Haskell Program Coverage

This large checkin is the new ghc version of Haskell
Program Coverage, an expression-level coverage tool for Haskell.

Parts:

 - Hpc.[ch] - small runtime support for Hpc; reading/writing *.tix files.
 - Coverage.lhs - Annotates the HsSyn with coverage tickboxes.
  - New Note's in Core,
      - TickBox      -- ticked on entry to sub-expression
      - BinaryTickBox  -- ticked on exit to sub-expression, depending
	       	     -- on the boolean result.

  - New Stg level TickBox (no BinaryTickBoxes, though) 

You can run the coverage tool with -fhpc at compile time. 
Main must be compiled with -fhpc. 
				      

40 files changed, 1450 insertions, 50 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index f6c5148e35..54abe2351b 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -93,6 +93,9 @@ module CLabel (
         mkPicBaseLabel,
         mkDeadStripPreventer,
 
+        mkHpcTicksLabel,
+        mkHpcModuleNameLabel,
+
 	infoLblToEntryLbl, entryLblToInfoLbl,
 	needsCDecl, isAsmTemp, externallyVisibleCLabel,
 	CLabelType(..), labelType, labelDynamic,
@@ -205,6 +208,9 @@ data CLabel
   | DeadStripPreventer CLabel
     -- label before an info table to prevent excessive dead-stripping on darwin
 
+  | HpcTicksLabel Module       -- Per-module table of tick locations
+  | HpcModuleNameLabel         -- Per-module name of the module for Hpc
+
   deriving (Eq, Ord)
 
 data IdLabelInfo
@@ -402,6 +408,11 @@ mkRtsApFastLabel str = RtsLabel (RtsApFast str)
 mkRtsSlowTickyCtrLabel :: String -> CLabel
 mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
 
+        -- Coverage
+
+mkHpcTicksLabel                = HpcTicksLabel
+mkHpcModuleNameLabel           = HpcModuleNameLabel
+
         -- Dynamic linking
         
 mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
@@ -473,6 +484,8 @@ needsCDecl (RtsLabel _)			= False
 needsCDecl (ForeignLabel _ _ _)		= False
 needsCDecl (CC_Label _)			= True
 needsCDecl (CCS_Label _)		= True
+needsCDecl (HpcTicksLabel _)            = True
+needsCDecl HpcModuleNameLabel           = False
 
 -- Whether the label is an assembler temporary:
 
@@ -501,6 +514,8 @@ externallyVisibleCLabel (DynIdLabel name _)  = isExternalName name
 externallyVisibleCLabel (CC_Label _)	   = True
 externallyVisibleCLabel (CCS_Label _)	   = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
+externallyVisibleCLabel (HpcTicksLabel _)   = True
+externallyVisibleCLabel HpcModuleNameLabel      = False
 
 -- -----------------------------------------------------------------------------
 -- Finding the "type" of a CLabel 
@@ -761,6 +776,12 @@ pprCLbl (ModuleInitLabel mod way _)
 pprCLbl (PlainModuleInitLabel mod _)	
    = ptext SLIT("__stginit_") <> ppr mod
 
+pprCLbl (HpcTicksLabel mod)
+  = ptext SLIT("_tickboxes_")  <> ppr mod <> ptext SLIT("_hpc")
+
+pprCLbl HpcModuleNameLabel
+  = ptext SLIT("_hpc_module_name_str")
+
 ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <>
 	       (case x of
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 
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 3b8f5778cd..fb31e4536d 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -33,6 +33,7 @@ import ErrUtils
 import DynFlags
 import Util
 import Outputable
+import TysWiredIn
 \end{code}
 
 -- ---------------------------------------------------------------------------
@@ -333,6 +334,8 @@ exprIsTrivial (Type _)	      	       = True
 exprIsTrivial (Lit lit)       	       = True
 exprIsTrivial (App e arg)     	       = isTypeArg arg && exprIsTrivial e
 exprIsTrivial (Note (SCC _) e) 	       = False
+exprIsTrivial (Note (TickBox {}) e)    = False
+exprIsTrivial (Note (BinaryTickBox {}) e) = False
 exprIsTrivial (Note _ e)      	       = exprIsTrivial e
 exprIsTrivial (Cast e co)              = exprIsTrivial e
 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
@@ -380,6 +383,23 @@ corePrepExprFloat env (Note n@(SCC _) expr)
     deLamFloat expr1			`thenUs` \ (floats, expr2) ->
     returnUs (floats, Note n expr2)
 
+corePrepExprFloat env (Note note@(TickBox {}) expr)
+  = corePrepAnExpr env expr            `thenUs` \ expr1 ->
+    deLamFloat expr1                   `thenUs` \ (floats, expr2) ->
+    return (floats, Note note expr2)
+
+corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr)
+  = corePrepAnExpr env expr            `thenUs` \ expr1 ->
+    deLamFloat expr1                   `thenUs` \ (floats, expr2) ->
+    getUniqueUs                        `thenUs` \ u ->
+    let bndr = mkSysLocal FSLIT("t") u boolTy in
+    return (floats, Case expr2
+                       bndr
+                       boolTy
+                       [ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId))
+                       , (DataAlt trueDataCon,  [], Note (TickBox m t) (Var trueDataConId))
+                       ])
+
 corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr		`thenUs` \ (floats, expr') ->
     returnUs (floats, Note other_note expr')
@@ -395,6 +415,21 @@ corePrepExprFloat env expr@(Lam _ _)
   where
     (bndrs,body) = collectBinders expr
 
+corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts)
+  = corePrepExprFloat env (Note note (Case expr bndr ty alts))
+
+corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts)
+  = do { ASSERT(exprType expr `coreEqType` boolTy)
+         corePrepExprFloat env $
+               Case expr bndr ty
+                       [ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch)
+                       , (DataAlt trueDataCon,  [], Note (TickBox m t) trueBranch)
+                       ]
+       }
+   where
+       (_,_,trueBranch)  = findAlt (DataAlt trueDataCon) alts
+       (_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts
+
 corePrepExprFloat env (Case scrut bndr ty alts)
   = corePrepExprFloat env scrut		`thenUs` \ (floats1, scrut1) ->
     deLamFloat scrut1			`thenUs` \ (floats2, scrut2) ->
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 3c98f288fd..3f74dc5be5 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -60,6 +60,7 @@ import DataCon
 import BasicTypes
 import FastString
 import Outputable
+import Module
 
 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
@@ -132,6 +133,11 @@ data Note
 
   | CoreNote String     -- A generic core annotation, propagated but not used by GHC
 
+  | TickBox Module !Int -- ^Tick box for Hpc-style coverage
+  | BinaryTickBox Module !Int !Int
+    			-- ^Binary tick box, with a tick for result = True, result = False
+
+
 -- NOTE: we also treat expressions wrapped in InlineMe as
 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
 -- What this means is that we obediently inline even things that don't
@@ -615,6 +621,9 @@ seqExprs [] = ()
 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 
 seqNote (CoreNote s)   = s `seq` ()
+seqNote (TickBox m n)  = m `seq` ()  -- no need for seq on n, because n is strict
+seqNote (BinaryTickBox m t f)   
+	               = m `seq` ()  -- likewise on t and f.
 seqNote other	       = ()
 
 seqBndr b = b `seq` ()
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index ffbdb50422..d82acb967c 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -800,6 +800,14 @@ exprIsConApp_maybe (Cast expr co)
     Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
     }}
 
+-- We do not want to tell the world that we have a
+-- Cons, to *stop* Case of Known Cons, which removes
+-- the TickBox.
+exprIsConApp_maybe (Note (TickBox {}) expr)
+  = Nothing
+exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
+  = Nothing
+
 exprIsConApp_maybe (Note _ expr)
   = exprIsConApp_maybe expr
     -- We ignore InlineMe notes in case we have
@@ -1184,6 +1192,9 @@ exprArity e = go e
 	      go (Var v) 	       	   = idArity v
 	      go (Lam x e) | isId x    	   = go e + 1
 			   | otherwise 	   = go e
+              go (Note (TickBox {}) _)     = 0
+              go (Note (BinaryTickBox {}) _) 
+		                           = 0
 	      go (Note n e) 		   = go e
               go (Cast e _)                = go e
 	      go (App e (Type t))      	   = go e
@@ -1301,6 +1312,8 @@ exprSize (Type t)        = seqType t `seq` 1
 noteSize (SCC cc)       = cc `seq` 1
 noteSize InlineMe       = 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
