Fix ghcii.sh creation
[ghc-hetmet.git] / compiler / codeGen / CgHpc.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for coverage
4 --
5 -- (c) Galois Connections, Inc. 2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgHpc (cgTickBox, initHpc, hpcTable) where
10
11 import Cmm
12 import CLabel
13 import Module
14 import MachOp
15 import CmmUtils
16 import CgUtils
17 import CgMonad
18 import CgForeignCall
19 import ForeignCall
20 import FastString
21 import HscTypes
22 import Char
23 import StaticFlags
24
25 cgTickBox :: Module -> Int -> Code
26 cgTickBox mod n = do
27        let tick_box = (cmmIndex I64
28                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
29                        (fromIntegral n)
30                       )
31        stmtsC [ CmmStore tick_box
32                          (CmmMachOp (MO_Add I64)
33                                                [ CmmLoad tick_box I64
34                                                , CmmLit (CmmInt 1 I64)
35                                                ])
36               ] 
37        let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ mod
38
39        whenC (opt_Hpc_Tracer) $ do
40            emitForeignCall'
41                PlayRisky        -- ??
42                []
43                (CmmForeignCall
44                  (CmmLit $ CmmLabel $ mkForeignLabel visible_tick Nothing False)
45                   CCallConv
46                )
47                [ (CmmMachOp (MO_Add I32)
48                      [ CmmLoad ext_tick_box I32
49                      , CmmLit (CmmInt (fromIntegral n) I32)
50                      ]
51                   ,  NoHint)
52                ,  ( CmmReg (CmmGlobal CurrentTSO)
53                   , PtrHint 
54                   )
55                ]
56                (Just [])
57    where
58       visible_tick = mkFastString "hs_hpc_tick"
59
60 hpcTable :: Module -> HpcInfo -> Code
61 hpcTable this_mod (HpcInfo hpc_tickCount _) = do
62                         emitData ReadOnlyData
63                                         [ CmmDataLabel mkHpcModuleNameLabel
64                                         , CmmString $ map (fromIntegral . ord)
65                                                          (module_name_str)
66                                                       ++ [0]
67                                         ]
68                         emitData Data   -- change Offset => Data or Info
69                                         [ CmmDataLabel (mkHpcModuleOffsetLabel this_mod)
70                                         , CmmStaticLit (CmmInt 0 I32)   -- stored offset?
71                                         ]
72                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
73                                         ] ++
74                                         [ CmmStaticLit (CmmInt 0 I64)
75                                         | _ <- take hpc_tickCount [0..]
76                                         ]
77   where
78     module_name_str = moduleNameString (Module.moduleName this_mod)
79 hpcTable this_mod (NoHpcInfo) = error "TODO: impossible"
80
81 initHpc :: Module -> HpcInfo -> Code
82 initHpc this_mod (HpcInfo tickCount hashNo)
83   = do { id <- newTemp wordRep
84        ; emitForeignCall'
85                PlayRisky
86                [(id,NoHint)]
87                (CmmForeignCall
88                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
89                   CCallConv
90                )
91                [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
92                , (CmmLit $ mkIntCLit tickCount,NoHint)
93                , (CmmLit $ mkIntCLit hashNo,NoHint)
94                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
95                ]
96                (Just [])
97        ; let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ this_mod
98        ; stmtsC [ CmmStore ext_tick_box (CmmReg id) ]
99        }
100   where
101        mod_alloc = mkFastString "hs_hpc_module"
102