Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
d50e93cf
Commit
d50e93cf
authored
Dec 09, 2006
by
andy@galois.com
Browse files
Adding tracing support
parent
71e810db
Changes
10
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
d50e93cf
...
...
@@ -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"
)
...
...
compiler/codeGen/CgHpc.hs
View file @
d50e93cf
...
...
@@ -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"
...
...
compiler/codeGen/CodeGen.lhs
View file @
d50e93cf
...
...
@@ -152,7 +152,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
emitData Data [CmmDataLabel moduleRegdLabel,
CmmStaticLit zeroCLit]
; whenC (
d
opt
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 (
d
opt
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 ||
d
opt
Opt_Hpc dflags
rec_descent_init = if opt_SccProfilingOn || opt
_Hpc
then jump_to_init
else ret_code
...
...
compiler/deSugar/Coverage.lhs
View file @
d50e93cf
...
...
@@ -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)
...
...
compiler/deSugar/Desugar.lhs
View file @
d50e93cf
...
...
@@ -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
d
opt
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
...
...
compiler/main/DynFlags.hs
View file @
d50e93cf
...
...
@@ -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
)
]
...
...
compiler/main/StaticFlags.hs
View file @
d50e93cf
...
...
@@ -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"
)
...
...
includes/HsFFI.h
View file @
d50e93cf
...
...
@@ -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
);
/* -------------------------------------------------------------------------- */
...
...
rts/Exception.cmm
View file @
d50e93cf
...
...
@@ -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
;
...
...
rts/Hpc.c
View file @
d50e93cf
...
...
@@ -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
);
}
}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment