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