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 FastString
  21 import HscTypes
  22 import Char
  23 import StaticFlags
  24
  25 cgTickBox :: Module -> Int -> Code
  26 cgTickBox mod n = do
  27        let tick_box = (cmmIndex I64
  28                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
  29                        (fromIntegral n)
  30                       )
  31        stmtsC [ CmmStore tick_box
  32                          (CmmMachOp (MO_Add I64)
  33                                                [ CmmLoad tick_box I64
  34                                                , CmmLit (CmmInt 1 I64)
  35                                                ])
  36               ]
  37        let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ mod
  38
  39        whenC (opt_Hpc_Tracer) $ do
  40            emitForeignCall'
  41                PlayRisky        -- ??
  42                []
  43                (CmmForeignCall
  44                  (CmmLit $ CmmLabel $ mkForeignLabel visible_tick Nothing False)
  45                   CCallConv
  46                )
  47                [ (CmmMachOp (MO_Add I32)
  48                      [ CmmLoad ext_tick_box I32
  49                      , CmmLit (CmmInt (fromIntegral n) I32)
  50                      ]
  51                   ,  NoHint) ]
  52                (Just [])
  53    where
  54       visible_tick = mkFastString "hs_hpc_tick"
  55
  56 hpcTable :: Module -> HpcInfo -> Code
  57 hpcTable this_mod hpc_tickCount = do
  58                         emitData ReadOnlyData
  59                                         [ CmmDataLabel mkHpcModuleNameLabel
  60                                         , CmmString $ map (fromIntegral . ord)
  61                                                          (module_name_str)
  62                                                       ++ [0]
  63                                         ]
  64                         emitData Data
  65                                         [ CmmDataLabel (mkHpcModuleOffsetLabel this_mod)
  66                                         , CmmStaticLit (CmmInt 0 I32)
  67                                         ]
  68                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
  69                                         ] ++
  70                                         [ CmmStaticLit (CmmInt 0 I64)
  71                                         | _ <- take hpc_tickCount [0..]
  72                                         ]
  73   where
  74     module_name_str = moduleNameString (Module.moduleName this_mod)
  75
  76
  77 initHpc :: Module -> HpcInfo -> Code
  78 initHpc this_mod tickCount
  79   = do { id <- newTemp wordRep
  80        ; emitForeignCall'
  81                PlayRisky
  82                [(id,NoHint)]
  83                (CmmForeignCall
  84                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
  85                   CCallConv
  86                )
  87                [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
  88                , (CmmLit $ mkIntCLit tickCount,NoHint)
  89                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
  90                ]
  91                (Just [])
  92        ; let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ this_mod
  93        ; stmtsC [ CmmStore ext_tick_box (CmmReg id) ]
  94        }
  95   where
  96        mod_alloc = mkFastString "hs_hpc_module"
  97