Commit d50e93cf authored by andy@galois.com's avatar andy@galois.com
Browse files

Adding tracing support

parent 71e810db
......@@ -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")
......
......@@ -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"
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 )
]
......
......@@ -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")
......
......@@ -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);
/* -------------------------------------------------------------------------- */
......
......@@ -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);
}
}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment