Merging in the new codegen branch
[ghc.git] / compiler / codeGen / StgCmmHpc.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for coverage
4 --
5 -- (c) Galois Connections, Inc. 2006
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -w #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 -- for details
15
16 module StgCmmHpc ( initHpc, mkTickBox ) where
17
18 import StgCmmUtils
19 import StgCmmMonad
20 import StgCmmForeign
21 import StgCmmClosure
22
23 import MkZipCfgCmm
24 import Cmm
25 import CLabel
26 import Module
27 import CmmUtils
28 import ForeignCall
29 import FastString
30 import HscTypes
31 import Char
32 import StaticFlags
33 import PackageConfig
34
35 mkTickBox :: Module -> Int -> CmmAGraph
36 mkTickBox mod n
37 = mkStore tick_box (CmmMachOp (MO_Add W64)
38 [ CmmLoad tick_box b64
39 , CmmLit (CmmInt 1 W64)
40 ])
41 where
42 tick_box = cmmIndex W64
43 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
44 (fromIntegral n)
45
46 initHpc :: Module -> HpcInfo -> FCode CmmAGraph
47 -- Emit top-level tables for HPC and return code to initialise
48 initHpc this_mod (NoHpcInfo {})
49 = return mkNop
50 initHpc this_mod (HpcInfo tickCount hashNo)
51 = getCode $ whenC opt_Hpc $
52 do { emitData ReadOnlyData
53 [ CmmDataLabel mkHpcModuleNameLabel
54 , CmmString $ map (fromIntegral . ord)
55 (full_name_str)
56 ++ [0]
57 ]
58 ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
59 ] ++
60 [ CmmStaticLit (CmmInt 0 W64)
61 | _ <- take tickCount [0::Int ..]
62 ]
63
64 ; id <- newTemp bWord -- TODO FIXME NOW
65 ; emitCCall
66 [(id,NoHint)]
67 (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
68 [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
69 , (CmmLit $ mkIntCLit tickCount,NoHint)
70 , (CmmLit $ mkIntCLit hashNo,NoHint)
71 , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
72 ]
73 }
74 where
75 mod_alloc = mkFastString "hs_hpc_module"
76 module_name_str = moduleNameString (Module.moduleName this_mod)
77 full_name_str = if modulePackageId this_mod == mainPackageId
78 then module_name_str
79 else packageIdString (modulePackageId this_mod) ++ "/" ++
80 module_name_str
81
82
83