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