compiler/codeGen/StgCmmHpc.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 StgCmmHpc ( initHpc, mkTickBox ) where
  17
  18 import StgCmmUtils
  19 import StgCmmMonad
  20 import StgCmmForeign
  21 import StgCmmClosure
  22
  23 import MkZipCfgCmm
  24 import Cmm
  25 import CLabel
  26 import Module
  27 import CmmUtils
  28 import ForeignCall
  29 import FastString
  30 import HscTypes
  31 import Char
  32 import StaticFlags
  33 import PackageConfig
  34
  35 mkTickBox :: Module -> Int -> CmmAGraph
  36 mkTickBox mod n
  37   = mkStore tick_box (CmmMachOp (MO_Add W64)
  38                                 [ CmmLoad tick_box b64
  39                                 , CmmLit (CmmInt 1 W64)
  40                                 ])
  41   where
  42     tick_box = cmmIndex W64
  43                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  44                         (fromIntegral n)
  45
  46 initHpc :: Module -> HpcInfo -> FCode CmmAGraph
  47 -- Emit top-level tables for HPC and return code to initialise
  48 initHpc this_mod (NoHpcInfo {})
  49   = return mkNop
  50 initHpc this_mod (HpcInfo tickCount hashNo)
  51   = getCode $ whenC opt_Hpc $
  52     do  { emitData ReadOnlyData
  53               [ CmmDataLabel mkHpcModuleNameLabel
  54               , CmmString $ map (fromIntegral . ord)
  55                                (full_name_str)
  56                             ++ [0]
  57               ]
  58         ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
  59               ] ++
  60               [ CmmStaticLit (CmmInt 0 W64)
  61               | _ <- take tickCount [0::Int ..]
  62               ]
  63
  64         ; id <- newTemp bWord -- TODO FIXME NOW
  65         ; emitCCall
  66                [(id,NoHint)]
  67                (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
  68                [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
  69                , (CmmLit $ mkIntCLit tickCount,NoHint)
  70                , (CmmLit $ mkIntCLit hashNo,NoHint)
  71                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
  72                ]
  73        }
  74   where
  75     mod_alloc = mkFastString "hs_hpc_module"
  76     module_name_str = moduleNameString (Module.moduleName this_mod)
  77     full_name_str   = if modulePackageId this_mod == mainPackageId
  78                       then module_name_str
  79                       else packageIdString (modulePackageId this_mod) ++ "/" ++
  80                            module_name_str
  81
  82
  83