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 CmmUtils
  15 import CgUtils
  16 import CgMonad
  17 import CgForeignCall
  18 import ForeignCall
  19 import ClosureInfo
  20 import FastString
  21 import HscTypes
  22 import Panic
  23 import BasicTypes
  24
  25 import Data.Char
  26 import Data.Word
  27
  28 cgTickBox :: Module -> Int -> Code
  29 cgTickBox mod n = do
  30        let tick_box = (cmmIndex W64
  31                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  32                        (fromIntegral n)
  33                       )
  34        stmtsC [ CmmStore tick_box
  35                          (CmmMachOp (MO_Add W64)
  36                                                [ CmmLoad tick_box b64
  37                                                , CmmLit (CmmInt 1 W64)
  38                                                ])
  39               ]
  40
  41 hpcTable :: Module -> HpcInfo -> Code
  42 hpcTable this_mod (HpcInfo hpc_tickCount _) = do
  43                         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 hpc_tickCount [0::Int ..]
  53                                         ]
  54   where
  55     module_name_str = moduleNameString (Module.moduleName this_mod)
  56     full_name_str   = if modulePackageId this_mod == mainPackageId
  57                       then module_name_str
  58                       else packageIdString (modulePackageId this_mod) ++ "/" ++
  59                            module_name_str
  60
  61 hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"
  62
  63 initHpc :: Module -> HpcInfo -> Code
  64 initHpc this_mod (HpcInfo tickCount hashNo)
  65   = do { id <- newTemp bWord
  66        ; emitForeignCall'
  67                PlayRisky
  68                [CmmHinted id NoHint]
  69                (CmmCallee
  70                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
  71                   CCallConv
  72                )
  73                [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
  74                , CmmHinted (word32 tickCount) NoHint
  75                , CmmHinted (word32 hashNo)    NoHint
  76                , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint
  77                ]
  78                (Just [])
  79                NoC_SRT -- No SRT b/c we PlayRisky
  80                CmmMayReturn
  81        }
  82   where
  83        word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32)
  84        mod_alloc = mkFastString "hs_hpc_module"
  85 initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo"
  86