Adding tracing support

10 files changed, 151 insertions, 72 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 67f7a2ed96..d96d416dec 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -95,6 +95,7 @@ module CLabel (
 
         mkHpcTicksLabel,
         mkHpcModuleNameLabel,
+        mkHpcModuleOffsetLabel,
 
 	infoLblToEntryLbl, entryLblToInfoLbl,
 	needsCDecl, isAsmTemp, externallyVisibleCLabel,
@@ -210,6 +211,7 @@ data CLabel
 
   | HpcTicksLabel Module       -- Per-module table of tick locations
   | HpcModuleNameLabel         -- Per-module name of the module for Hpc
+  | HpcModuleOffsetLabel Module-- Per-module offset of the module for Hpc (dynamically generated)
 
   deriving (Eq, Ord)
 
@@ -412,6 +414,7 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
 
 mkHpcTicksLabel                = HpcTicksLabel
 mkHpcModuleNameLabel           = HpcModuleNameLabel
+mkHpcModuleOffsetLabel         = HpcModuleOffsetLabel
 
         -- Dynamic linking
         
@@ -485,6 +488,7 @@ needsCDecl (ForeignLabel _ _ _)		= False
 needsCDecl (CC_Label _)			= True
 needsCDecl (CCS_Label _)		= True
 needsCDecl (HpcTicksLabel _)            = True
+needsCDecl (HpcModuleOffsetLabel _)     = True
 needsCDecl HpcModuleNameLabel           = False
 
 -- Whether the label is an assembler temporary:
@@ -515,6 +519,7 @@ externallyVisibleCLabel (CC_Label _)	   = True
 externallyVisibleCLabel (CCS_Label _)	   = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)   = True
+externallyVisibleCLabel (HpcModuleOffsetLabel _)  = True
 externallyVisibleCLabel HpcModuleNameLabel      = False
 
 -- -----------------------------------------------------------------------------
@@ -777,7 +782,10 @@ pprCLbl (PlainModuleInitLabel mod _)
    = ptext SLIT("__stginit_") <> ppr mod
 
 pprCLbl (HpcTicksLabel mod)
-  = ptext SLIT("_tickboxes_")  <> ppr mod <> ptext SLIT("_hpc")
+  = ptext SLIT("_hpc_tickboxes_")  <> ppr mod <> ptext SLIT("_hpc")
+
+pprCLbl (HpcModuleOffsetLabel mod)
+  = ptext SLIT("_hpc_module_offset_")  <> ppr mod <> ptext SLIT("_hpc")
 
 pprCLbl HpcModuleNameLabel
   = ptext SLIT("_hpc_module_name_str")
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index 9620973d10..82ea54a844 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -13,12 +13,14 @@ import CLabel
 import Module
 import MachOp
 import CmmUtils
+import CgUtils
 import CgMonad
 import CgForeignCall
 import ForeignCall
 import FastString
 import HscTypes
 import Char
+import StaticFlags
 
 cgTickBox :: Module -> Int -> Code
 cgTickBox mod n = do
@@ -31,8 +33,25 @@ cgTickBox mod n = do
                                                [ CmmLoad tick_box I64
                                                , CmmLit (CmmInt 1 I64)
                                                ])
-              ]
+              ] 
+       let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ mod
 
+       whenC (opt_Hpc_Tracer) $ do
+           emitForeignCall'
+               PlayRisky	-- ??
+	       []
+               (CmmForeignCall
+                 (CmmLit $ CmmLabel $ mkForeignLabel visible_tick Nothing False)
+                  CCallConv
+               )
+               [ (CmmMachOp (MO_Add I32)
+                     [ CmmLoad ext_tick_box I32
+                     , CmmLit (CmmInt (fromIntegral n) I32)
+		     ]
+		  ,  NoHint) ]
+               (Just [])
+   where
+      visible_tick = mkFastString "hs_hpc_tick"
 
 hpcTable :: Module -> HpcInfo -> Code
 hpcTable this_mod hpc_tickCount = do
@@ -42,6 +61,10 @@ hpcTable this_mod hpc_tickCount = do
                                                          (module_name_str)
                                                       ++ [0]
                                         ]
