[PATCH stable-2.16 1/3] debugging allocation

['Brian Foley' via ganeti-devel]

(cherry picked from commit 33745104fd9286477cbba13cd9565a53eb64c56d)
Signed-off-by: Brian Foley <bpfo...@google.com>
---
 src/Ganeti/Query/Server.hs |    5 +++--
 src/Ganeti/UDSServer.hs    |   12 ++++++++++--
 2 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/Ganeti/Query/Server.hs b/src/Ganeti/Query/Server.hs
index 1b7cfa5..db27fc8 100644
--- a/src/Ganeti/Query/Server.hs
+++ b/src/Ganeti/Query/Server.hs
@@ -98,7 +98,6 @@ import qualified Ganeti.Version as Version
 import Ganeti.WConfd.Client ( getWConfdClient, withLockedConfig, writeConfig
                             , cleanupLocks)
 
-
 -- | Creates a `ClientId` that identifies the current luxi
 -- (process, thread).
 --
@@ -180,7 +179,9 @@ handleCallWrapper _ _ (Bad msg) _ =
   return . Bad . ConfigurationError $
            "I do not have access to a valid configuration, cannot\
            \ process queries: " ++ msg
-handleCallWrapper qlock qstat (Ok config) op = handleCall qlock qstat config op
+handleCallWrapper qlock qstat (Ok config) op = do
+  logInfo $ "handleCallWrapper for " ++ (show op)
+  handleCall qlock qstat config op
 
 -- | Actual luxi operation handler.
 handleCall :: Lock -> JQStatus
diff --git a/src/Ganeti/UDSServer.hs b/src/Ganeti/UDSServer.hs
index 77e2e88..254d0e4 100644
--- a/src/Ganeti/UDSServer.hs
+++ b/src/Ganeti/UDSServer.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
 
 {-| Implementation of the Ganeti Unix Domain Socket JSON server interface.
 
@@ -100,6 +101,7 @@ import Ganeti.Logging
 import Ganeti.THH
 import Ganeti.Utils
 import Ganeti.Constants (privateParametersBlacklist)
+import GHC.Stats
 
 -- * Utility functions
 
@@ -466,6 +468,7 @@ isRisky msg = case msg of
   RecvOk payload -> any (`isInfixOf` payload) privateParametersBlacklist
   _ -> False
 
+
 -- | Reads a request, passes it to a handler and sends a response back to the
 -- client.
 handleClient
@@ -493,7 +496,6 @@ handleClient handler client = do
       liftBase $ sendMsg client outMsg
       return close
 
-
 -- | Main client loop: runs one loop of 'handleClient', and if that
 -- doesn't report a finished (closed) connection, restarts itself.
 clientLoop
@@ -502,7 +504,13 @@ clientLoop
     -> Client
     -> m ()
 clientLoop handler client = do
-  result <- handleClient handler client
+  t1 <- liftBase getCurrentTimeUSec
+  s1 <- liftBase getGCStats
+  !result <- handleClient handler client
+  t2 <- liftBase getCurrentTimeUSec
+  s2 <- liftBase getGCStats
+  logInfo $ "BUFFY " ++ show ((t2-t1) `div` 1000) ++ "ms, "
+    ++ "bytesAllocatedDelta=" ++ show (bytesAllocated s2 - bytesAllocated s1)
   {- It's been observed sometimes that reading immediately after sending
      a response leads to worse performance, as there is nothing to read and
      the system calls are just wasted. Thus yielding before reading gives
-- 
1.7.9.5