diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 10 | ||||
| -rw-r--r-- | compiler/codeGen/CgHpc.hs | 32 | ||||
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.lhs | 54 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 6 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 16 | ||||
| -rw-r--r-- | includes/HsFFI.h | 4 | ||||
| -rw-r--r-- | rts/Exception.cmm | 3 | ||||
| -rw-r--r-- | rts/Hpc.c | 90 |
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; @@ -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); + } } |