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 MachOp
  15 import CmmUtils
  16 import CgUtils
  17 import CgMonad
  18 import CgForeignCall
  19 import ForeignCall
  20 import ClosureInfo
  21 import FastString
  22 import HscTypes
  23 import Char
  24 import StaticFlags
  25 import PackageConfig
  26
  27 cgTickBox :: Module -> Int -> Code
  28 cgTickBox mod n = do
  29        let tick_box = (cmmIndex I64
  30                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  31                        (fromIntegral n)
  32                       )
  33        stmtsC [ CmmStore tick_box
  34                          (CmmMachOp (MO_Add I64)
  35                                                [ CmmLoad tick_box I64
  36                                                , CmmLit (CmmInt 1 I64)
  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 I64)
  51                                         | _ <- take hpc_tickCount [0..]
  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 this_mod (NoHpcInfo {}) = error "TODO: impossible"
  61
  62 initHpc :: Module -> HpcInfo -> Code
  63 initHpc this_mod (HpcInfo tickCount hashNo)
  64   = do { id <- newNonPtrTemp wordRep -- TODO FIXME NOW
  65        ; emitForeignCall'
  66                PlayRisky
  67                [(id,NoHint)]
  68                (CmmForeignCall
  69                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
  70                   CCallConv
  71                )
  72                [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
  73                , (CmmLit $ mkIntCLit tickCount,NoHint)
  74                , (CmmLit $ mkIntCLit hashNo,NoHint)
  75                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
  76                ]
  77                (Just [])
  78                NoC_SRT -- No SRT b/c we PlayRisky
  79        }
  80   where
  81        mod_alloc = mkFastString "hs_hpc_module"
  82