Records.xhs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Contains the structures to hold allocation information
-- used when debugging.
--
-----------------------------------------------------------------------------

module WinDll.Debug.Records
 ( MemAlloc(..)
 , Caller(..)
 , fileName
 , writeMemAlloc
 ) where

import WinDll.Debug.Stack ( Stack )
import System.Directory ( doesFileExist, createDirectoryIfMissing )
import Control.Monad ( when )
import Control.Concurrent.MVar

import System.FilePath
import System.IO.Unsafe

type PtrLocation = Int -- 32bit signed integer, like the rest of hs2lib we assume x86
type MemSize     = Int

-- | Identifier which shows which function was invoked to do allocations
data Caller = Malloc
            | Alloc
            | ReAlloc
            | Other
            | Record
            deriving (Show, Read)

-- | The allocation structure/record that is used to keep track of allocations
data MemAlloc = MemAlloc { memFun   :: Caller
                         , memStack :: Stack
                         , memStart :: PtrLocation 
                         , memStop  :: Maybe PtrLocation
                         , memSize  :: Maybe MemSize 
                         , memTime  :: String
                         }
              | MemFree { memStack :: Stack
                        , memStart :: PtrLocation
                        , memSize  :: Maybe MemSize
                        , memTime  :: String
                        }
              deriving (Show, Read)
              
-- | The directory in which to write the results to.
directory :: String
directory = "MemDumps"
       
-- | The file to write the results too       
fileName :: IO String
fileName = do let path = "Memory.dump"
              createDirectoryIfMissing True directory
              return $ directory </> path
              
-- | Synchronization variable between threads.
fileLock :: MVar Int
{-# NOINLINE fileLock #-}
fileLock = unsafePerformIO $ newMVar 0
                  
-- | Write out a single allocation structure out to file.
writeMemAlloc :: MemAlloc -> IO ()
writeMemAlloc mem = do takeMVar fileLock
                       fn <- fileName
                       exists <- doesFileExist fn
                       when (not exists) $ writeFile fn []
                       appendFile fn (show mem ++ "\n")
                       putMVar fileLock 0