X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=b28f3eba3f2e6a42ffe85ab9081cd770161f3e12;hp=95b70f091a5ab33bf7939e8abc5e58a0ac8000ed;hb=a52ff7619e8b7d74a9d933d922eeea49f580bca8;hpb=5463b55b7dadc1e9918edb2d8666bf3ed195bc61

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 95b70f0..b28f3eb 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -5,7 +5,7 @@
 \section[Coverage]{@coverage@: the main function}
 
 \begin{code}
-module Coverage (addCoverageTicksToBinds) where
+module Coverage (addCoverageTicksToBinds, hpcInitCode) where
 
 import HsSyn
 import Module
@@ -25,6 +25,8 @@ import StaticFlags
 import TyCon
 import MonadUtils
 import Maybes
+import CLabel
+import Util
 
 import Data.Array
 import System.Directory ( createDirectoryIfMissing )
@@ -871,3 +873,56 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 mixHash file tm tabstop entries = fromIntegral $ hashString
 	(show $ Mix file tm 0 tabstop entries)
 \end{code}
+
+%************************************************************************
+%*									*
+%*              initialisation
+%*									*
+%************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+
+\begin{code}
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+    [ text "static void hpc_init_" <> ppr this_mod
+         <> text "(void) __attribute__((constructor));"
+    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+    , braces (vcat [
+        ptext (sLit "extern StgWord64 ") <> tickboxes <>
+               ptext (sLit "[]") <> semi,
+        ptext (sLit "hs_hpc_module") <>
+          parens (hcat (punctuate comma [
+              doubleQuotes full_name_str,
+              int tickCount, -- really StgWord32
+              int hashNo,    -- really StgWord32
+              tickboxes
+            ])) <> semi
+       ])
+    ]
+  where
+    tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)
+
+    module_name  = hcat (map (text.charToC) $
+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
+    package_name = hcat (map (text.charToC) $
+                         bytesFS (packageIdFS  (modulePackageId this_mod)))
+    full_name_str
+       | modulePackageId this_mod == mainPackageId
+       = module_name
+       | otherwise
+       = package_name <> char '/' <> module_name
+\end{code}