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