+noteSize (TickBox m n)    = m `seq` n `seq` 1 
+noteSize (BinaryTickBox m t e)  = m `seq` t `seq` e `seq` 1 
 
 varSize :: Var -> Int
 varSize b  | isTyVar b = 1
@@ -1446,6 +1459,8 @@ rhsIsStatic this_pkg rhs = is_static False rhs
   is_static False (Lam b e) = isRuntimeVar b || is_static False e
   
   is_static in_arg (Note (SCC _) e) = False
+  is_static in_arg (Note (TickBox {}) e) = False
+  is_static in_arg (Note (BinaryTickBox {}) e) = False
   is_static in_arg (Note _ e)       = is_static in_arg e
   is_static in_arg (Cast e co)      = is_static in_arg e
   
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 08fbdc417e..cb79cb449d 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -33,6 +33,7 @@ import BasicTypes
 import Util
 import Outputable
 import FastString
+import Module
 \end{code}
 
 %************************************************************************
@@ -212,6 +213,21 @@ ppr_expr add_par (Note (SCC cc) expr)
 ppr_expr add_par (Note InlineMe expr)
   = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
 
+ppr_expr add_par (Note (TickBox mod n) expr)
+  = add_par $
+    sep [sep [ptext SLIT("__tick_box"),
+               pprModule mod,
+              text (show n)],
+         pprParendExpr expr]
+
+ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
+  = add_par $
+    sep [sep [ptext SLIT("__binary_tick_box"),
+               pprModule mod,
+              text (show t),
+              text (show e)],
+         pprParendExpr expr]
+
 ppr_expr add_par (Note (CoreNote s) expr)
   = add_par $ 
     sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
