Bump base lower version to 4.5 (the version GHC 7.4.1 came with)
[packages/hpc.git] / Trace / Hpc / Reflect.hsc
1 {-# LANGUAGE ForeignFunctionInterface #-}
2 #ifdef __GLASGOW_HASKELL__
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5
6 module Trace.Hpc.Reflect
7   ( clearTix
8   , examineTix
9   , updateTix
10   ) where
11
12 import Trace.Hpc.Tix
13
14 import Foreign.C.String
15 import Foreign.Marshal.Array
16 import Foreign.Ptr
17 import Foreign.Storable ( Storable(..) )
18 import Data.Word 
19 import Trace.Hpc.Util
20 import System.IO.Unsafe
21
22 #include "Rts.h"
23
24 foreign import ccall unsafe hs_hpc_rootModule :: IO (Ptr ())
25
26 modInfo :: [ModuleInfo]
27 modInfo = unsafePerformIO $ do
28       ptr <- hs_hpc_rootModule 
29       moduleInfoList ptr
30
31 data ModuleInfo = ModuleInfo String Word32 Hash (Ptr Word64) 
32
33 moduleInfoList :: Ptr () -> IO [ModuleInfo]
34 moduleInfoList ptr
35   | ptr == nullPtr = return []
36   | otherwise = do
37         cModName  <- (#peek HpcModuleInfo, modName) ptr
38         modName   <- peekCString cModName
39         tickCount <- (#peek HpcModuleInfo, tickCount) ptr
40         hashNo    <- (#peek HpcModuleInfo, hashNo) ptr
41         tixArr    <- (#peek HpcModuleInfo, tixArr) ptr
42         next      <- (#peek HpcModuleInfo, next) ptr
43         rest      <- moduleInfoList next
44         return $ ModuleInfo modName tickCount (toHash (hashNo :: Int)) tixArr : rest
45
46 clearTix :: IO ()
47 clearTix = do
48       sequence_ [ pokeArray ptr $ take (fromIntegral count) $ repeat 0
49                 | ModuleInfo _mod count _hash ptr <- modInfo
50                 ]
51       return ()
52
53
54 examineTix :: IO Tix
55 examineTix = do
56       mods <- sequence [ do tixs <- peekArray (fromIntegral count) ptr
57                             return $ TixModule mod' hash (fromIntegral count)
58                                    $ map fromIntegral tixs
59                        | (ModuleInfo mod' count hash ptr) <- modInfo
60                        ]
61       return $ Tix mods
62
63 -- requirement that the tix be of the same shape as the 
64 -- internal tix.
65 updateTix :: Tix -> IO ()
66 updateTix (Tix modTixes) 
67   | length modTixes /= length modInfo = error "updateTix failed"
68   | otherwise = do
69       sequence_ [ pokeArray ptr $ map fromIntegral tixs
70                 | (ModuleInfo mod1 count1 hash1 ptr,
71                    TixModule mod2 hash2 count2 tixs) <- zip modInfo modTixes
72                 , if mod1 /= mod2 
73                 || (fromIntegral count1) /= count2 
74                 || hash1 /= hash2
75                 || length tixs /= count2
76                   then error "updateTix failed"
77                   else True
78                 ]
79       return ()
80