Commit ce1f1607 authored by Simon Marlow's avatar Simon Marlow

Make GHCi & TH work when the compiler is built with -prof

Summary:
Amazingly, there were zero changes to the byte code generator and very
few changes to the interpreter - mainly because we've used good
abstractions that hide the differences between profiling and
non-profiling.  So that bit was pleasantly straightforward, but there
were a pile of other wibbles to get the whole test suite through.

Note that a compiler built with -prof is now like one built with
-dynamic, in that to use TH you have to build the code the same way.
For dynamic, we automatically enable -dynamic-too when TH is required,
but we don't have anything equivalent for profiling, so you have to
explicitly use -prof when building code that uses TH with a profiled
compiler.  For this reason Cabal won't work with TH.  We don't expect
to ship a profiled compiler, so I think that's OK.

Test Plan: validate with GhcProfiled=YES in validate.mk

Reviewers: goldfire, bgamari, rwbarton, austin, hvr, erikd, ezyang

Reviewed By: ezyang

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1407

GHC Trac Issues: #4837, #545
parent a58eeb7f
......@@ -26,6 +26,7 @@ module CmmInfo (
maxStdInfoTableSizeW,
maxRetInfoTableSizeW,
stdInfoTableSizeB,
conInfoTableSizeB,
stdSrtBitmapOffset,
stdClosureTypeOffset,
stdPtrsOffset, stdNonPtrsOffset,
......@@ -551,3 +552,6 @@ stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
conInfoTableSizeB :: DynFlags -> Int
conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
......@@ -321,14 +321,15 @@ dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
-- Initialise the LDV word of a new closure
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure = do dflags <- getDynFlags
emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
ldvRecordCreate closure = do
dflags <- getDynFlags
emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
--
-- Called when a closure is entered, marks the closure as having been "used".
-- The closure is not an 'inherently used' one.
-- The closure is not IND or IND_OLDGEN because neither is considered for LDV
-- profiling.
-- | Called when a closure is entered, marks the closure as having
-- been "used". The closure is not an "inherently used" one. The
-- closure is not @IND@ or @IND_OLDGEN@ because neither is considered
-- for LDV profiling.
--
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure closure_info node_reg = do
......
{-# LANGUAGE CPP, MagicHash #-}
{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
......@@ -20,6 +20,7 @@ import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Type ( flattenRepType, repType, typePrimRep )
import StgCmmLayout ( mkVirtHeapOffsets )
import CmmInfo ( conInfoTableSizeB, profInfoTableSizeW )
import Util
import Control.Monad
......@@ -43,10 +44,6 @@ itblCode dflags (ItblPtr ptr)
| ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags
| otherwise = castPtr ptr
-- XXX bogus
conInfoTableSizeB :: DynFlags -> Int
conInfoTableSizeB dflags = 3 * wORD_SIZE dflags
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
......@@ -258,8 +255,10 @@ foreign import ccall "&stg_interp_constr_entry"
-- Ultra-minimalist version specially for constructors
#if SIZEOF_VOID_P == 8
type HalfWord = Word32
type FullWord = Word64
#else
type HalfWord = Word16
type FullWord = Word32
#endif
data StgConInfoTable = StgConInfoTable {
......@@ -311,6 +310,8 @@ sizeOfItbl dflags itbl
Right xs -> sizeOf (head xs) * length xs
else 0
]
+ if rtsIsProfiled then profInfoTableSizeW * wORD_SIZE dflags
else 0
pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO ()
pokeItbl _ a0 itbl
......@@ -319,6 +320,9 @@ pokeItbl _ a0 itbl
case entry itbl of
Nothing -> return ()
Just e -> store e
when rtsIsProfiled $ do
store (0 :: FullWord)
store (0 :: FullWord)
store (ptrs itbl)
store (nptrs itbl)
store (tipe itbl)
......@@ -335,6 +339,10 @@ peekItbl dflags a0
entry' <- if ghciTablesNextToCode
then return Nothing
else liftM Just load
when rtsIsProfiled $ do
(_ :: Ptr FullWord) <- advance
(_ :: Ptr FullWord) <- advance
return ()
ptrs' <- load
nptrs' <- load
tipe' <- load
......
......@@ -504,24 +504,20 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay dflags srcspan =
if interpWays == haskellWays
then return Nothing
-- see #3604: object files compiled for way "dyn" need to link to the
-- dynamic packages, so we can't load them into a statically-linked GHCi.
-- we have to treat "dyn" in the same way as "prof".
--
-- In the future when GHCi is dynamically linked we should be able to relax
-- this, but they we may have to make it possible to load either ordinary
-- .o files or -dynamic .o files into GHCi (currently that's not possible
-- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
-- whereas we have __stginit_base_Prelude_.
else if objectSuf dflags == normalObjectSuffix && not (null haskellWays)
then failNonStd dflags srcspan
else return $ Just $ if dynamicGhc
then "dyn_o"
else "o"
where haskellWays = filter (not . wayRTSOnly) (ways dflags)
checkNonStdWay dflags srcspan
| interpWays == haskellWays = return Nothing
-- Only if we are compiling with the same ways as GHC is built
-- with, can we dynamically load those object files. (see #3604)
| objectSuf dflags == normalObjectSuffix && not (null haskellWays)
= failNonStd dflags srcspan
| otherwise = return (Just (interpTag ++ "o"))
where
haskellWays = filter (not . wayRTSOnly) (ways dflags)
interpTag = case mkBuildTag interpWays of
"" -> ""
tag -> tag ++ "_"
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn
......@@ -529,11 +525,13 @@ normalObjectSuffix = phaseInputExt StopLn
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
failNonStd dflags srcspan = dieWith dflags srcspan $
ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
ptext (sLit "You need to build the program twice: once the") <+> ghciWay <+> ptext (sLit "way, and then") $$
ptext (sLit "You need to build the program twice: once") <+>
ghciWay <> ptext (sLit ", and then") $$
ptext (sLit "in the desired way using -osuf to set the object file suffix.")
where ghciWay = if dynamicGhc
then ptext (sLit "dynamic")
else ptext (sLit "normal")
where ghciWay
| dynamicGhc = ptext (sLit "with -dynamic")
| rtsIsProfiled = ptext (sLit "with -prof")
| otherwise = ptext (sLit "the normal way")
getLinkDeps :: HscEnv -> HomePackageTable
-> PersistentLinkerState
......@@ -663,7 +661,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
ok <- doesFileExist new_file
if (not ok)
then dieWith dflags span $
ptext (sLit "cannot find normal object file ")
ptext (sLit "cannot find object file ")
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
......@@ -1199,22 +1197,34 @@ locateLib dflags is_hs dirs lib
-- for a dynamic library (#5289)
-- otherwise, assume loadDLL can find it
--
= findDll `orElse` findArchive `orElse` tryGcc `orElse` tryGccPrefixed `orElse` assumeDll
| not dynamicGhc
-- When the GHC package was not compiled as dynamic library
-- (=DYNAMIC not set), we search for .o libraries or, if they
-- don't exist, .a libraries.
= findObject `orElse` findArchive `orElse` assumeDll
= findDll `orElse`
findArchive `orElse`
tryGcc `orElse`
tryGccPrefixed `orElse`
assumeDll
| otherwise
| dynamicGhc
-- When the GHC package was compiled as dynamic library (=DYNAMIC set),
-- we search for .so libraries first.
= findHSDll `orElse` findDynObject `orElse` assumeDll
| rtsIsProfiled
-- When the GHC package is profiled, only a libHSfoo_p.a archive will do.
= findArchive `orElse`
assumeDll
| otherwise
-- HSfoo.o is the best, but only works for the normal way
-- libHSfoo.a is the backup option.
= findObject `orElse`
findArchive `orElse`
assumeDll
where
obj_file = lib <.> "o"
dyn_obj_file = lib <.> "dyn_o"
arch_file = "lib" ++ lib <.> "a"
arch_file = "lib" ++ lib ++ lib_tag <.> "a"
lib_tag = if is_hs && rtsIsProfiled then "_p" else ""
hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
......
......@@ -175,17 +175,17 @@ getClosureData :: DynFlags -> a -> IO Closure
getClosureData dflags a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
let iptr'
| ghciTablesNextToCode =
Ptr iptr
let iptr0 = Ptr iptr
let iptr1
| ghciTablesNextToCode = iptr0
| otherwise =
-- the info pointer we get back from unpackClosure#
-- is to the beginning of the standard info table,
-- but the Storable instance for info tables takes
-- into account the extra entry pointer when
-- !ghciTablesNextToCode, so we must adjust here:
Ptr iptr `plusPtr` negate (wORD_SIZE dflags)
itbl <- peekItbl dflags iptr'
iptr0 `plusPtr` negate (wORD_SIZE dflags)
itbl <- peekItbl dflags iptr1
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
......@@ -193,7 +193,7 @@ getClosureData dflags a =
| I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
ASSERT(elems >= 0) return ()
ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
return (Closure tipe iptr0 itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
readCType i
......@@ -774,7 +774,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
return (Term my_ty (Right dc) a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
tipe_clos ->
tipe_clos -> do
traceTR (text "Unknown closure:" <+> ppr tipe_clos)
return (Suspension tipe_clos my_ty a Nothing)
-- insert NewtypeWraps around newtypes
......
......@@ -172,10 +172,8 @@ import SrcLoc
import BasicTypes ( IntWithInf, treatZeroAsInf )
import FastString
import Outputable
#ifdef GHCI
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
import System.IO.Unsafe ( unsafePerformIO )
......@@ -1580,9 +1578,10 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
else []
interpWays :: [Way]
interpWays = if dynamicGhc
then [WayDyn]
else []
interpWays
| dynamicGhc = [WayDyn]
| rtsIsProfiled = [WayProf]
| otherwise = []
--------------------------------------------------------------------------
......@@ -3493,14 +3492,12 @@ glasgowExtsFlags = [
, Opt_UnicodeSyntax
, Opt_UnliftedFFITypes ]
#ifdef GHCI
-- Consult the RTS to find whether GHC itself has been built profiled
-- If so, you can't use Template Haskell
foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
rtsIsProfiled :: Bool
rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
#endif
#ifdef GHCI
-- Consult the RTS to find whether GHC itself has been built with
......@@ -4126,6 +4123,8 @@ compilerInfo dflags
then "YES" else "NO"),
("GHC Dynamic", if dynamicGhc
then "YES" else "NO"),
("GHC Profiled", if rtsIsProfiled
then "YES" else "NO"),
("Leading underscore", cLeadingUnderscore),
("Debug on", show debugIsOn),
("LibDir", topDir dflags),
......@@ -4217,6 +4216,14 @@ makeDynFlagsConsistent dflags
"Enabling -fPIC as it is always on for this platform"
| Left err <- checkOptLevel (optLevel dflags) dflags
= loop (updOptLevel 0 dflags) err
| LinkInMemory <- ghcLink dflags
, rtsIsProfiled
, isObjectTarget (hscTarget dflags)
, WayProf `notElem` ways dflags
= loop dflags{ways = WayProf : ways dflags}
"Enabling -prof, because -fobject-code is enabled and GHCi is profiled"
| otherwise = (dflags, [])
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
loop updated_dflags warning
......
......@@ -1787,11 +1787,6 @@ hscCompileCoreExpr hsc_env =
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
| rtsIsProfiled
= throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
-- Otherwise you get a seg-fault when you run it
| otherwise
= do { let dflags = hsc_dflags hsc_env
{- Simplify it -}
......
......@@ -83,7 +83,6 @@ import Data.Maybe
import Exception hiding (catch)
import Foreign.C
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
......@@ -346,8 +345,6 @@ findEditor = do
return ""
#endif
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
default_progname, default_prompt, default_prompt2, default_stop :: String
default_progname = "<interactive>"
default_prompt = "%s> "
......@@ -360,13 +357,6 @@ default_args = []
interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
interactiveUI config srcs maybe_exprs = do
-- although GHCi compiles with -prof, it is not usable: the byte-code
-- compiler and interpreter don't work with profiling. So we check for
-- this up front and emit a helpful error message (#2197)
i <- liftIO $ isProfiled
when (i /= 0) $
throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
......
......@@ -244,10 +244,12 @@ extern CostCentreStack * RTS_VAR(CCS_LIST); // registered CCS list
/* eliminate profiling overhead from allocation costs */
#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs
#else /* !PROFILING */
#define CCS_ALLOC(ccs, amount) doNothing()
#define ENTER_CCS_THUNK(cap,p) doNothing()
#endif /* PROFILING */
......
......@@ -48,28 +48,6 @@ typedef struct {
#endif
} StgProfInfo;
/* -----------------------------------------------------------------------------
Ticky info
There is no ticky-specific stuff in an info table at this time.
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
Debugging info
-------------------------------------------------------------------------- */
#ifdef DEBUG_CLOSURE
typedef struct {
... whatever ...
} StgDebugInfo;
#else /* !DEBUG_CLOSURE */
/* There is no DEBUG-specific stuff in an info table at this time. */
#endif /* DEBUG_CLOSURE */
/* -----------------------------------------------------------------------------
Closure flags
-------------------------------------------------------------------------- */
......@@ -216,12 +194,6 @@ typedef struct StgInfoTable_ {
#ifdef PROFILING
StgProfInfo prof;
#endif
#ifdef TICKY
/* Ticky-specific stuff would go here. */
#endif
#ifdef DEBUG_CLOSURE
/* Debug-specific stuff would go here. */
#endif
StgClosureInfo layout; /* closure layout info (one word) */
......
......@@ -340,6 +340,8 @@ eval_obj:
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
}
ENTER_CCS_THUNK(cap,ap);
/* Ok; we're safe. Party on. Push an update frame. */
Sp -= sizeofW(StgUpdateFrame);
{
......@@ -529,7 +531,7 @@ do_return_unboxed:
// get the offset of the stg_ctoi_ret_XXX itbl
offset = stack_frame_sizeW((StgClosure *)Sp);
switch (get_itbl((StgClosure *)Sp+offset)->type) {
switch (get_itbl((StgClosure*)((StgPtr)Sp+offset))->type) {
case RET_BCO:
// Returning to an interpreted continuation: put the object on
......@@ -883,7 +885,7 @@ run_BCO:
// the BCO
size_words = BCO_BITMAP_SIZE(obj) + 2;
new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
new_aps->size = size_words;
new_aps->fun = &stg_dummy_ret_closure;
......@@ -1098,7 +1100,7 @@ run_BCO:
ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
Sp[-1] = (W_)ap;
ap->n_args = n_payload;
SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
Sp --;
goto nextInsn;
}
......@@ -1109,7 +1111,7 @@ run_BCO:
ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
Sp[-1] = (W_)ap;
ap->n_args = n_payload;
SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
Sp --;
goto nextInsn;
}
......@@ -1122,7 +1124,7 @@ run_BCO:
Sp[-1] = (W_)pap;
pap->n_args = n_payload;
pap->arity = arity;
SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
Sp --;
goto nextInsn;
}
......@@ -1192,7 +1194,7 @@ run_BCO:
itbl->layout.payload.nptrs );
StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
for (i = 0; i < n_words; i++) {
con->payload[i] = (StgClosure*)Sp[i];
}
......
......@@ -31,6 +31,7 @@
#include "GetEnv.h"
#include "Stable.h"
#include "RtsSymbols.h"
#include "Profiling.h"
#if !defined(mingw32_HOST_OS)
#include "posix/Signals.h"
......@@ -1831,9 +1832,15 @@ static HsInt loadArchive_ (pathchar *path)
IF_DEBUG(linker,
debugBelch("loadArchive: Found member file `%s'\n", fileName));
isObject = thisFileNameSize >= 2
&& fileName[thisFileNameSize - 2] == '.'
&& fileName[thisFileNameSize - 1] == 'o';
isObject =
(thisFileNameSize >= 2 &&
fileName[thisFileNameSize - 2] == '.' &&
fileName[thisFileNameSize - 1] == 'o')
|| (thisFileNameSize >= 4 &&
fileName[thisFileNameSize - 4] == '.' &&
fileName[thisFileNameSize - 3] == 'p' &&
fileName[thisFileNameSize - 2] == '_' &&
fileName[thisFileNameSize - 1] == 'o');
IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize));
IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject));
......@@ -2260,6 +2267,12 @@ static HsInt resolveObjs_ (void)
oc->status = OBJECT_RESOLVED;
}
}
#ifdef PROFILING
// collect any new cost centres & CCSs that were defined during runInit
initProfiling2();
#endif
IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
return 1;
}
......
......@@ -1960,8 +1960,6 @@ stg_mkApUpd0zh ( P_ bco )
stg_unpackClosurezh ( P_ closure )
{
// TODO: Consider the absence of ptrs or nonptrs as a special case ?
W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
info = %GET_STD_INFO(UNTAG(closure));
......
......@@ -311,7 +311,7 @@ nextEra( void )
FILE *hp_file;
static char *hp_filename;
void initProfiling1 (void)
void initProfiling (void)
{
}
......
......@@ -142,8 +142,7 @@ static void initProfilingLogFile ( void );
Initialise the profiling environment
-------------------------------------------------------------------------- */
void
initProfiling1 (void)
void initProfiling (void)
{
// initialise our arena
prof_arena = newArena();
......@@ -159,18 +158,6 @@ initProfiling1 (void)
#ifdef THREADED_RTS
initMutex(&ccs_mutex);
#endif
}
void
freeProfiling (void)
{
arenaFree(prof_arena);
}
void
initProfiling2 (void)
{
CostCentreStack *ccs, *next;
/* Set up the log file, and dump the header and cost centre
* information into it.
......@@ -205,14 +192,7 @@ initProfiling2 (void)
CCS_MAIN->root = CCS_MAIN;
ccsSetSelected(CCS_MAIN);
// make CCS_MAIN the parent of all the pre-defined CCSs.
for (ccs = CCS_LIST; ccs != NULL; ) {
next = ccs->prevStack;
ccs->prevStack = NULL;
actualPush_(CCS_MAIN,ccs->cc,ccs);
ccs->root = ccs;
ccs = next;
}
initProfiling2();
if (RtsFlags.CcFlags.doCostCentres) {
initTimeProfiling();
......@@ -223,6 +203,29 @@ initProfiling2 (void)
}
}
//
// Should be called after loading any new Haskell code.
//
void initProfiling2 (void)
{
CostCentreStack *ccs, *next;
// make CCS_MAIN the parent of all the pre-defined CCSs.
for (ccs = CCS_LIST; ccs != NULL; ) {
next = ccs->prevStack;
ccs->prevStack = NULL;
actualPush_(CCS_MAIN,ccs->cc,ccs);
ccs->root = ccs;
ccs = next;
}
CCS_LIST = NULL;
}
void
freeProfiling (void)
{
arenaFree(prof_arena);
}
static void
initProfilingLogFile(void)
......
......@@ -20,7 +20,7 @@
#define PROFILING_ONLY(s) doNothing()
#endif
void initProfiling1 (void);
void initProfiling (void);
void initProfiling2 (void);
void endProfiling (void);
void freeProfiling (void);
......
......@@ -230,7 +230,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
initThreadLabelTable();
#endif
initProfiling1();
initProfiling();
/* start the virtual timer 'subsystem'. */
initTimer();
......@@ -255,10 +255,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
startupHpc();
// This must be done after module initialisation.
// ToDo: make this work in the presence of multiple hs_add_root()s.
initProfiling2();
// ditto.
#if defined(THREADED_RTS)
ioManagerStart();
......
......@@ -641,10 +641,25 @@
SymI_HasProto(stg_INTLIKE_closure)
#endif
#if defined(PROFILING)
#define RTS_PROF_SYMBOLS \
SymI_HasProto(CCS_DONT_CARE) \
SymI_HasProto(CC_LIST) \
SymI_HasProto(CC_ID) \
SymI_HasProto(CCS_LIST) \
SymI_HasProto(CCS_ID) \
SymI_HasProto(stg_restore_cccs_info) \
SymI_HasProto(enterFunCCS) \
SymI_HasProto(pushCostCentre) \
SymI_HasProto(era)
#else
#define RTS_PROF_SYMBOLS /* empty */
#endif
#define RTS_SYMBOLS \
Maybe_Stable_Names \
RTS_TICKY_SYMBOLS \
RTS_PROF_SYMBOLS \
SymI_HasProto(StgReturn) \
SymI_HasProto(stg_gc_noregs) \
SymI_HasProto(stg_ret_v_info) \
......
......@@ -179,7 +179,6 @@ def get_compiler_info():
if re.match(".*_p(_.*|$)", rtsInfoDict["RTS way"]):
config.compiler_profiled = True
config.run_ways = [x for x in config.run_ways if x != 'ghci']
else:
config.compiler_profiled = False
......@@ -204,6 +203,11 @@ def get_compiler_info():
config.ghci_way_flags = "-dynamic"
config.ghc_th_way = "dyn"
config.ghc_plugin_way = "dyn"
elif config.compiler_profiled:
config.ghc_th_way_flags = "-prof"
config.ghci_way_flags = "-prof"
config.ghc_th_way = "prof"
config.ghc_plugin_way = "prof"
else:
config.ghc_th_way_flags = "-static"
config.ghci_way_flags = "-static"
......
......@@ -250,6 +250,10 @@ ifeq "$(GhcDynamic)" "YES"
ghcThWayFlags = -dynamic
ghciWayFlags = -dynamic
ghcPluginWayFlags = -dynamic
else ifeq "$(GhcProfiled)" "YES"
ghcThWayFlags = -prof
ghciWayFlags = -prof
ghcPluginWayFlags = -prof
else
ghcThWayFlags = -static
ghciWayFlags = -static
......
......@@ -25,6 +25,7 @@ main = do
getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
......