[Haskell-cafe] Trashing of memory: How to troubleshoot and fix?

[Joel Reymont]

Folks,

This is a I came up with a "scripting" environment for poker server  
people to excercise their server. All it basically does is compose  
and parse binary packets and let scripters send and receive them.

The issue I have is that the "script" runs fine on Mac OSX (1Gb of  
memory, though 6Gb VM) and runs out of memory on a Windows machine  
with 512Mb of memory and 768Mb of VM. The memory error is from malloc  
which leads me to believe memory fragmentation could be an issue.  
Running on Windows is a customer requirement.

I'm sending and receiving deeply nested structures although that is  
not my call as the server is in C++. Most of the time just one or two  
fields will be needed after the command is unpickled. Most of the  
commands are converted to strings and written to a Chan for logging,  
though.

I'm trying to launch 1000 scripts (separate threads) which just  
connect to the server, login and disconnect. The big issue is that  
the production scripts will run for hours, playing against one  
another. If I the maximum that I can handle is about 200 scripts that  
do nothing  that I failed the project.

I was wondering if peak memory usage was the issue but jugding from  
the GC stats it does not seem to be that high. Maybe I'm wrong. What  
do you guys make of this?

./logon +RTS -p -sblah

GC summary:
--
5,695,379,620 bytes allocated in the heap
1,274,038,800 bytes copied during GC
69,790,544 bytes maximum residency (53 sample(s))

       20433 collections in generation 0 (230.29s)
          53 collections in generation 1 (  5.15s)

         152 Mb total memory in use

   INIT  time    0.00s  (  0.04s elapsed)
   MUT   time   91.13s  (250.79s elapsed)
   GC    time  235.44s  (607.31s elapsed)
   RP    time    0.00s  (  0.00s elapsed)
   PROF  time    0.00s  (  0.00s elapsed)
   EXIT  time    0.00s  (  0.00s elapsed)
   Total time  326.57s  (858.14s elapsed)

   %GC time      72.1%  (70.8% elapsed)

   Alloc rate    62,497,307 bytes per MUT second

   Productivity  27.9% of total user, 10.6% of total elapsed

---
Time allocation and profiling report:
----
         total time  =       85.58 secs   (4279 ticks @ 20 ms)
         total alloc = 2,941,143,704 bytes  (excludes profiling  
overheads)

COST CENTRE                    MODULE               %time %alloc

exp/evalU/cmd                  Script.Engine         50.0   66.4
connect                        Main                  14.1   11.1
CAF                            Script.Engine         10.3    5.4
exp/if                         Script.Engine          8.8    4.8
send                           Main                   6.4    6.7
expect                         Main                   5.8    2.7
exp/evalU/sz                   Script.Engine          1.4    1.4
startSSL                       Script.Engine          1.3    0.1
---

expect -- receives command and unpickles it from a FastPackedString.
send -- pickles the command into a FastPackedString.

hGet from FPS:
---
hGet :: Handle -> Int -> IO FastString
hGet _ 0 = return empty
hGet h i = do fp <- mallocForeignPtr i
               l  <- withForeignPtr fp $ \p-> hGetBuf h p i
               return $ PS fp 0 l
--

The code for send:
---
send :: Command -> EngineState ()
send cmd@(Command kind props) =
     do liftIO $ yield
        w <- get
        let (_, cmd') = checkEncryption cmd
        send_ cmd'
        trace $ "Sent: " ++ show (kindOf cmd')
        tracecmd cmd'
---

The code for expect:
---
expect :: [CmdType] -> EngineState ()
expect kind =
     do w <- get
        let h = socket w
            secs = timeout_seconds w
        (Right fps) <- liftIO $ timeout secs $ P.hGet h 4
        trace $ "Size: " ++ show (P.unpackWords fps)
        state <- liftIO $ hIsEOF h
        trace $ "Connection closed: " ++ show state
        (Right size', _) <- {-# SCC "exp/evalU/sz" #-}return $ evalU  
fps appU
        let size = fromIntegral $ (unLE size' :: Word16) - 4
        (Right packet) <- liftIO $ timeout secs $ P.hGet h size
        guard $ size == P.length packet
        cmd' <- {-# SCC "exp/evalU/cmd" #-}return $ evalU packet appU  
-- unpickle command
        case cmd' of
                  (Left s, _) -> do trace $ "Error: " ++ s
                                    throwError $ "Cannot parse: "
                                                ++ show  
(P.unpackWords packet)
                  (Right _, _) -> do return ()
        let (Right cmd'', _) = cmd'
        let kind' = kindOf cmd''
        let vars = (cmdKind := kind'):(propsOf cmd'')
            vars'=  map (\p -> (attrName p, p)) vars
        -- update world
        {-# SCC "exp/putWorld" #-}put $ w { cmd = cmd'', cmdVars =  
M.fromList vars' }
        -- move on
        {-# SCC "processCbks" #-}processCallbacks
        {-# SCC "exp/if" #-}if elem kind' (skip w)
           then tracecmd cmd'' >> expect kind -- keep going
           else match kind cmd''

--
http://wagerlabs.com/