compiler/codeGen/CgHpc.hs

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