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