new file mode 100644
index 0000000000..9a53b2bdfc
--- /dev/null
+++ b/compiler/deSugar/Coverage.lhs
@@ -0,0 +1,647 @@
+%
+% (c) Galois, 2006
+%
+\section[Coverage]{@coverage@: the main function}
+
+\begin{code}
+module Coverage (addCoverageTicksToBinds) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import Id		( Id )
+import DynFlags		( DynFlags, mainModIs, mainFunIs )
+import Module
+import HscTypes		( HpcInfo, noHpcInfo )
+
+import IdInfo
+import Outputable
+import DynFlags		( DynFlag(Opt_D_dump_hpc), hpcDir )
+import Monad		
+
+import SrcLoc
+import ErrUtils 	(doIfSet_dyn)
+import HsUtils		( mkHsApp )
+import Unique
+import UniqSupply
+import Id
+import Name
+import TcType		
+import TysPrim		
+import CoreUtils
+import TyCon
+import Type
+import TysWiredIn	( intTy , stringTy, unitTy, intDataCon, falseDataConId, mkListTy, pairTyCon, tupleCon, mkTupleTy, unboxedSingletonDataCon )
+import Bag
+import Var		( TyVar, mkTyVar )
+import DataCon		( dataConWrapId )
+import MkId
+import PrimOp
+import BasicTypes	( RecFlag(..), Activation(NeverActive), Boxity(..) )
+import Data.List        ( isSuffixOf )
+
+import System.Time (ClockTime(..))
+import System.Directory (getModificationTime)
+import System.IO   (FilePath)
+#if __GLASGOW_HASKELL__ < 603
+import Compat.Directory ( createDirectoryIfMissing )
+#else
+import System.Directory ( createDirectoryIfMissing )
+#endif
+\end{code}
+
+%************************************************************************
+%*									*
+%* 		The main function: addCoverageTicksToBinds
+%*									*
+%************************************************************************
+
+\begin{code}
+addCoverageTicksToBinds dflags mod mod_loc binds = do 
+  let main_mod = mainModIs dflags
+      main_is  = case mainFunIs dflags of
+		  Nothing -> "main"
+		  Just main -> main 
+
+  let mod_name = moduleNameString (moduleName mod)
+
+  let (binds1,st)
+		 = unTM (addTickLHsBinds binds) 
+		 $ TT { modName      = mod_name
+		      , declPath     = []
+		      , tickBoxCount = 0
+		      , mixEntries   = []
+		      }
+
+  let hpc_dir = hpcDir dflags
+
+  -- write the mix entries for this module
+  let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
+
+  let orig_file = case ml_hs_file mod_loc of
+		    Just file -> file
+		    Nothing -> error "can not find the original file during hpc trans"
+
+  modTime <- getModificationTime' orig_file
+
+  createDirectoryIfMissing True hpc_dir
+
+  mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
+
+  doIfSet_dyn dflags  Opt_D_dump_hpc $ do
+	  printDump (pprLHsBinds binds1)
+--	  putStrLn (showSDocDebug (pprLHsBinds binds3))
+  return (binds1, tickBoxCount st)
+\end{code}
+
+
+\begin{code}
+liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
+liftL f (L loc a) = do
+  a' <- f a
+  return $ L loc a'
+
+addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
+addTickLHsBinds binds = mapBagM addTickLHsBind binds
+
+addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
+addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
+  abs_binds' <- addTickLHsBinds abs_binds
+  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  })))  = do
+  let name = getOccString id
+  decl_path <- getPathEntry
+
+  tick_no <- allocATickBox (if null decl_path
+			    then TopLevelBox [name]
+			    else LocalBox (name : decl_path))
+			  pos
+
+  mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)  
+				 $ addTickMatchGroup (fun_matches funBind)
+  let arg_count = matchGroupArity mg
+  let (tys,res_ty) = splitFunTysN arg_count ty
+
+  return $ L pos $ funBind { fun_matches = MatchGroup ({-L pos fn_entry:-}matches') ty 
+			   , fun_tick = tick_no
+			   }
+
+-- TODO: Revisit this
+addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
+  let name = "(...)"
+  rhs' <- addPathEntry name $ addTickGRHSs False rhs
+{-
+  decl_path <- getPathEntry
+  tick_me <- allocTickBox (if null decl_path
+			   then TopLevelBox [name]
+			   else LocalBox (name : decl_path))
+-}			   
+  return $ L pos $ pat { pat_rhs = rhs' }
+
+{- only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind (VarBind var_id var_rhs) = do
+  var_rhs' <- addTickLHsExpr var_rhs  
+  return $ VarBind var_id var_rhs'
+-}
+addTickLHsBind other = return other
+
+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    fn <- allocTickBox ExpBox pos 
+    return $ fn $ L pos e1
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprOptAlt oneOfMany (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos 
+    return $ fn $ L pos e1
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by 
+-- another.
+addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExpr' (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    return $ L pos e1
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+addBinTickLHsExpr boxLabel (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    allocBinTickBox boxLabel $ L pos e1
+    
+
+addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
+addTickHsExpr e@(HsVar _) = return e
+addTickHsExpr e@(HsIPVar _) = return e
+addTickHsExpr e@(HsOverLit _) = return e
+addTickHsExpr e@(HsLit _) = return e
+addTickHsExpr e@(HsLam matchgroup) =
+        liftM HsLam (addTickMatchGroup matchgroup)
+addTickHsExpr (HsApp e1 e2) = 
+	liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
+addTickHsExpr (OpApp e1 e2 fix e3) = 
+	liftM4 OpApp 
+		(addTickLHsExpr e1) 
+		(addTickLHsExpr' e2)
+		(return fix)
+		(addTickLHsExpr e3)
+addTickHsExpr ( NegApp e neg) =
+	liftM2 NegApp
+		(addTickLHsExpr e) 
+		(addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
+addTickHsExpr (SectionL e1 e2) = 
+	liftM2 SectionL
+		(addTickLHsExpr e1)
+		(addTickLHsExpr e2)
+addTickHsExpr (SectionR e1 e2) = 
+	liftM2 SectionR
+		(addTickLHsExpr e1)
+		(addTickLHsExpr e2)
+addTickHsExpr (HsCase e mgs) = 
+	liftM2 HsCase
+		(addTickLHsExpr e) 
+		(addTickMatchGroup mgs)
+addTickHsExpr (HsIf	 e1 e2 e3) = 
+	liftM3 HsIf
+		(addBinTickLHsExpr CondBinBox e1)
+		(addTickLHsExprOptAlt True e2)
+		(addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsLet binds e) =
+	liftM2 HsLet
+		(addTickHsLocalBinds binds)		-- to think about: !patterns.
+		(addTickLHsExpr' e)
+addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
+	liftM4 HsDo
+		(return cxt)
+		(mapM (liftL (addTickStmt forQual)) stmts)
+		(addTickLHsExpr last_exp)
+		(return srcloc)
+  where
+	forQual = case cxt of
+		    ListComp -> Just QualBinBox
+		    _        -> Nothing
+addTickHsExpr (ExplicitList ty es) = 
+	liftM2 ExplicitList 
+		(return ty)
+		(mapM addTickLHsExpr es)
+addTickHsExpr (ExplicitPArr	 {}) = error "addTickHsExpr: ExplicitPArr	"
+addTickHsExpr (ExplicitTuple es box) =
+	liftM2 ExplicitTuple
+		(mapM addTickLHsExpr es)
+		(return box)
+addTickHsExpr (RecordCon	 id ty rec_binds) = 
+	liftM3 RecordCon
+		(return id)
+		(return ty)
+		(addTickHsRecordBinds rec_binds)
+addTickHsExpr (RecordUpd	e rec_binds ty1 ty2) =
+	liftM4 RecordUpd
+		(addTickLHsExpr e)
+		(addTickHsRecordBinds rec_binds)
+		(return ty1)
+		(return ty2)
+addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
+addTickHsExpr (ExprWithTySigOut e ty) =
+	liftM2 ExprWithTySigOut
+		(addTickLHsExpr' e) -- No need to tick the inner expression
+				    -- for expressions with signatures
+		(return ty)
+addTickHsExpr (ArithSeq	 ty arith_seq) =
+	liftM2 ArithSeq	
+		(return ty)
+		(addTickArithSeqInfo arith_seq)
+addTickHsExpr (PArrSeq	 {}) = error "addTickHsExpr: PArrSeq	"
+addTickHsExpr (HsSCC	 {}) = error "addTickHsExpr: HsSCC	"
+addTickHsExpr (HsCoreAnn   {}) = error "addTickHsExpr: HsCoreAnn  "
+addTickHsExpr e@(HsBracket     {}) = return e
+addTickHsExpr e@(HsBracketOut  {}) = return e
+addTickHsExpr e@(HsSpliceE  {}) = return e
+addTickHsExpr (HsProc pat cmdtop) =
+	liftM2 HsProc
+		(addTickLPat pat)
+		(liftL addTickHsCmdTop cmdtop)
+addTickHsExpr (HsWrap w e) = 
+	liftM2 HsWrap
+		(return w)
+		(addTickHsExpr e)	-- explicitly no tick on inside
+addTickHsExpr (HsArrApp	 {}) = error "addTickHsExpr:  HsArrApp	"
+addTickHsExpr (HsArrForm {}) = error "addTickHsExpr:  HsArrForm"
+addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
+addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
+addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
+addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
+addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
+
+addTickHsExpr e@(HsType ty) = return e
+
+-- catch all, and give an error message.
+--addTickHsExpr e = error ("addTickLhsExpr: " ++ showSDoc (ppr e))
+
+
+addTickMatchGroup (MatchGroup matches ty) = do
+  let isOneOfMany = True -- AJG: for now
+  matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
+  return $ MatchGroup matches' ty
+
+addTickMatch :: Bool -> Match Id -> TM (Match Id)
+addTickMatch isOneOfMany (Match pats opSig gRHSs) = do
+  gRHSs' <- addTickGRHSs isOneOfMany gRHSs
+  return $ Match pats opSig gRHSs'
+
+addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
+addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
+  guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
+  local_binds' <- addTickHsLocalBinds local_binds
+  return $ GRHSs guarded' local_binds'
+
+addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
+addTickGRHS isOneOfMany (GRHS stmts expr) = do
+  stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
+  expr' <- addTickLHsExprOptAlt isOneOfMany expr
+  return $ GRHS stmts' expr'
+
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt isGuard (BindStmt pat e bind fail) =
+	liftM4 BindStmt
+		(addTickLPat pat)
+		(addTickLHsExpr e)
+		(addTickSyntaxExpr hpcSrcSpan bind)
+		(addTickSyntaxExpr hpcSrcSpan fail)
+addTickStmt isGuard (ExprStmt e bind' ty) =
+	liftM3 ExprStmt
+		(addTick e)
+		(addTickSyntaxExpr hpcSrcSpan bind')
+		(return ty)
+  where
+	addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
+		  | otherwise          = addTickLHsExpr e
+
+addTickStmt isGuard (LetStmt binds) =
+	liftM LetStmt
+		(addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt pairs) =
+  	liftM ParStmt (mapM process pairs)
+  where
+	process (stmts,ids) = 
+		liftM2 (,) 
+			(mapM (liftL (addTickStmt isGuard)) stmts)
+			(return ids)
+addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) =
+  	liftM5 RecStmt 
+		(mapM (liftL (addTickStmt isGuard)) stmts)
+		(return ids1)
+		(return ids2)
+		(return tys)
+		(addTickDictBinds dictbinds)
+
+addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
+addTickHsLocalBinds (HsValBinds binds) = 
+	liftM HsValBinds 
+		(addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds binds)  = 
+	liftM HsIPBinds 
+		(addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
+
+addTickHsValBinds (ValBindsOut binds sigs) =
+	liftM2 ValBindsOut
+		(mapM (\ (rec,binds') -> 
+				liftM2 (,)
+					(return rec)
+					(addTickLHsBinds binds'))
+			binds)
+		(return sigs)
+
+addTickHsIPBinds (IPBinds ipbinds dictbinds) =
+	liftM2 IPBinds
+		(mapM (liftL addTickIPBind) ipbinds)
+		(addTickDictBinds dictbinds)
+
+addTickIPBind :: IPBind Id -> TM (IPBind Id)
+addTickIPBind (IPBind nm e) =
+	liftM2 IPBind
+		(return nm)
+		(addTickLHsExpr e)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
+addTickSyntaxExpr pos x = do
+	L _ x' <- addTickLHsExpr (L pos x)
+	return $ x'
+-- we do not walk into patterns.
+addTickLPat :: LPat Id -> TM (LPat Id)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
+	liftM4 HsCmdTop
+		(addTickLHsCmd cmd)
+		(return tys)
+		(return ty)
+		(return syntaxtable)
+
+addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
+addTickLHsCmd x = addTickLHsExpr x
+
+addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
+addTickDictBinds x = addTickLHsBinds x
+
+addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
+addTickHsRecordBinds pairs = mapM process pairs
+    where
+	process (ids,expr) = 
+		liftM2 (,) 
+			(return ids)
+			(addTickLHsExpr expr)			
+
+addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
+addTickArithSeqInfo (From e1) =
+	liftM From
+		(addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+	liftM2 FromThen
+		(addTickLHsExpr e1)
+		(addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+	liftM2 FromTo
+		(addTickLHsExpr e1)
+		(addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+	liftM3 FromThenTo
+		(addTickLHsExpr e1)
+		(addTickLHsExpr e2)
+		(addTickLHsExpr e3)
+\end{code}
+
+\begin{code}
+data TixFlags = TixFlags
+
+data TickTransState = TT { modName     :: String
+                         , declPath    :: [String]
+                         , tickBoxCount:: Int
+                         , mixEntries  :: [MixEntry]
+                         }                        
+	deriving Show
+
+data TM a = TM { unTM :: TickTransState -> (a,TickTransState) }
+
+instance Monad TM where
+  return a = TM $ \ st -> (a,st)
+  (TM m) >>= k = TM $ \ st -> case m st of
+				(r1,st1) -> unTM (k r1) st1 
+
+--addTick :: LHsExpr Id -> TM (LHsExpr Id)
+--addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm (TM m) = TM $ \ st -> case m (st { declPath = declPath st ++ [nm] }) of
+					(r,st') -> (r,st' { declPath = declPath st })
+
+getPathEntry :: TM [String]
+getPathEntry = TM $ \ st -> (declPath st,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations 
+allocTickBox :: BoxLabel -> SrcSpan -> TM (LHsExpr Id -> LHsExpr Id)
+allocTickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+  let me = (hpcPos,boxLabel)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in ( \ (L pos e) -> L pos $ HsTick c (L pos e)
+     , st {tickBoxCount=c+1,mixEntries=me:mes}
+     )
+allocTickBox boxLabel e = return id
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations 
+allocATickBox :: BoxLabel -> SrcSpan -> TM (Maybe Int)
+allocATickBox boxLabel pos | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+  let me = (hpcPos,boxLabel)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in ( Just c
+     , st {tickBoxCount=c+1,mixEntries=me:mes}
+     )
+allocATickBox boxLabel e = return Nothing
+
+allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
+  let meT = (hpcPos,boxLabel True)
+      meF = (hpcPos,boxLabel False)
+      meE = (hpcPos,ExpBox)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
+	-- notice that F and T are reversed,
+	-- because we are building the list in
+	-- reverse...
+     , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
+     )
+
+allocBinTickBox boxLabel e = return e
+
+mkHpcPos :: SrcSpan -> Maybe HpcPos
+mkHpcPos pos 
+   | not (isGoodSrcSpan pos) = Nothing
+   | start == end            = Nothing	-- no actual location
+   | otherwise		     = Just hpcPos
+  where
+   start = srcSpanStart pos
+   end   = srcSpanEnd pos
+   hpcPos = toHpcPos ( srcLocLine start
+		     , srcLocCol start + 1
+		     , srcLocLine end
+		     , srcLocCol end
+		     )
+
+hpcSrcSpan = mkGeneralSrcSpan (FSLIT("Haskell Program Coverage internals"))
+
+-- all newly allocated locations have an HPC tag on them, to help debuging
+hpcLoc :: e -> Located e
+hpcLoc = L hpcSrcSpan
+\end{code}
+
+
+\begin{code}
+---------------------------------------------------------------
+-- Datatypes and file-access routines for the per-module (.mix)
+-- indexes used by Hpc.
+-- Colin Runciman and Andy Gill, June 2006
+---------------------------------------------------------------
+
+-- a module index records the attributes of each tick-box that has
+-- been introduced in that module, accessed by tick-number position
+-- in the list
+
+data Mix = Mix 
+	     FilePath		-- location of original file
+	     Integer		-- time (in seconds) of original file's last update, since 1970.
+	     Int 		-- tab stop value 
+	     [MixEntry] 	-- entries
+	deriving (Show,Read)
+
+-- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
+-- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
+-- because if some other program also defined that instance, we will not be able to compile.
+
+type MixEntry = (HpcPos, BoxLabel)
+
+data BoxLabel = ExpBox
+              | AltBox
+              | TopLevelBox [String]
+              | LocalBox [String]
+           -- | UserBox (Maybe String)
+              | GuardBinBox Bool
+              | CondBinBox Bool
+              | QualBinBox Bool
+           -- | PreludeBinBox String Bool
+           -- | UserBinBox (Maybe String) Bool
+              deriving (Read, Show)
+                         
+mixCreate :: String -> String -> Mix -> IO ()
+mixCreate dirName modName mix =
+   writeFile (mixName dirName modName) (show mix)
+
+readMix :: FilePath -> String -> IO Mix
+readMix dirName modName = do
+   contents <- readFile (mixName dirName modName)
+   return (read contents)
+
+mixName :: FilePath -> String -> String
+mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
+
+getModificationTime' :: FilePath -> IO Integer
+getModificationTime' file = do
+  (TOD sec _) <- System.Directory.getModificationTime file
+  return $ sec
+
+data Tix = Tix [PixEntry]	-- The number of tickboxes in each module
+	       [TixEntry] 	-- The tick boxes
+	deriving (Read, Show,Eq)
+
+type TixEntry = Integer
+
+-- always read and write Tix from the current working directory.
+
+readTix :: String -> IO (Maybe Tix)
+readTix pname = 
+  catch (do contents <- readFile $ tixName pname 
+	    return $ Just $ read contents)
+	(\ _ -> return $ Nothing)
+
+writeTix :: String -> Tix -> IO ()
+writeTix pname tix = 
+  writeFile (tixName pname) (show tix)
+
+tixName :: String -> String
+tixName name = name ++ ".tix"
+
+-- a program index records module names and numbers of tick-boxes
+-- introduced in each module that has been transformed for coverage 
+
+data Pix = Pix [PixEntry] deriving (Read, Show)
+
+type PixEntry = ( String	-- module name
+		, Int		-- number of boxes
+		)
+
+pixUpdate :: FilePath -> String -> String -> Int -> IO ()
+pixUpdate dirName progName modName boxCount = do
+   fileUpdate (pixName dirName progName) pixAssign (Pix [])
+   where
+   pixAssign :: Pix -> Pix
+   pixAssign (Pix pes) =
+     Pix ((modName,boxCount) : filter ((/=) modName . fst) pes)
+
+readPix :: FilePath -> String -> IO Pix
+readPix dirName pname = do
+  contents <- readFile (pixName dirName pname)
+  return (read contents)
+
+tickCount :: Pix -> Int
+tickCount (Pix mp) = sum $ map snd mp
+
+pixName :: FilePath -> String -> String
+pixName dirName name = dirName ++ "/" ++ name ++ ".pix"
+
+-- updating a value stored in a file via read and show
+fileUpdate :: (Read a, Show a) => String -> (a->a) -> a -> IO()
+fileUpdate fname update init =
+   catch
+     (do
+        valueText <- readFile fname
+        ( case finite valueText of
+          True ->
+            writeFile fname (show (update (read valueText))) ))
+     (const (writeFile fname (show (update init))))
+
+finite :: [a] -> Bool
+finite []     = True
+finite (x:xs) = finite xs
+
+data HpcPos = P !Int !Int !Int !Int deriving (Eq)
+
+fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
+fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
+
+toHpcPos :: (Int,Int,Int,Int) -> HpcPos
+toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
+
+instance Show HpcPos where
+   show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
+
+instance Read HpcPos where
+  readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
+      where
+         (before,after)   = span (/= ',') pos
+         (lhs,rhs)    = case span (/= '-') before of
+	 		       (lhs,'-':rhs) -> (lhs,rhs)
+			       (lhs,"")      -> (lhs,lhs)
+         (l1,':':c1)	  = span (/= ':') lhs
+         (l2,':':c2)	  = span (/= ':') rhs
+
+\end{code}
+
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index ab4ee74b41..2e5b1e1c9d 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -42,6 +42,7 @@ import SrcLoc
 import Maybes
 import FastString
 import Util
+import Coverage
 
 import Data.IORef
 \end{code}
@@ -53,10 +54,11 @@ import Data.IORef
 %************************************************************************
 
 \begin{code}
-deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts)
 -- Can modify PCS by faulting in more declarations
 
 deSugar hsc_env 
+        mod_loc
         tcg_env@(TcGblEnv { tcg_mod       = mod,
 			    tcg_src	  = hsc_src,
 		    	    tcg_type_env  = type_env,
@@ -81,18 +83,22 @@ deSugar hsc_env
 	; let auto_scc = mkAutoScc mod export_set
 
 	; mb_res <- case ghcMode dflags of
-	             JustTypecheck -> return (Just ([], [], NoStubs))
-	             _             -> initDs hsc_env mod rdr_env type_env $ do
-		                        { core_prs <- dsTopLHsBinds auto_scc binds
+	             JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo))
+                     _        -> do (binds_cvr,ds_hpc_info) 
+					      <- if dopt Opt_Hpc dflags
+                                                 then addCoverageTicksToBinds dflags mod mod_loc binds
+                                                 else return (binds, noHpcInfo)
+                                    initDs hsc_env mod rdr_env type_env $ do
+		                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
 		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
 		                        ; let all_prs = foreign_prs ++ core_prs
 		                              local_bndrs = mkVarSet (map fst all_prs)
 		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
-		                        ; return (all_prs, catMaybes ds_rules, ds_fords)
+		                        ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
 		                        }
 	; case mb_res of {
 	   Nothing -> return Nothing ;
-	   Just (all_prs, ds_rules, ds_fords) -> do
+	   Just (all_prs, ds_rules, ds_fords,ds_hpc_info) -> do
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
@@ -160,8 +166,8 @@ deSugar hsc_env
 		mg_fam_insts = fam_insts,
 	        mg_rules     = ds_rules,
 		mg_binds     = ds_binds,
-		mg_foreign   = ds_fords }
-	
+		mg_foreign   = ds_fords,
+		mg_hpc_info  = ds_hpc_info }
         ; return (Just mod_guts)
 	}}}
 
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 8ed971909f..27d41476e1 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -89,9 +89,10 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr	`thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
   = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
-    dsCoercion co_fn (return (mkLams args body))	`thenDs` \ rhs ->
+    mkOptTickBox tick body 				`thenDs` \ body' ->
+    dsCoercion co_fn (return (mkLams args body'))	`thenDs` \ rhs ->
     returnDs ((fun,rhs) : rest)
 
 dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4a5521c888..2bb2cc43db 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -111,11 +111,12 @@ ds_val_bind (NonRecursive, hsbinds) body
 	--	 below.  Then pattern-match would fail.  Urk.)
     putSrcSpanDs loc	$
     case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
 	-> matchWrapper (FunRhs (idName fun)) matches 	 	`thenDs` \ (args, rhs) ->
 	   ASSERT( null args )	-- Functions aren't lifted
 	   ASSERT( isIdHsWrapper co_fn )
-	   returnDs (bindNonRec fun rhs body_w_exports)
+           mkOptTickBox tick rhs 				`thenDs` \ rhs' ->
+	   returnDs (bindNonRec fun rhs' body_w_exports)
 
       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
 	-> 	-- let C x# y# = rhs in body
@@ -570,6 +571,26 @@ dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 \end{code}
 
+Hpc Support 
+
+\begin{code}
+dsExpr (HsTick ix e) = do
+  e' <- dsLExpr e
+  mkTickBox ix e'
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+dsExpr (HsBinTick ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `coreEqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+\end{code}
 
 \begin{code}
 
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 0552c2bd08..868a89402c 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -33,7 +33,8 @@ module DsUtils (
 	
 	dsSyntaxTable, lookupEvidence,
 
-	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+	mkTickBox, mkOptTickBox, mkBinaryTickBox
     ) where
 
 #include "HsVersions.h"
@@ -880,4 +881,18 @@ mkFailurePair expr
     ty = exprType expr
 \end{code}
 
-
+\begin{code}
+mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
+mkOptTickBox Nothing e   = return e
+mkOptTickBox (Just ix) e = mkTickBox ix e
+
+mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
+mkTickBox ix e = do
+       mod <- getModuleDs
+       return $ Note (TickBox mod ix) e
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+       mod <- getModuleDs
+       return $ Note (BinaryTickBox mod ixT ixF) e
+\end{code}
\ No newline at end of file
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index ebac06fa05..41097d888e 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -87,11 +87,13 @@ data HsBind id
 				-- type 	Int -> forall a'. a' -> a'
 				-- Notice that the coercion captures the free a'.
 
-	bind_fvs :: NameSet	-- After the renamer, this contains a superset of the 
+	bind_fvs :: NameSet,	-- After the renamer, this contains a superset of the 
 				-- Names of the other binders in this binding group that 
 				-- are free in the RHS of the defn
 				-- Before renaming, and after typechecking, 
 				-- the field is unused; it's just an error thunk
+
+        fun_tick :: Maybe Int   -- This is the (optional) module-local tick number. 
     }
 
   | PatBind {	-- The pattern is never a simple variable;
@@ -238,7 +240,13 @@ ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 
 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
+ppr_monobind (FunBind { fun_id = fun, 
+			fun_matches = matches,
+		        fun_tick = tick }) = 
+		           (case tick of 
+			      Nothing -> empty
+			      Just t  -> text "-- tick id = " <> ppr t
+			   ) $$ pprFunBind (unLoc fun) matches
       -- ToDo: print infix if appropriate
 
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 2360337759..9bcd06e47f 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -202,6 +202,18 @@ data HsExpr id
 					-- always has an empty stack
 
   ---------------------------------------
+  -- Hpc Support
+
+  | HsTick 
+     Int				-- module-local tick number
+     (LHsExpr id)			-- sub-expression
+
+  | HsBinTick
+     Int				-- module-local tick number for True
+     Int				-- module-local tick number for False
+     (LHsExpr id)			-- sub-expression
+
+  ---------------------------------------
   -- The following are commands, not expressions proper
 
   | HsArrApp	-- Arrow tail, or arrow application (f -< arg)
@@ -391,6 +403,16 @@ ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
 ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
 
+ppr_expr (HsTick tickId exp)
+  = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+  = hcat [ptext SLIT("bintick<"), 
+	  ppr tickIdTrue,
+	  ptext SLIT(","),
+	  ppr tickIdFalse,
+	  ptext SLIT(">("), 
+	  ppr exp,ptext SLIT(")")]
+
 ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
 ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index be4431d234..51c6a198a8 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -225,7 +225,8 @@ nlHsFunTy a b		= noLoc (HsFunTy a b)
 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 -- Not infix, with place holders for coercion and free vars
 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
-			    fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+			    fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
+			    fun_tick = Nothing }
 
 
 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index ebb26c784c..72ea80deb7 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1002,6 +1002,15 @@ instance Binary IfaceNote where
     put_ bh (IfaceCoreNote s) = do
             putByte bh 4
             put_ bh s
+    put_ bh (IfaceTickBox m n) = do
+            putByte bh 5
+            put_ bh m
+            put_ bh n
+    put_ bh (IfaceBinaryTickBox m t e) = do
+            putByte bh 6
+            put_ bh m
+            put_ bh t
+            put_ bh e
     get bh = do
 	    h <- getByte bh
 	    case h of
@@ -1010,7 +1019,13 @@ instance Binary IfaceNote where
 	      3 -> do return IfaceInlineMe
               4 -> do ac <- get bh
                       return (IfaceCoreNote ac)
-
+              5 -> do m <- get bh
+                      n <- get bh
+                      return (IfaceTickBox m n)
+              6 -> do m <- get bh
+                      t <- get bh
+                      e <- get bh
+                      return (IfaceBinaryTickBox m t e)
 
 -------------------------------------------------------------------------
 --		IfaceDecl and friends
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 7efa0299bf..55cd6d1963 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -41,6 +41,7 @@ import SrcLoc
 import BasicTypes
 import Outputable
 import FastString
+import Module
 
 import Data.List
 import Data.Maybe
@@ -209,6 +210,8 @@ data IfaceExpr
 data IfaceNote = IfaceSCC CostCentre
 	       | IfaceInlineMe
                | IfaceCoreNote String
+               | IfaceTickBox Module Int
+               | IfaceBinaryTickBox Module Int Int
 
 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
 	-- Note: FastString, not IfaceBndr (and same with the case binder)
@@ -482,6 +485,13 @@ instance Outputable IfaceNote where
     ppr (IfaceSCC cc)     = pprCostCentreCore cc
     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+    ppr (IfaceTickBox m n)  = ptext SLIT("__tick_box") <+> pprModule m <+>  text (show n)
+    ppr (IfaceBinaryTickBox m t e)
+                         = ptext SLIT("__binary_tick_box")
+                               <+> pprModule m
+                               <+> text (show t)
+                               <+> text (show e)
+
 
 instance Outputable IfaceConAlt where
     ppr IfaceDefault	  = text "DEFAULT"
@@ -749,6 +759,8 @@ eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
+eq_ifaceNote env (IfaceTickBox m1 n1) (IfaceTickBox m2 n2)   = bool (m1==m2 && n1==n2)
+eq_ifaceNote env (IfaceBinaryTickBox m1 t1 e1) (IfaceBinaryTickBox m2 t2 e2) = bool (m1==m2 && t1==t2 && e1 == e2)
 eq_ifaceNote env _ _ = NotEqual
 \end{code}
 
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 751811125e..f7cb28a735 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1240,6 +1240,9 @@ toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
 toIfaceNote (SCC cc)      = IfaceSCC cc
 toIfaceNote InlineMe      = IfaceInlineMe
 toIfaceNote (CoreNote s)  = IfaceCoreNote s
+toIfaceNote (TickBox m n) = IfaceTickBox m n
+toIfaceNote (BinaryTickBox m t e)
+                          = IfaceBinaryTickBox m t e
 
 ---------------------
 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 42321955e6..6c60af873e 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -686,6 +686,8 @@ tcIfaceExpr (IfaceNote note expr)
 	IfaceInlineMe     -> returnM (Note InlineMe   expr')
 	IfaceSCC cc       -> returnM (Note (SCC cc)   expr')
 	IfaceCoreNote n   -> returnM (Note (CoreNote n) expr')
+        IfaceTickBox m n  -> returnM (Note (TickBox m n) expr')
+        IfaceBinaryTickBox m t e -> returnM (Note (BinaryTickBox m t e) expr')
 
 -------------------------
 tcIfaceAlt _ (IfaceDefault, names, rhs)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 20376f05dc..53fa11aa28 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -121,6 +121,7 @@ data DynFlag
    | Opt_D_dump_splices
    | Opt_D_dump_BCOs
    | Opt_D_dump_vect
+   | Opt_D_dump_hpc
    | Opt_D_source_stats
    | Opt_D_verbose_core2core
    | Opt_D_verbose_stg2stg
@@ -198,6 +199,8 @@ data DynFlag
    | Opt_HideAllPackages
    | Opt_PrintBindResult
    | Opt_Haddock
+   | Opt_Hpc
+   | Opt_Hpc_Trace
 
    -- keeping stuff
    | Opt_KeepHiDiffs
@@ -255,6 +258,8 @@ data DynFlags = DynFlags {
   ghcUsagePath          :: FilePath,    -- Filled in by SysTools
   ghciUsagePath         :: FilePath,    -- ditto
 
+  hpcDir		:: String,	-- ^ path to store the .mix files
+
   -- options for particular phases
   opt_L			:: [String],
   opt_P			:: [String],
@@ -392,6 +397,8 @@ defaultDynFlags =
 	cmdlineFrameworks	= [],
 	tmpDir			= cDEFAULT_TMPDIR,
 	
+        hpcDir		        = ".hpc",
+
 	opt_L			= [],
 	opt_P			= [],
 	opt_F			= [],
@@ -875,6 +882,7 @@ dynamic_flags = [
   ,  ( "no-hs-main"     , NoArg (setDynFlag Opt_NoHsMain))
   ,  ( "main-is"   	, SepArg setMainIs )
   ,  ( "haddock"	, NoArg (setDynFlag Opt_Haddock) )
+  ,  ( "hpcdir"		, SepArg setOptHpcDir )
 
 	------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
   ,  ( "recomp"		, NoArg (unSetDynFlag Opt_ForceRecomp) )
@@ -938,6 +946,8 @@ dynamic_flags = [
   ,  ( "ddump-hi",               setDumpFlag Opt_D_dump_hi)
   ,  ( "ddump-minimal-imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports))
   ,  ( "ddump-vect",         	 setDumpFlag Opt_D_dump_vect)
+  ,  ( "ddump-hpc",         	 setDumpFlag Opt_D_dump_hpc)
+  
   ,  ( "dcore-lint",       	 NoArg (setDynFlag Opt_DoCoreLinting))
   ,  ( "dstg-lint",        	 NoArg (setDynFlag Opt_DoStgLinting))
   ,  ( "dcmm-lint",		 NoArg (setDynFlag Opt_DoCmmLinting))
@@ -1041,7 +1051,9 @@ fFlags = [
   ( "excess-precision",			Opt_ExcessPrecision ),
   ( "asm-mangling",			Opt_DoAsmMangling ),
   ( "print-bind-result",		Opt_PrintBindResult ),
-  ( "force-recomp",			Opt_ForceRecomp )
+  ( "force-recomp",			Opt_ForceRecomp ),
+  ( "hpc",				Opt_Hpc ),
+  ( "hpc-tracer",			Opt_Hpc )
   ]
 
 
@@ -1244,6 +1256,12 @@ setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir }
 #endif
 
 -----------------------------------------------------------------------------
+-- Hpc stuff
+
+setOptHpcDir :: String -> DynP ()
+setOptHpcDir arg  = upd $ \ d -> d{hpcDir = arg}
+
+-----------------------------------------------------------------------------
 -- Via-C compilation stuff
 
 machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 31995f0962..6c09b97c93 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -466,7 +466,7 @@ hscFileFrontEnd =
                          -------------------
                          -- DESUGAR
                          -------------------
-                         -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result
+                         -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result
 
 --------------------------------------------------------------
 -- Simplifiers
@@ -583,7 +583,8 @@ hscCompile cgguts
                      cg_tycons   = tycons,
                      cg_dir_imps = dir_imps,
                      cg_foreign  = foreign_stubs,
-                     cg_dep_pkgs = dependencies } = cgguts
+                     cg_dep_pkgs = dependencies,
+		     cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env
              location = ms_location mod_summary
              data_tycons = filter isDataTyCon tycons
@@ -603,7 +604,7 @@ hscCompile cgguts
          abstractC <- {-# SCC "CodeGen" #-}
                       codeGen dflags this_mod data_tycons
                               foreign_stubs dir_imps cost_centre_info
-                              stg_binds
+                              stg_binds hpc_info
          ------------------  Code output -----------------------
          (stub_h_exists,stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index c5483b90e1..4dc7894133 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -58,7 +58,8 @@ module HscTypes (
 	-- Linker stuff
 	Linkable(..), isObjectLinkable,
 	Unlinked(..), CompiledByteCode,
-	isObject, nameOfObject, isInterpretable, byteCodeOfObject
+	isObject, nameOfObject, isInterpretable, byteCodeOfObject,
+        HpcInfo, noHpcInfo
     ) where
 
 #include "HsVersions.h"
@@ -480,7 +481,8 @@ data ModGuts
 	mg_fam_insts :: ![FamInst],	 -- Instances 
         mg_rules     :: ![CoreRule],	 -- Rules from this module
 	mg_binds     :: ![CoreBind],	 -- Bindings for this module
-	mg_foreign   :: !ForeignStubs
+	mg_foreign   :: !ForeignStubs,
+	mg_hpc_info  :: !HpcInfo         -- info about coverage tick boxes
     }
 
 -- The ModGuts takes on several slightly different forms:
@@ -517,7 +519,8 @@ data CgGuts
 		-- initialisation code
 
 	cg_foreign  :: !ForeignStubs,	
-	cg_dep_pkgs :: ![PackageId]	-- Used to generate #includes for C code gen
+	cg_dep_pkgs :: ![PackageId],	-- Used to generate #includes for C code gen
+        cg_hpc_info :: !HpcInfo         -- info about coverage tick boxes
     }
 
 -----------------------------------
@@ -1139,6 +1142,19 @@ showModMsg target recomp mod_summary
 
 %************************************************************************
 %*									*
+\subsection{Hpc Support}
+%*									*
+%************************************************************************
+
+\begin{code}
+type HpcInfo = Int             -- just the number of ticks in a module
+
+noHpcInfo :: HpcInfo
+noHpcInfo = 0                  -- default = 0
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection{Linkable stuff}
 %*									*
 %************************************************************************
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b95d4d31ab..331d921489 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -239,7 +239,8 @@ tidyProgram hsc_env
 				mg_binds = binds, 
 				mg_rules = imp_rules,
 				mg_dir_imps = dir_imps, mg_deps = deps, 
-				mg_foreign = foreign_stubs })
+				mg_foreign = foreign_stubs,
+			        mg_hpc_info = hpc_info })
 
   = do	{ let dflags = hsc_dflags hsc_env
 	; showPass dflags "Tidy Core"
@@ -290,7 +291,8 @@ tidyProgram hsc_env
 			   cg_binds    = all_tidy_binds,
 			   cg_dir_imps = dir_imps,
 			   cg_foreign  = foreign_stubs,
-			   cg_dep_pkgs = dep_pkgs deps }, 
+			   cg_dep_pkgs = dep_pkgs deps,
+			   cg_hpc_info = hpc_info }, 
 
 		   ModDetails { md_types     = tidy_type_env,
 				md_rules     = tidy_rules,
@@ -789,11 +791,17 @@ CAF list to keep track of non-collectable CAFs.
 \begin{code}
 hasCafRefs  :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
 hasCafRefs this_pkg p arity expr 
-  | is_caf || mentions_cafs = MayHaveCafRefs
+  | is_caf || mentions_cafs || is_tick
+                            = MayHaveCafRefs
   | otherwise 		    = NoCafRefs
  where
   mentions_cafs = isFastTrue (cafRefs p expr)
   is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+  is_tick = case expr of
+	      Note (TickBox {}) _       -> True
+	      Note (BinaryTickBox {}) _ -> True
+	      _                         -> False
+        
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
   -- knows how much eta expansion is going to be done by 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 28f8fcbaf9..da31d06a3f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -757,7 +757,7 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn is_infix ms 
   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
-	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+	      fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 
 checkPatBind lhs (L _ grhss)
   = do	{ lhs <- checkPattern lhs
diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs
index 8e02892254..d27a3a0c4a 100644
--- a/compiler/profiling/SCCfinal.lhs
+++ b/compiler/profiling/SCCfinal.lhs
@@ -195,6 +195,10 @@ stgMassageForProfiling this_pkg mod_name us stg_binds
 	= do_let b e `thenMM` \ (b,e) ->
 	  returnMM (StgLetNoEscape lvs1 lvs2 b e)
 
+    do_expr (StgTick m n expr) 
+        = do_expr expr `thenMM` \ expr' ->
+          returnMM (StgTick m n expr')
+
 #ifdef DEBUG
     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
 #endif
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index ecd3b3d04a..ad2a6b370e 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -398,7 +398,7 @@ rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches
 	; checkPrecMatch inf plain_name matches'
 
 	; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches',
-				   bind_fvs = trim fvs, fun_co_fn = idHsWrapper }), 
+				   bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }), 
 		  [plain_name], fvs)
       }
 \end{code}
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index e32a8ea160..b80a8e0b2a 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -214,6 +214,13 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
   = 	-- Ditto... don't float anything into an INLINE expression
     mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
 
+fiExpr to_drop (_, AnnNote note@(TickBox {}) expr)
+  =    -- Wimp out for now
+    mkCoLets' to_drop (Note note (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote note@(BinaryTickBox {}) expr)
+  =    -- Wimp out for now
+    mkCoLets' to_drop (Note note (fiExpr [] expr))
+
 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
   = Note note (fiExpr to_drop expr)
 \end{code}
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2f881d5a4a..b3e6bf7cf4 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -911,6 +911,14 @@ simplNote env InlineMe e cont
 simplNote env (CoreNote s) e cont
   = simplExpr env e    `thenSmpl` \ e' ->
     rebuild env (Note (CoreNote s) e') cont
+
+simplNote env note@(TickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
+
+simplNote env note@(BinaryTickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
 \end{code}
 
 
diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
index cd118d7092..eb3229f196 100644
--- a/compiler/simplStg/SRT.lhs
+++ b/compiler/simplStg/SRT.lhs
@@ -116,6 +116,8 @@ srtExpr table e@(StgOpApp op args ty)   = e
 
 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
 
+srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
+
 srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
  = StgCase expr' live1 live2 uniq srt' alt_type alts'
  where
diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs
index a91873971c..7b341fa345 100644
--- a/compiler/simplStg/StgStats.lhs
+++ b/compiler/simplStg/StgStats.lhs
@@ -151,6 +151,7 @@ statExpr (StgLit _)	  = countOne Literals
 statExpr (StgConApp _ _)  = countOne ConstructorApps
 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
 statExpr (StgSCC l e) 	  = statExpr e
+statExpr (StgTick m n e)  = statExpr e
 
 statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
   = statBinding False{-not top-level-} binds	`combineSE`
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 31837b9043..bdb3a6622d 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -318,6 +318,15 @@ coreToStgExpr (Note (SCC cc) expr)
   = coreToStgExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
     returnLne (StgSCC cc expr2, fvs, escs) )
 
+coreToStgExpr (Note (TickBox m n) expr)
+  = coreToStgExpr expr         `thenLne` ( \ (expr2, fvs, escs) ->
+    returnLne (StgTick m n expr2, fvs, escs) )
+
+-- BinaryTickBox'es are are removed by the CorePrep pass.
+
+coreToStgExpr expr@(Note (BinaryTickBox m t e) _)	
+  = pprPanic "coreToStgExpr: " (ppr expr)
+
 coreToStgExpr (Note other_note expr)
   = coreToStgExpr expr
 
@@ -1075,6 +1084,8 @@ myCollectBinders expr
   where
     go bs (Lam b e)          = go (b:bs) e
     go bs e@(Note (SCC _) _) = (reverse bs, e) 
+    go bs e@(Note (TickBox {}) _) = (reverse bs, e)
+    go bs e@(Note (BinaryTickBox {}) _)  = (reverse bs, e)
     go bs (Cast e co)        = go bs e
     go bs (Note _ e)         = go bs e
     go bs e	             = (reverse bs, e)
@@ -1088,6 +1099,8 @@ myCollectArgs expr
     go (Var v)          as = (v, as)
     go (App f a) as        = go f (a:as)
     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go (Note (BinaryTickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
     go (Cast e co)      as = go e as
     go (Note n e)       as = go e as
     go _		as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index 74832a24aa..a184d5e6c0 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -67,6 +67,7 @@ import UniqSet		( isEmptyUniqSet, uniqSetToList, UniqSet )
 import Unique		( Unique )
 import Bitmap
 import StaticFlags	( opt_SccProfilingOn )
+import Module		( Module, pprModule )
 \end{code}
 
 %************************************************************************
@@ -349,6 +350,21 @@ Finally for @scc@ expressions we introduce a new STG construct.
   | StgSCC
 	CostCentre		-- label of SCC expression
 	(GenStgExpr bndr occ)	-- scc expression
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{@GenStgExpr@: @hpc@ expressions}
+%*									*
+%************************************************************************
+
+Finally for @scc@ expressions we introduce a new STG construct.
+
+\begin{code}
+  | StgTick
+    Module			-- the module of the source of this tick
+    Int				-- tick number
+    (GenStgExpr bndr occ)	-- sub expression
   -- end of GenStgExpr
 \end{code}
 
@@ -719,6 +735,10 @@ pprStgExpr (StgSCC cc expr)
   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 	  pprStgExpr expr ]
 
+pprStgExpr (StgTick m n expr)
+  = sep [ hsep [ptext SLIT("_tick_"),  pprModule m,text (show n)],
+	  pprStgExpr expr ]
+
 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
   = sep [sep [ptext SLIT("case"),
 	   nest 4 (hsep [pprStgExpr expr,
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 0ec1c66657..5d804334fd 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -526,7 +526,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 	; let mono_id = mkLocalId mono_name zonked_rhs_ty
 	; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
 					      fun_matches = matches', bind_fvs = fvs,
-					      fun_co_fn = co_fn })),
+					      fun_co_fn = co_fn, fun_tick = Nothing })),
 		  [(name, Nothing, mono_id)]) }
 
 tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
@@ -550,7 +550,8 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 
 	; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
 				    fun_infix = inf, fun_matches = matches',
-			            bind_fvs = placeHolderNames, fun_co_fn = co_fn }
+			            bind_fvs = placeHolderNames, fun_co_fn = co_fn, 
+				    fun_tick = Nothing }
 	; return (unitBag (L b_loc fun_bind'),
 		  [(name, Just tc_sig, mono_id)]) }
 
@@ -655,7 +656,8 @@ tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
   = do	{ (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
 				    	    (idType mono_id)
 	; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
-			    bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
+			    bind_fvs = placeHolderNames, fun_co_fn = co_fn,
+			    fun_tick = Nothing }) }
 
 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
   = do	{ grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 139f134f2e..bd4eb9b54c 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -303,7 +303,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 				mg_rdr_env   = emptyGlobalRdrEnv,
 				mg_fix_env   = emptyFixityEnv,
 				mg_deprecs   = NoDeprecs,
-				mg_foreign   = NoStubs
+				mg_foreign   = NoStubs,
+				mg_hpc_info = noHpcInfo
 		    } } ;
 
    tcCoreDump mod_guts ;
diff --git a/driver/mangler/ghc-asm.lprl b/driver/mangler/ghc-asm.lprl
index 902593ea7f..21b56f8039 100644
--- a/driver/mangler/ghc-asm.lprl
+++ b/driver/mangler/ghc-asm.lprl
@@ -699,6 +699,12 @@ sub mangle_asm {
 	    $chkcat[$i]  = 'data';
 	    $chksymb[$i] = '';
 
+        } elsif ( /^${T_US}([A-Za-z0-9_]+)_hpc?${T_POST_LBL}$/o ) {
+           # hpc shares tick boxes across modules
+           $chk[++$i]   = $_;
+           $chkcat[$i]  = 'data';
+           $chksymb[$i] = '';
+
 	} elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/o ) {
 	    $chk[++$i]   = $_;
 	    $chkcat[$i]  = 'misc';
diff --git a/includes/HsFFI.h b/includes/HsFFI.h
index cd9f7ede80..0d343f8d98 100644
--- a/includes/HsFFI.h
+++ b/includes/HsFFI.h
@@ -158,6 +158,8 @@ extern void hs_perform_gc (void);
 extern void hs_free_stable_ptr (HsStablePtr sp);
 extern void hs_free_fun_ptr    (HsFunPtr fp);
 
+extern void hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr);
+
 /* -------------------------------------------------------------------------- */
 
 #ifdef __cplusplus
diff --git a/rts/Hpc.c b/rts/Hpc.c
new file mode 100644
index 0000000000..8e67ffcc88
--- /dev/null
+++ b/rts/Hpc.c
@@ -0,0 +1,324 @@
+/*
+ * (c)2006 Galois Connections, Inc.
+ */ 
+
+// #include "HsFFI.h"
+
+#include <stdio.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include "HsFFI.h"
+#include "Hpc.h"
+
+/* This is the runtime support for the Haskell Program Coverage (hpc) toolkit,
+ * inside GHC.
+ *
+ */
+
+#define DEBUG_HPC 0
+
+static int hpc_inited = 0;	// Have you started this component?
+static FILE *tixFile;		// file being read/written
+static int tix_ch;		// current char
+
+typedef struct _Info {
+  char *modName;		// name of module
+  int tickCount;		// number of ticks
+  int tickOffset;		// offset into a single large .tix Array
+  StgWord64 *tixArr;		// tix Array from the program execution (local for this module)
+  struct _Info *next;
+} Info;
+
+Info *modules = 0;
+Info *nextModule = 0;
+StgWord64 *tixBoxes = 0;	// local copy of tixBoxes array, from file.
+int totalTixes = 0;		// total number of tix boxes.
+
+
+
+static char *tixFilename = "Main.tix";
+
+static void failure(char *msg) {
+  printf("Hpc failure: %s\n",msg);
+  printf("(perhaps remove .tix file?)\n");
+  exit(-1);
+}
+
+
+static int init_open(char *filename) 
+{
+  tixFile = fopen(filename,"r");
+ if (tixFile == 0) {
+    return 0;
+  }
+  tix_ch = getc(tixFile);
+  return 1;
+}
+
+static void expect(char c) {
+  if (tix_ch != c) {
+    printf("Hpc: parse failed (%c,%c)\n",tix_ch,c);
+    exit(-1);
+  }
+  tix_ch = getc(tixFile);
+}
+
+static void ws(void) {
+  while (tix_ch == ' ') {
+    tix_ch = getc(tixFile);
+  }
+}
+
+static char *expectString(void) {
+  char tmp[256], *res;
+  int tmp_ix = 0;
+  expect('"');
+  while (tix_ch != '"') {
+    tmp[tmp_ix++] = tix_ch;
+    tix_ch = getc(tixFile);
+  }
+  tmp[tmp_ix++] = 0;
+  expect('"');
+  res = malloc(tmp_ix);
+  strcpy(res,tmp);
+  return res;
+}
+
+static StgWord64 expectWord64(void) {
+  StgWord64 tmp = 0;
+  while (isdigit(tix_ch)) {
+    tmp = tmp * 10 + (tix_ch -'0');
+    tix_ch = getc(tixFile);
+  }
+  return tmp;
+}
+
+static void hpc_init(void) {
+  int i;
+  Info *tmpModule;  
+
+  if (hpc_inited != 0) {
+    return;
+  }
+  hpc_inited = 1;
+  
+  if (init_open(tixFilename)) { 
+    totalTixes = 0;
+
+    ws();
+    expect('T');
+    expect('i');
+    expect('x');
+    ws();
+    expectWord64();
+    ws();
+    expect('[');
+    ws();
+    while(tix_ch != ']') {
+      tmpModule = (Info *)calloc(1,sizeof(Info));
+      expect('(');
+      ws();
+      tmpModule -> modName = expectString();
+      ws();
+      expect(',');
+      ws();
+      tmpModule -> tickCount = (int)expectWord64();
+      ws();
+      expect(')');
+      ws();
+      
+      tmpModule -> tickOffset = totalTixes;
+      totalTixes += tmpModule -> tickCount;
+      
+      tmpModule -> tixArr = 0;
+      
+      if (!modules) {
+	modules = tmpModule;
+      } else {
+	nextModule->next=tmpModule;
+      }
+      nextModule=tmpModule;
+      
+      if (tix_ch == ',') {
+	expect(',');
+	ws();
+      }}
+    expect(']');
+    ws();
+    tixBoxes = (StgWord64 *)calloc(totalTixes,sizeof(StgWord64));
+
+    expect('[');
+    for(i = 0;i < totalTixes;i++) {
+      if (i != 0) {
+	expect(',');
+	ws();
+      }
+    tixBoxes[i] = expectWord64();
+    ws();
+    }
+    expect(']');
+
+    fclose(tixFile);
+  }
+}
+
+/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory.
+ * This memory can be uninitized, because we will initialize it with either the contents
+ * of the tix file, or all zeros.
+ */
+
+void
+hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr) {
+  Info *tmpModule, *lastModule;
+  int i;
+  
+#if DEBUG_HPC
+  printf("hs_hpc_module(%s,%d)\n",modName,modCount);
+#endif
+
+  hpc_init();
+
+  tmpModule = modules;
+  lastModule = 0;
+  
+  for(;tmpModule != 0;tmpModule = tmpModule->next) {
+    if (!strcmp(tmpModule->modName,modName)) {
+      if (tmpModule->tickCount != modCount) {
+	failure("inconsistent number of tick boxes");
+      }
+      assert(tmpModule->tixArr == 0);	
+      assert(tixBoxes != 0);
+      tmpModule->tixArr = tixArr;
+      for(i=0;i < modCount;i++) {
+	tixArr[i] = tixBoxes[i + tmpModule->tickOffset];
+      }
+      return;
+    }
+    lastModule = tmpModule;
+  }
+  // Did not find entry so add one on.
+  tmpModule = (Info *)calloc(1,sizeof(Info));
+  tmpModule->modName = modName;
+  tmpModule->tickCount = modCount;
+  if (lastModule) {
+    tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
+  } else {
+    tmpModule->tickOffset = 0;
+  }
+  tmpModule->tixArr = tixArr;
+  for(i=0;i < modCount;i++) {
+    tixArr[i] = 0;
+  }
+  tmpModule->next = 0;
+
+  if (!modules) {
+    modules = tmpModule;
+  } else {
+    lastModule->next=tmpModule;
+  }
+
+#if DEBUG_HPC
+  printf("end: hs_hpc_module\n");
+#endif
+}
+
+/* This is called after all the modules have registered their local tixboxes,
+ * and does a sanity check: are we good to go?
+ */
+
+void
+startupHpc(void) {
+  Info *tmpModule;
+#if DEBUG_HPC
+  printf("startupHpc\n");
+#endif
+ 
+ if (hpc_inited == 0) {
+    return;
+  }
+
+  tmpModule = modules;
+
+  if (tixBoxes) {
+    for(;tmpModule != 0;tmpModule = tmpModule->next) {
+      if (!tmpModule->tixArr) {
+	fprintf(stderr,"error: module %s did not register any hpc tick data\n",
+		tmpModule->modName);
+	fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
+	exit(-1);
+      }
+    }
+  }
+}
+
+/* Called at the end of execution, to write out the Hpc *.tix file  
+ * for this exection. Safe to call, even if coverage is not used.
+ */
+void
+exitHpc(void) {
+  Info *tmpModule;  
+  int i, comma;
+
+#if DEBUG_HPC
+  printf("exitHpc\n");
+#endif
+
+  if (hpc_inited == 0) {
+    return;
+  }
+
+  FILE *f = fopen(tixFilename,"w");
+  
+  comma = 0;
+
+  fprintf(f,"Tix 0 [");
+  tmpModule = modules;
+  for(;tmpModule != 0;tmpModule = tmpModule->next) {
+    if (comma) {
+      fprintf(f,",");
+    } else {
+      comma = 1;
+    }
+    fprintf(f,"(\"%s\",%d)",
+	   tmpModule->modName,
+	    tmpModule->tickCount);
+#if DEBUG_HPC
+    fprintf(stderr,"%s: %d (offset=%d)\n",
+	   tmpModule->modName,
+	   tmpModule->tickCount,
+	   tmpModule->tickOffset);
+#endif
+  }
+  fprintf(f,"] [");
+  
+  comma = 0;
+  tmpModule = modules;
+  for(;tmpModule != 0;tmpModule = tmpModule->next) {
+      if (!tmpModule->tixArr) {
+	fprintf(stderr,"warning: module %s did not register any hpc tick data\n",
+		tmpModule->modName);
+      }
+
+    for(i = 0;i < tmpModule->tickCount;i++) {
+      if (comma) {
+	fprintf(f,",");
+      } else {
+	comma = 1;
+      }
+
+      if (tmpModule->tixArr) {
+	fprintf(f,"%lld",tmpModule->tixArr[i]);
+      } else {
+	fprintf(f,"0");
+      }
+
+    }
+  }
+      
+  fprintf(f,"]\n");
+  fclose(f);
+  
+}
+
diff --git a/rts/Hpc.h b/rts/Hpc.h
new file mode 100644
index 0000000000..a0ff40b06c
--- /dev/null
+++ b/rts/Hpc.h
@@ -0,0 +1,10 @@
+#ifndef HPC_H
+#define HPC_H
+
+extern void startupHpc(void);
+extern void exitHpc(void);
+
+#endif /* HPC_H */
+
+
+
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index f023a96092..67430dc685 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -311,6 +311,8 @@ hs_add_root(void (*init_root)(void))
 
     freeGroup_lock(bd);
 
+    startupHpc();
+
 #if defined(PROFILING) || defined(DEBUG)
     // This must be done after module initialisation.
     // ToDo: make this work in the presence of multiple hs_add_root()s.
@@ -391,6 +393,9 @@ hs_exit(void)
     /* stop timing the shutdown, we're about to print stats */
     stat_endExit();
     
+    /* shutdown the hpc support (if needed) */
+    exitHpc();
+
     // clean up things from the storage manager's point of view.
     // also outputs the stats (+RTS -s) info.
     exitStorage();