mkHpcTicksLabel,
mkHpcModuleNameLabel,
+ mkHpcModuleOffsetLabel,
infoLblToEntryLbl, entryLblToInfoLbl,
needsCDecl, isAsmTemp, externallyVisibleCLabel,
| 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)
mkHpcTicksLabel = HpcTicksLabel
mkHpcModuleNameLabel = HpcModuleNameLabel
+mkHpcModuleOffsetLabel = HpcModuleOffsetLabel
-- Dynamic linking
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True
+needsCDecl (HpcModuleOffsetLabel _) = True
needsCDecl HpcModuleNameLabel = False
-- Whether the label is an assembler temporary:
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
+externallyVisibleCLabel (HpcModuleOffsetLabel _) = True
externallyVisibleCLabel HpcModuleNameLabel = False
-- -----------------------------------------------------------------------------
= 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")
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
[ 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
(module_name_str)
++ [0]
]
+ emitData Data
+ [ CmmDataLabel (mkHpcModuleOffsetLabel this_mod)
+ , CmmStaticLit (CmmInt 0 I32)
+ ]
emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
] ++
[ CmmStaticLit (CmmInt 0 I64)
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
, (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"
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
; 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)
, 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
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"
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
, 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)
; 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
| Opt_HideAllPackages
| Opt_PrintBindResult
| Opt_Haddock
- | Opt_Hpc
- | Opt_Hpc_Tracer
-- keeping stuff
| Opt_KeepHiDiffs
( "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 )
]
opt_SccProfilingOn,
opt_DoTickyProfiling,
+ -- Hpc opts
+ opt_Hpc,
+ opt_Hpc_Tracer,
+
-- language opts
opt_DictsStrict,
opt_IrrefutableTuples,
, ( "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") )
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")
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);
/* -------------------------------------------------------------------------- */
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;
* (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"
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
* 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);
for(i=0;i < modCount;i++) {
tixArr[i] = tixBoxes[i + tmpModule->tickOffset];
}
- return;
+ return tmpModule->tickOffset;
}
lastModule = tmpModule;
}
#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,
}
}
+
/* 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.
*/
fprintf(f,"]\n");
fclose(f);
+
+ if (hpc_ticks_inited && rixFile != 0) {
+ fclose(rixFile);
+ }
}
projects / ghc-hetmet.git / commitdiff