[Haskell-cafe] Trace parser

[Andy Georges]

Hello,

I'm looking for a bit of help (ok, a lot) the speed up my program  
which I use to build a calltree out of an annotated program execution  
trace. To give you an idea about the sluggishness at the moment, for  
a trace containing 70MB, it has been running for about 10 hours  
straight (AMD Athlon XP (Barton) 2600+).

The trace contains lines made up of a number of fields:

C 4 1000 1000000
C 4 1001 1000200
R 4 1001 1003045
R 4 1000 1003060

C indicates a function entrypoint (call), R indicates a function  
exitpoint (return). The second field indicates which thread is  
executing the function, the third field denotes the function id, the  
last field contains a performance counter value. As you can see,  
numbering each line with a pre-order and a post-order number yields a  
list that can be transformed easily into a tree, which can then be  
manipulated. The first goal is to build the tree. This is done in the  
following code:


data ParserState = ParserState { methodStack :: !ThreadMap
                                , methodQueue :: !ThreadMap
                                , pre         :: !Integer
                                , post        :: !Integer
                                , methodMap   :: !MethodMap
                                , currentThread :: !Integer
                                } deriving (Show)

initialParserState :: ParserState
initialParserState = ParserState e e 0 0 e 0
   where e = M.empty :: Map Integer a

readInteger :: B.ByteString -> Integer
readInteger = fromIntegral . fst . fromJust . B.readInt


parseTraceMonadic :: [B.ByteString] -> ParserState
parseTraceMonadic ss = state { methodQueue = M.map reverse  
(methodQueue state) }
   where state = execState (mapM_ (\x -> modify (updateState x) >>  
get >>= (`seq` return ())) ss) initialParserState


updateState :: B.ByteString -> ParserState -> ParserState
updateState s state = case (B.unpack $ head fields) of
   "M" -> updateStateMethod     fields state
   "E" -> updateStateException  fields state
   "C" -> updateStateEntry      fields state
   "R" -> updateStateExit       fields state
   where fields = B.splitWith (== ' ') s


updateStateMethod :: [B.ByteString] -> ParserState -> ParserState
updateStateMethod (_:methodId:methodName:_) state = state { methodMap  
= M.insert (readInteger methodId) methodName (methodMap state) }

updateStateException :: [B.ByteString] -> ParserState -> ParserState
updateStateException _ state = state

updateStateEntry :: [B.ByteString] -> ParserState -> ParserState
updateStateEntry (_:ss) state = {-Debug.Trace.trace ("before: " ++  
(show state) ++ "\nafter: " ++ (show newstate)) $-} newstate
   where newstate = state { methodStack = updateMap thread  
(methodStack state) (\x y -> Just (x:y)) (pre state, 0, method)
                                       , pre = ((+1) $! (pre state))
                                       }
         method = mkMethod (Prelude.map B.unpack ss)
         thread = Method.thread method

updateStateExit :: [B.ByteString] -> ParserState -> ParserState
updateStateExit (_:ss) state = {-Debug.Trace.trace ("before: " ++  
(show state)) $-} case updateMethod m (Prelude.map B.unpack ss) of
                                    Just um -> state { methodStack =  
M.update (\x -> Just (tail x)) thread (methodStack state)
                                                     , methodQueue =  
updateMap thread (methodQueue state) (\x y -> Just (x:y)) (pre_, post  
state, um)
                                                     , post = ((+1)  
$! (post state))
                                                     }
                                    Nothing -> error $ "Top of the  
stack is mismatching! Expected " ++ (show m) ++ " yet got " ++ (show  
ss) ++ "\n" ++ (show state)
   where method = mkMethod (Prelude.map B.unpack ss)
         thread = Method.thread method
         (pre_, _, m) = case M.lookup thread (methodStack state) of
                           Just stack -> head stack
                           Nothing    -> error $ "Method stack has  
not been found for thread " ++ (show thread) ++ " -> fields: " ++  
(show ss)


updateMap key map f value = case M.member key map of
                               True  -> M.update (f value) key map
                               False -> M.insert key [value] map

As you can see, the state is updated for each entry, a stack being  
maintained with methods we've seen up to now, and a list with methods  
that have received both pre and post order numbers, and of which both  
the entry and exit point have been parsed. I am using a ByteString,  
because using a plain String is causing the program to grab far too  
much heap.

The mkMethod yields a Method like this:


data Method = Method { mid :: Integer
                      , thread :: Integer
                      , instruction_entry :: Integer
                      , instruction_exit :: Integer
                      } deriving (Eq, Show)

eM = Method 0 0 0 0

mkMethod :: [String] -> Method
mkMethod s = let [_thread, _id, _entry] = take 3 $ map (read ::  
String -> Integer) s
              in [_thread, _id, _entry] `seq` Method { mid = _id
                                                     , thread = _thread
                                                     ,  
instruction_entry = _entry
                                                     ,  
instruction_exit = 0
                                                     }

updateMethod :: Method -> [String] -> Maybe Method
updateMethod (Method mid thread instruction_entry instruction_exit ) s
   | thread == _thread && mid == _id = _exit `seq` Just Method { mid  
= mid
                                                               ,  
thread = thread
                                                               ,  
instruction_entry = instruction_entry
                                                               ,  
instruction_exit = _exit
                                                               }
   | otherwise = Nothing
   where [_thread, _id, _exit] = take 3 $ map (read :: String ->  
Integer) s


Any suggestions for improving this code?

Thanks,

Andy