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 Data.Char
  23 import StaticFlags
  24 import BasicTypes
  25
  26 mkTickBox :: Module -> Int -> CmmAGraph
  27 mkTickBox mod n
  28   = mkStore tick_box (CmmMachOp (MO_Add W64)
  29                                 [ CmmLoad tick_box b64
  30                                 , CmmLit (CmmInt 1 W64)
  31                                 ])
  32   where
  33     tick_box = cmmIndex W64
  34                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  35                         (fromIntegral n)
  36
  37 initHpc :: Module -> HpcInfo -> FCode CmmAGraph
  38 -- Emit top-level tables for HPC and return code to initialise
  39 initHpc _ (NoHpcInfo {})
  40   = return mkNop
  41 initHpc this_mod (HpcInfo tickCount hashNo)
  42   = getCode $ whenC opt_Hpc $
  43     do  { emitData ReadOnlyData
  44               [ CmmDataLabel mkHpcModuleNameLabel
  45               , CmmString $ map (fromIntegral . ord)
  46                                (full_name_str)
  47                             ++ [0]
  48               ]
  49         ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
  50               ] ++
  51               [ CmmStaticLit (CmmInt 0 W64)
  52               | _ <- take tickCount [0::Int ..]
  53               ]
  54
  55         ; id <- newTemp bWord -- TODO FIXME NOW
  56         ; emitCCall
  57                [(id,NoHint)]
  58                (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
  59                [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
  60                , (CmmLit $ mkIntCLit tickCount,NoHint)
  61                , (CmmLit $ mkIntCLit hashNo,NoHint)
  62                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
  63                ]
  64        }
  65   where
  66     mod_alloc = mkFastString "hs_hpc_module"
  67     module_name_str = moduleNameString (Module.moduleName this_mod)
  68     full_name_str   = if modulePackageId this_mod == mainPackageId
  69                       then module_name_str
  70                       else packageIdString (modulePackageId this_mod) ++ "/" ++
  71                            module_name_str
  72
  73
  74