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