compiler/codeGen/StgCmmHpc.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for coverage
   4 --
   5 -- (c) Galois Connections, Inc. 2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmHpc ( initHpc, mkTickBox ) where
  10
  11 import StgCmmUtils
  12 import StgCmmMonad
  13 import StgCmmForeign
  14
  15 import MkZipCfgCmm
  16 import Cmm
  17 import CLabel
  18 import Module
  19 import CmmUtils
  20 import FastString
  21 import HscTypes
  22 import Char
  23 import StaticFlags
  24
  25 mkTickBox :: Module -> Int -> CmmAGraph
  26 mkTickBox mod n
  27   = mkStore tick_box (CmmMachOp (MO_Add W64)
  28                                 [ CmmLoad tick_box b64
  29                                 , CmmLit (CmmInt 1 W64)
  30                                 ])
  31   where
  32     tick_box = cmmIndex W64
  33                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  34                         (fromIntegral n)
  35
  36 initHpc :: Module -> HpcInfo -> FCode CmmAGraph
  37 -- Emit top-level tables for HPC and return code to initialise
  38 initHpc _ (NoHpcInfo {})
  39   = return mkNop
  40 initHpc this_mod (HpcInfo tickCount hashNo)
  41   = getCode $ whenC opt_Hpc $
  42     do  { emitData ReadOnlyData
  43               [ CmmDataLabel mkHpcModuleNameLabel
  44               , CmmString $ map (fromIntegral . ord)
  45                                (full_name_str)
  46                             ++ [0]
  47               ]
  48         ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
  49               ] ++
  50               [ CmmStaticLit (CmmInt 0 W64)
  51               | _ <- take tickCount [0::Int ..]
  52               ]
  53
  54         ; id <- newTemp bWord -- TODO FIXME NOW
  55         ; emitCCall
  56                [(id,NoHint)]
  57                (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
  58                [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
  59                , (CmmLit $ mkIntCLit tickCount,NoHint)
  60                , (CmmLit $ mkIntCLit hashNo,NoHint)
  61                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
  62                ]
  63        }
  64   where
  65     mod_alloc = mkFastString "hs_hpc_module"
  66     module_name_str = moduleNameString (Module.moduleName this_mod)
  67     full_name_str   = if modulePackageId this_mod == mainPackageId
  68                       then module_name_str
  69                       else packageIdString (modulePackageId this_mod) ++ "/" ++
  70                            module_name_str
  71
  72
  73