Output.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Module to process the Memory.dump file. From loading to analysis.
--
-----------------------------------------------------------------------------

module WinDll.Debug.Output where

import WinDll.Session.Debug
import WinDll.Debug.Records
import WinDll.Debug.Stack
import WinDll.Debug.Heap
import WinDll.Debug.Analyzer
import WinDll.Utils.Feedback

import Data.Maybe
import Data.List
import Data.Function

-- | Load and Parse files
loadAndParse :: Exec ()
loadAndParse = do session <- get
                  let file = absPath session
                  inform _normal $ "Reading file '" ++ file ++ "'..."
                  contents <- liftIO $ readFile file
                  let mems = map read $ lines contents
                  let len  = length mems
                  inform _normal $ "Found " ++ show len ++ " record(s)."
                  put $ session { memAllocs    = len `seq` mems
                                , memAllocsLen = len
                                }
                                
data Outstanding = Outs { outCount     :: Int
                        , outStack     :: Stack
                        , outAddresses :: [Address]
                        }
                        
instance Show Outstanding where
  show x = show (outCount x) ++ " unfreed references found originating from " ++ printStack (outStack x)
                                
data MemResult 
  = MemResult { memHeap    :: Heap
              , memRSize   :: Int
              , memOuts    :: [Outstanding]
              , memUnAlloc :: Int
              }
  deriving (Show)
             
-- | Analyze the memory allocation functions             
analyze :: Exec MemResult
analyze = do session <- get
             heap'   <- emulate (memAllocs session) (0, memAllocsLen session) (heap session) 
             hp      <- normalizeHeap heap'
             let allocs = filter isMem $ memAllocs session
                 isMem  = \x -> case x of 
                                  MemAlloc{} -> True
                                  _          -> False
                 locs   = getStartingAddr hp
                 found  = mapMaybe (flip lookupStack allocs) locs
                 size   = sizeHeap hp
                 outst  = size - length found
                 merged = groupBy ((==) `on` snd) $ sortBy (compare `on` snd) found
                 outdat = map (\x -> guard (not $ null x) >> (return $ Outs (length x) (snd $ head x) (map fst x))) merged
             put $ session { memAllocs =[], memAllocsLen = 0, heap = hp }
             return $ MemResult { memHeap    = hp 
                                , memRSize   = size
                                , memUnAlloc = outst
                                , memOuts    = catMaybes outdat
                                }

-- | Lookup an address and return its associated stack
lookupStack :: Address -> [MemAlloc] -> Maybe (Address, Stack)
lookupStack _ []                                           = Nothing
lookupStack p (x:xs) | p >= memStart x && p `lt` memStop x = return (p, memStack x)
                     | otherwise                           = lookupStack p xs

lt = \x -> maybe False id . liftM (x <=)
                                
-- | Show the result of the analysis 
displayResults :: MemResult -> Exec ()
displayResults mem = do echo $ "Found " ++ show (memRSize mem) ++ " outstanding allocation(s)."
                        when (memUnAlloc mem > 0) $ echo $ "Unable to resolve " ++ show (memUnAlloc mem) ++ " allocation(s)."
                        liftIO $ mapM_ print $ memOuts mem
                        when (memUnAlloc mem == 0 && memRSize mem == 0) $ liftIO $ putStrLn "Congratulations, No memory leak(s) detected."
                   
-- | Discover file locations
discoverFiles :: Exec ()
discoverFiles = do return ()