+                        emitData Data
+                                        [ CmmDataLabel (mkHpcModuleOffsetLabel this_mod)
+					, CmmStaticLit (CmmInt 0 I32)
+                                        ]
                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
                                         ] ++
                                         [ CmmStaticLit (CmmInt 0 I64)
@@ -53,9 +76,10 @@ hpcTable this_mod hpc_tickCount = do
 
 initHpc :: Module -> HpcInfo -> Code
 initHpc this_mod tickCount
-  = do { emitForeignCall'
+  = do { id <- newTemp wordRep
+       ; emitForeignCall'
                PlayRisky
-               []
+               [(id,NoHint)]
                (CmmForeignCall
                  (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
                   CCallConv
@@ -65,6 +89,8 @@ initHpc this_mod tickCount
                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
                ]
                (Just [])
+       ; let ext_tick_box = CmmLit $ CmmLabel $ mkHpcModuleOffsetLabel $ this_mod
+       ; stmtsC [ CmmStore ext_tick_box (CmmReg id) ]
        }
   where
        mod_alloc = mkFastString "hs_hpc_module"
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 3b7fc0abe2..4302e84f56 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -152,7 +152,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
 	  emitData Data [CmmDataLabel moduleRegdLabel, 
 		         CmmStaticLit zeroCLit]
 
-        ; whenC (dopt Opt_Hpc dflags) $
+        ; whenC (opt_Hpc) $
               hpcTable this_mod hpc_info
 
           -- we emit a recursive descent module search for all modules
@@ -210,7 +210,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
         ; whenC (opt_SccProfilingOn) $ do 
 	    initCostCentres cost_centre_info
 
-        ; whenC (dopt Opt_Hpc dflags) $
+        ; whenC (opt_Hpc) $
             initHpc this_mod hpc_info
          
 	; mapCs (registerModuleImport this_pkg way) 
@@ -224,7 +224,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
                       , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
 
 
-    rec_descent_init = if opt_SccProfilingOn || dopt Opt_Hpc dflags
+    rec_descent_init = if opt_SccProfilingOn || opt_Hpc
 		       then jump_to_init
 		       else ret_code
 
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index af9f002723..f888d05894 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -567,11 +567,6 @@ 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"
 
@@ -586,21 +581,6 @@ data Tix = Tix [PixEntry]	-- The number of tickboxes in each module
 
 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 
 
@@ -610,40 +590,6 @@ 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)
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 2e5b1e1c9d..dd2ed6d07b 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -85,7 +85,7 @@ deSugar hsc_env
 	; mb_res <- case ghcMode dflags of
 	             JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo))
                      _        -> do (binds_cvr,ds_hpc_info) 
-					      <- if dopt Opt_Hpc dflags
+					      <- if opt_Hpc
                                                  then addCoverageTicksToBinds dflags mod mod_loc binds
                                                  else return (binds, noHpcInfo)
                                     initDs hsc_env mod rdr_env type_env $ do
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 8de1eec79e..736aff3c31 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -199,8 +199,6 @@ data DynFlag
    | Opt_HideAllPackages
    | Opt_PrintBindResult
    | Opt_Haddock
-   | Opt_Hpc
-   | Opt_Hpc_Tracer
 
    -- keeping stuff
    | Opt_KeepHiDiffs
@@ -1049,9 +1047,7 @@ fFlags = [
   ( "excess-precision",			Opt_ExcessPrecision ),
   ( "asm-mangling",			Opt_DoAsmMangling ),
   ( "print-bind-result",		Opt_PrintBindResult ),
-  ( "force-recomp",			Opt_ForceRecomp ),
-  ( "hpc",				Opt_Hpc ),
-  ( "hpc-tracer",			Opt_Hpc_Tracer )
+  ( "force-recomp",			Opt_ForceRecomp )
   ]
 
 
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 1a026bd726..54c46b3860 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,6 +27,10 @@ module StaticFlags (
 	opt_SccProfilingOn,
 	opt_DoTickyProfiling,
 
+        -- Hpc opts
+	opt_Hpc,
+        opt_Hpc_Tracer,
+
 	-- language opts
 	opt_DictsStrict,
 	opt_IrrefutableTuples,
@@ -150,6 +154,11 @@ static_flags = [
   ,  ( "dppr-user-length", AnySuffix addOpt )
       -- rest of the debugging flags are dynamic
 
+	--------- Haskell Program Coverage -----------------------------------
+
+  ,  ( "fhpc"           , PassFlag addOpt )
+  ,  ( "fhpc-tracer"    , PassFlag addOpt )
+
 	--------- Profiling --------------------------------------------------
   ,  ( "auto-all"	, NoArg (addOpt "-fauto-sccs-on-all-toplevs") )
   ,  ( "auto"		, NoArg (addOpt "-fauto-sccs-on-exported-toplevs") )
@@ -264,6 +273,13 @@ opt_AutoSccsOnIndividualCafs	= lookUp  FSLIT("-fauto-sccs-on-individual-cafs")
 opt_SccProfilingOn		= lookUp  FSLIT("-fscc-profiling")
 opt_DoTickyProfiling		= lookUp  FSLIT("-fticky-ticky")
 
+
+-- Hpc opts
+
+opt_Hpc				= lookUp FSLIT("-fhpc")  
+				  || opt_Hpc_Tracer 
+opt_Hpc_Tracer			= lookUp FSLIT("-fhpc-tracer")
+
 -- language opts
 opt_DictsStrict			= lookUp  FSLIT("-fdicts-strict")
 opt_IrrefutableTuples		= lookUp  FSLIT("-firrefutable-tuples")
diff --git a/includes/HsFFI.h b/includes/HsFFI.h
index 0d343f8d98..9fce2a484d 100644
--- a/includes/HsFFI.h
+++ b/includes/HsFFI.h
@@ -158,7 +158,9 @@ 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);
+extern int hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr);
+extern void hs_hpc_tick(int globIx);
+extern void hs_hpc_throw(void);
 
 /* -------------------------------------------------------------------------- */
 
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 1104706c9c..103e0c4a5d 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -336,6 +336,9 @@ raisezh_fast
       foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
     }
 #endif
