summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/codeGen/CgClosure.lhs6
-rw-r--r--compiler/codeGen/CgTailCall.lhs3
-rw-r--r--compiler/codeGen/CgTicky.hs8
-rw-r--r--compiler/codeGen/ClosureInfo.lhs32
-rw-r--r--compiler/codeGen/StgCmmBind.hs3
-rw-r--r--compiler/codeGen/StgCmmClosure.hs33
-rw-r--r--compiler/codeGen/StgCmmExpr.hs5
-rw-r--r--compiler/codeGen/StgCmmTicky.hs9
-rw-r--r--compiler/main/DynFlags.hs6
-rw-r--r--compiler/main/StaticFlags.hs3
10 files changed, 61 insertions, 47 deletions
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 18879a3756..56f2847052 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -395,8 +395,10 @@ thunkWrapper closure_info thunk_code = do
-- Stack and/or heap checks
; thunkEntryChecks closure_info $ do
- { -- Overwrite with black hole if necessary
- whenC (blackHoleOnEntry closure_info && node_points)
+ {
+ dflags <- getDynFlags
+ -- Overwrite with black hole if necessary
+ ; whenC (blackHoleOnEntry dflags closure_info && node_points)
(blackHoleIt closure_info)
; setupUpdate closure_info thunk_code }
-- setupUpdate *encloses* the thunk_code
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 6f8fd040cb..e4f79a7aa6 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -108,7 +108,8 @@ performTailCall fun_info arg_amodes pending_assts
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
- ; case (getCallMethod fun_name fun_has_cafs lf_info (length arg_amodes)) of
+ ; dflags <- getDynFlags
+ ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
-- Node must always point to things we enter
EnterIt -> do
diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
index 5422127ae5..27af4461b1 100644
--- a/compiler/codeGen/CgTicky.hs
+++ b/compiler/codeGen/CgTicky.hs
@@ -69,6 +69,8 @@ import PrelNames
import TcType
import TyCon
+import DynFlags
+
import Data.Maybe
-----------------------------------------------------------------------------
@@ -298,9 +300,9 @@ tickyAllocHeap hp
-- Ticky utils
ifTicky :: Code -> Code
-ifTicky code
- | opt_DoTickyProfiling = code
- | otherwise = nopC
+ifTicky code = do dflags <- getDynFlags
+ if doingTickyProfiling dflags then code
+ else nopC
addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 0620099ac7..d819873ca9 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -88,6 +88,7 @@ import BasicTypes
import FastString
import Outputable
import Constants
+import DynFlags
\end{code}
@@ -576,37 +577,38 @@ data CallMethod
CLabel -- The code label
Int -- Its arity
-getCallMethod :: Name -- Function being applied
+getCallMethod :: DynFlags
+ -> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod name _ lf_info n_args
+getCallMethod _ name _ lf_info n_args
| nodeMustPointToIt lf_info && opt_Parallel
= -- If we're parallel, then we must always enter via node.
-- The reason is that the closure may have been
-- fetched since we allocated it.
EnterIt
-getCallMethod name caf (LFReEntrant _ arity _ _) n_args
+getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel name caf) arity
-getCallMethod name _ (LFCon con) n_args
+getCallMethod _ name _ (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
| is_fun -- it *might* be a function, so we must "call" it (which is
-- always safe)
= SlowCall -- We cannot just enter it [in eval/apply, the entry code
-- is the fast-entry code]
-- Since is_fun is False, we are *definitely* looking at a data value
- | updatable || opt_DoTickyProfiling -- to catch double entry
+ | updatable || doingTickyProfiling dflags -- to catch double entry
{- OLD: || opt_SMP
I decided to remove this, because in SMP mode it doesn't matter
if we enter the same thunk multiple times, so the optimisation
@@ -624,10 +626,10 @@ getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
= ASSERT( n_args == 0 )
JumpToIt (thunkEntryLabel name caf std_form_info updatable)
-getCallMethod name _ (LFUnknown True) n_args
+getCallMethod _ name _ (LFUnknown True) n_args
= SlowCall -- Might be a function
-getCallMethod name _ (LFUnknown False) n_args
+getCallMethod _ name _ (LFUnknown False) n_args
| n_args > 0
= WARN( True, ppr name <+> ppr n_args )
SlowCall -- Note [Unsafe coerce complications]
@@ -635,27 +637,27 @@ getCallMethod name _ (LFUnknown False) n_args
| otherwise
= EnterIt -- Not a function
-getCallMethod name _ (LFBlackHole _) n_args
+getCallMethod _ name _ (LFBlackHole _) n_args
= SlowCall -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we slow call it
-getCallMethod name _ (LFLetNoEscape 0) n_args
+getCallMethod _ name _ (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod name _ (LFLetNoEscape arity) n_args
+getCallMethod _ name _ (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
-blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
-- Updatable ones will be overwritten with a CAFList cell, which points to a
-- black hole;
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry ConInfo{} = False
-blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+blackHoleOnEntry _ ConInfo{} = False
+blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
| isStaticRep rep
= False -- Never black-hole a static closure
@@ -666,7 +668,7 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
- else opt_DoTickyProfiling || not no_fvs
+ else doingTickyProfiling dflags || not no_fvs
-- the former to catch double entry,
-- and the latter to plug space-leaks. KSW/SDM 1999-04.
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index b4415eb1f0..ee033b19c9 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -462,7 +462,8 @@ thunkCode cl_info fv_details cc node arity body
; entryHeapCheck node arity [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
- whenC (blackHoleOnEntry cl_info && node_points)
+ dflags <- getDynFlags
+ ; whenC (blackHoleOnEntry dflags cl_info && node_points)
(blackHoleIt cl_info)
-- Push update frame
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 7e8f02c17e..d4789be8e7 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -90,7 +90,7 @@ import TyCon
import BasicTypes
import Outputable
import Constants
-
+import DynFlags
-----------------------------------------------------------------------------
-- Representations
@@ -491,38 +491,39 @@ data CallMethod
CLabel -- The code label
Int -- Its arity
-getCallMethod :: Name -- Function being applied
+getCallMethod :: DynFlags
+ -> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod _name _ lf_info _n_args
+getCallMethod _ _name _ lf_info _n_args
| nodeMustPointToIt lf_info && opt_Parallel
= -- If we're parallel, then we must always enter via node.
-- The reason is that the closure may have been
-- fetched since we allocated it.
EnterIt
-getCallMethod name caf (LFReEntrant _ arity _ _) n_args
+getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel name caf) arity
-getCallMethod _name _ LFUnLifted n_args
+getCallMethod _ _name _ LFUnLifted n_args
= ASSERT( n_args == 0 ) ReturnIt
-getCallMethod _name _ (LFCon _) n_args
+getCallMethod _ _name _ (LFCon _) n_args
= ASSERT( n_args == 0 ) ReturnIt
-getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
| is_fun -- it *might* be a function, so we must "call" it (which is always safe)
= SlowCall -- We cannot just enter it [in eval/apply, the entry code
-- is the fast-entry code]
-- Since is_fun is False, we are *definitely* looking at a data value
- | updatable || opt_DoTickyProfiling -- to catch double entry
+ | updatable || doingTickyProfiling dflags -- to catch double entry
{- OLD: || opt_SMP
I decided to remove this, because in SMP mode it doesn't matter
if we enter the same thunk multiple times, so the optimisation
@@ -540,19 +541,19 @@ getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
= ASSERT( n_args == 0 )
DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
-getCallMethod _name _ (LFUnknown True) _n_args
+getCallMethod _ _name _ (LFUnknown True) _n_args
= SlowCall -- might be a function
-getCallMethod name _ (LFUnknown False) n_args
+getCallMethod _ name _ (LFUnknown False) n_args
= ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
EnterIt -- Not a function
-getCallMethod _name _ (LFBlackHole _) _n_args
+getCallMethod _ _name _ (LFBlackHole _) _n_args
= SlowCall -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we slow call it
-getCallMethod _name _ LFLetNoEscape _n_args
+getCallMethod _ _name _ LFLetNoEscape _n_args
= JumpToIt
isStandardFormThunk :: LambdaFormInfo -> Bool
@@ -887,15 +888,15 @@ minPayloadSize smrep updatable
-- Other functions over ClosureInfo
--------------------------------------
-blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
-- Updatable ones will be overwritten with a CAFList cell, which points to a
-- black hole;
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry ConInfo{} = False
-blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+blackHoleOnEntry _ ConInfo{} = False
+blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
| isStaticRep rep
= False -- Never black-hole a static closure
@@ -906,7 +907,7 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
- else opt_DoTickyProfiling || not no_fvs
+ else doingTickyProfiling dflags || not no_fvs
-- the former to catch double entry,
-- and the latter to plug space-leaks. KSW/SDM 1999-04.
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 47bf6c433d..369564cba8 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -442,8 +442,9 @@ cgLneJump blk_id lne_regs args -- Join point; discard sequel
<*> mkBranch blk_id) }
cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
-cgTailCall fun_id fun_info args
- = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
+cgTailCall fun_id fun_info args = do
+ dflags <- getDynFlags
+ case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
-- A value in WHNF, so we can just return it.
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 544f863012..2e4b29e73b 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -56,12 +56,13 @@ import CLabel
import Module
import Name
import Id
-import StaticFlags
import BasicTypes
import FastString
import Constants
import Outputable
+import DynFlags
+
-- Turgid imports for showTypeCategory
import PrelNames
import TcType
@@ -321,9 +322,9 @@ tickyAllocHeap hp
-- Ticky utils
ifTicky :: FCode () -> FCode ()
-ifTicky code
- | opt_DoTickyProfiling = code
- | otherwise = nopC
+ifTicky code = do dflags <- getDynFlags
+ if doingTickyProfiling dflags then code
+ else nopC
-- All the ticky-ticky counters are declared "unsigned long" in C
bumpTickyCounter :: LitString -> FCode ()
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index b5cfb235bb..3f975cd984 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -35,6 +35,7 @@ module DynFlags (
updOptLevel,
setTmpDir,
setPackageName,
+ doingTickyProfiling,
-- ** Parsing DynFlags
parseDynamicFlags,
@@ -517,6 +518,11 @@ isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
isNoLink _ = False
+-- Is it worth evaluating this Bool and caching it in the DynFlags value
+-- during initDynFlags?
+doingTickyProfiling :: DynFlags -> Bool
+doingTickyProfiling dflags = WayTicky `elem` wayNames dflags
+
data PackageFlag
= ExposePackage String
| HidePackage String
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 456f62009d..d88a33de67 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,7 +27,6 @@ module StaticFlags (
-- profiling opts
opt_SccProfilingOn,
- opt_DoTickyProfiling,
-- Hpc opts
opt_Hpc,
@@ -196,8 +195,6 @@ opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
-- profiling opts
opt_SccProfilingOn :: Bool
opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling")
-opt_DoTickyProfiling :: Bool
-opt_DoTickyProfiling = WayTicky `elem` (unsafePerformIO $ readIORef v_Ways)
-- Hpc opts
opt_Hpc :: Bool
View Lorry Controller Status