compiler/codeGen/CgHpc.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- Code generation for coverage
  11 --
  12 -- (c) Galois Connections, Inc. 2006
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module CgHpc (cgTickBox, initHpc, hpcTable) where
  17
  18 import Cmm
  19 import CLabel
  20 import Module
  21 import MachOp
  22 import CmmUtils
  23 import CgUtils
  24 import CgMonad
  25 import CgForeignCall
  26 import ForeignCall
  27 import ClosureInfo
  28 import FastString
  29 import HscTypes
  30 import Char
  31 import StaticFlags
  32 import PackageConfig
  33
  34 import Data.Word
  35
  36 cgTickBox :: Module -> Int -> Code
  37 cgTickBox mod n = do
  38        let tick_box = (cmmIndex I64
  39                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  40                        (fromIntegral n)
  41                       )
  42        stmtsC [ CmmStore tick_box
  43                          (CmmMachOp (MO_Add I64)
  44                                                [ CmmLoad tick_box I64
  45                                                , CmmLit (CmmInt 1 I64)
  46                                                ])
  47               ]
  48
  49 hpcTable :: Module -> HpcInfo -> Code
  50 hpcTable this_mod (HpcInfo hpc_tickCount _) = do
  51                         emitData ReadOnlyData
  52                                         [ CmmDataLabel mkHpcModuleNameLabel
  53                                         , CmmString $ map (fromIntegral . ord)
  54                                                          (full_name_str)
  55                                                       ++ [0]
  56                                         ]
  57                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
  58                                         ] ++
  59                                         [ CmmStaticLit (CmmInt 0 I64)
  60                                         | _ <- take hpc_tickCount [0::Int ..]
  61                                         ]
  62   where
  63     module_name_str = moduleNameString (Module.moduleName this_mod)
  64     full_name_str   = if modulePackageId this_mod == mainPackageId
  65                       then module_name_str
  66                       else packageIdString (modulePackageId this_mod) ++ "/" ++
  67                            module_name_str
  68
  69 hpcTable this_mod (NoHpcInfo {}) = error "TODO: impossible"
  70
  71 initHpc :: Module -> HpcInfo -> Code
  72 initHpc this_mod (HpcInfo tickCount hashNo)
  73   = do { id <- newNonPtrTemp wordRep -- TODO FIXME NOW
  74        ; emitForeignCall'
  75                PlayRisky
  76                [(id,NoHint)]
  77                (CmmCallee
  78                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
  79                   CCallConv
  80                )
  81                [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
  82                , (word32 tickCount, NoHint)
  83                , (word32 hashNo,    NoHint)
  84                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
  85                ]
  86                (Just [])
  87                NoC_SRT -- No SRT b/c we PlayRisky
  88                CmmMayReturn
  89        }
  90   where
  91        word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) I32)
  92        mod_alloc = mkFastString "hs_hpc_module"
  93