+    
+    /* Inform the Hpc that an exception has been thrown */
+    foreign "C" hs_hpc_throw();
 
 retry_pop_stack:
     StgTSO_sp(CurrentTSO) = Sp;
diff --git a/rts/Hpc.c b/rts/Hpc.c
index bfbbf67c8f..6d79f260d9 100644
--- a/rts/Hpc.c
+++ b/rts/Hpc.c
@@ -2,14 +2,13 @@
  * (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 "Rts.h"
 #include "Hpc.h"
 
@@ -25,6 +24,9 @@ static FILE *tixFile;			// file being read/written
 static int tix_ch;			// current char
 static StgWord64 magicTixNumber;	// Magic/Hash number to mark .tix files
 
+static int hpc_ticks_inited = 0;	// Have you started the dynamic external ticking?
+static FILE *rixFile;			// The tracer file/pipe
+
 typedef struct _Info {
   char *modName;		// name of module
   int tickCount;		// number of ticks
@@ -186,10 +188,11 @@ static void hpc_init(void) {
  * of the tix file, or all zeros.
  */
 
-void
+int
 hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr) {
   Info *tmpModule, *lastModule;
   int i;
+  int offset = 0;
   
 #if DEBUG_HPC
   printf("hs_hpc_module(%s,%d)\n",modName,modCount);
@@ -211,7 +214,7 @@ hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr) {
       for(i=0;i < modCount;i++) {
 	tixArr[i] = tixBoxes[i + tmpModule->tickOffset];
       }
-      return;
+      return tmpModule->tickOffset;
     }
     lastModule = tmpModule;
   }
@@ -239,6 +242,80 @@ hs_hpc_module(char *modName,int modCount,StgWord64 *tixArr) {
 #if DEBUG_HPC
   printf("end: hs_hpc_module\n");
 #endif
+  return offset;
+}
+
+
+/*
+ * Called on *every* exception thrown
+ */
+void
+hs_hpc_throw() {
+  // Assumes that we have had at least *one* tick first.
+  // All exceptions before the first tick are not reported.
+  // The only time this might be an issue is in bootstrapping code,
+  // so this is a feature.
+  if (hpc_inited != 0 && hpc_ticks_inited != 0) {
+    fprintf(rixFile,"Throw\n");
+  }
+}
+
+/* Called on every tick
+ */
+
+void
+hs_hpc_tick(int globIx) {
+  int threadId = 0;	 // for now, assume single thread
+			 // TODO: work out how to get the thread Id to here.
+
+  
+#if DEBUG_HPC && DEBUG
+  printf("hs_hpc_tick(%d)\n",globIx);
+#endif
+  if (!hpc_ticks_inited) {
+    char* trace_filename;
+    int comma;
+    Info *tmpModule;  
+
+    assert(hpc_inited);
+    hpc_ticks_inited = 1;
+
+    trace_filename = (char *) malloc(strlen(prog_name) + 6);
+    sprintf(trace_filename, "%s.rix", prog_name);
+    rixFile = fopen(trace_filename,"w+");
+
+    comma = 0;
+    
+    fprintf(rixFile,"START %s\n",prog_name);
+    fprintf(rixFile,"[");
+    tmpModule = modules;
+    for(;tmpModule != 0;tmpModule = tmpModule->next) {
+      if (comma) {
+	fprintf(rixFile,",");
+      } else {
+	comma = 1;
+      }
+      fprintf(rixFile,"(\"%s\",%u)",
+	      tmpModule->modName,
+	      tmpModule->tickCount);
+#if DEBUG_HPC
+      fprintf(stderr,"(tracer)%s: %u (offset=%u)\n",
+	      tmpModule->modName,
+	      tmpModule->tickCount,
+	      tmpModule->tickOffset);
+#endif
+    }
+    fprintf(rixFile,"]\n");
+    fflush(rixFile);
+  }
+  assert(rixFile != 0);
+
+  fprintf(rixFile,"%d\n",globIx);
+
+#if DEBUG_HPC
+  printf("end: hs_hpc_tick\n");
+#endif
+  
 }
 
 /* This is called after all the modules have registered their local tixboxes,
@@ -270,6 +347,7 @@ startupHpc(void) {
   }
 }
 
+
 /* 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.
  */
@@ -336,6 +414,10 @@ exitHpc(void) {
       
   fprintf(f,"]\n");
   fclose(f);
+
+  if (hpc_ticks_inited && rixFile != 0) {
+    fclose(rixFile);
+  }
   
 }