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