summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgExpr.lhs11
-rw-r--r--compiler/codeGen/CgHpc.hs71
-rw-r--r--compiler/codeGen/CodeGen.lhs53
3 files changed, 119 insertions, 16 deletions
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index fff2b3d564..88340789f1 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/compiler/codeGen/CgExpr.lhs
@@ -26,6 +26,7 @@ import CgTailCall
import CgInfoTbls
import CgForeignCall
import CgPrimOp
+import CgHpc
import CgUtils
import ClosureInfo
import Cmm
@@ -252,6 +253,16 @@ cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
\end{code}
%********************************************************
+%* *
+%* Hpc Tick Boxes *
+%* *
+%********************************************************
+
+\begin{code}
+cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
+\end{code}
+
+%********************************************************
%* *
%* Non-top-level bindings *
%* *
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
new file mode 100644
index 0000000000..53d81c91fa
--- /dev/null
+++ b/compiler/codeGen/CgHpc.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for coverage
+--
+-- (c) Galois Connections, Inc. 2006
+--
+-----------------------------------------------------------------------------
+
+module CgHpc (cgTickBox, initHpc, hpcTable) where
+
+import Cmm
+import CLabel
+import Module
+import MachOp
+import CmmUtils
+import CgMonad
+import CgForeignCall
+import ForeignCall
+import FastString
+import HscTypes
+import Char
+
+cgTickBox :: Module -> Int -> Code
+cgTickBox mod n = do
+ let tick_box = (cmmIndex I64
+ (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
+ (fromIntegral n)
+ )
+ stmtsC [ CmmStore tick_box
+ (CmmMachOp (MO_Add I64)
+ [ CmmLoad tick_box I64
+ , CmmLit (mkIntCLit 1)
+ ])
+ ]
+
+
+hpcTable :: Module -> HpcInfo -> Code
+hpcTable this_mod hpc_tickCount = do
+ emitData ReadOnlyData
+ [ CmmDataLabel mkHpcModuleNameLabel
+ , CmmString $ map (fromIntegral . ord)
+ (module_name_str)
+ ++ [0]
+ ]
+ emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
+ ] ++
+ [ CmmStaticLit (CmmInt 0 I64)
+ | _ <- take hpc_tickCount [0..]
+ ]
+ where
+ module_name_str = moduleNameString (Module.moduleName this_mod)
+
+
+initHpc :: Module -> HpcInfo -> Code
+initHpc this_mod tickCount
+ = do { emitForeignCall'
+ PlayRisky
+ []
+ (CmmForeignCall
+ (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
+ CCallConv
+ )
+ [ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
+ , (CmmLit $ mkIntCLit tickCount,NoHint)
+ , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
+ ]
+ (Just [])
+ }
+ where
+ mod_alloc = mkFastString "hs_hpc_module"
+
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 2c4ea5cfae..3b7fc0abe2 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -25,6 +25,7 @@ import CgBindery
import CgClosure
import CgCon
import CgUtils
+import CgHpc
import CLabel
import Cmm
@@ -60,10 +61,11 @@ codeGen :: DynFlags
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
+ -> HpcInfo
-> IO [Cmm] -- Output
codeGen dflags this_mod data_tycons foreign_stubs imported_mods
- cost_centre_info stg_binds
+ cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "CodeGen"
; let way = buildTag dflags
@@ -77,7 +79,7 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods
; cmm_tycons <- mapM cgTyCon data_tycons
; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info
this_mod main_mod
- foreign_stubs imported_mods)
+ foreign_stubs imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
}
-- Put datatype_stuff after code_stuff, because the
@@ -142,17 +144,24 @@ mkModuleInit
-> Module -- name of the Main module
-> ForeignStubs
-> [Module]
+ -> HpcInfo
-> Code
-mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods
- = do {
- if opt_SccProfilingOn
- then do { -- Allocate the static boolean that records if this
- -- module has been registered already
- emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
+mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info
+ = do { -- Allocate the static boolean that records if this
+ -- module has been registered already
+ emitData Data [CmmDataLabel moduleRegdLabel,
+ CmmStaticLit zeroCLit]
- ; emitSimpleProc real_init_lbl $ do
- { ret_blk <- forkLabelledCode ret_code
+ ; whenC (dopt Opt_Hpc dflags) $
+ hpcTable this_mod hpc_info
+
+ -- we emit a recursive descent module search for all modules
+ -- and *choose* to chase it in :Main, below.
+ -- In this way, Hpc enabled modules can interact seamlessly with
+ -- not Hpc enabled moduled, provided Main is compiled with Hpc.
+
+ ; emitSimpleProc real_init_lbl $ do
+ { ret_blk <- forkLabelledCode ret_code
; init_blk <- forkLabelledCode $ do
{ mod_init_code; stmtC (CmmBranch ret_blk) }
@@ -161,8 +170,6 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
ret_blk)
; stmtC (CmmBranch init_blk)
}
- }
- else emitSimpleProc real_init_lbl ret_code
-- Make the "plain" procedure jump to the "real" init procedure
; emitSimpleProc plain_init_lbl jump_to_init
@@ -172,8 +179,12 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
+
+ -- Notice that the recursive descent is optional, depending on what options
+ -- are enabled.
+
; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl jump_to_init)
+ (emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
this_pkg = thisPackage dflags
@@ -196,10 +207,15 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
{ -- Set mod_reg to 1 to record that we've been here
stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
- -- Now do local stuff
- ; initCostCentres cost_centre_info
+ ; whenC (opt_SccProfilingOn) $ do
+ initCostCentres cost_centre_info
+
+ ; whenC (dopt Opt_Hpc dflags) $
+ initHpc this_mod hpc_info
+
; mapCs (registerModuleImport this_pkg way)
(imported_mods++extra_imported_mods)
+
}
-- The return-code pops the work stack by
@@ -207,6 +223,11 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
, CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
+
+ rec_descent_init = if opt_SccProfilingOn || dopt Opt_Hpc dflags
+ then jump_to_init
+ else ret_code
+
-----------------------
registerModuleImport :: PackageId -> String -> Module -> Code
registerModuleImport this_pkg way mod
View Lorry Controller Status