summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
8402955)
We used to use StaticFlags
-- Stack and/or heap checks
; thunkEntryChecks closure_info $ 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
(blackHoleIt closure_info)
; setupUpdate closure_info thunk_code }
-- setupUpdate *encloses* the thunk_code
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
| 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
-- Node must always point to things we enter
EnterIt -> do
import TcType
import TyCon
import TcType
import TyCon
import Data.Maybe
-----------------------------------------------------------------------------
import Data.Maybe
-----------------------------------------------------------------------------
-- Ticky utils
ifTicky :: Code -> Code
-- 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
addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
import FastString
import Outputable
import Constants
import FastString
import Outputable
import Constants
CLabel -- The code label
Int -- Its arity
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
-> 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
| 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
| 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
= 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
| 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
{- 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
= ASSERT( n_args == 0 )
JumpToIt (thunkEntryLabel name caf std_form_info updatable)
= 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
= 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]
| n_args > 0
= WARN( True, ppr name <+> ppr n_args )
SlowCall -- Note [Unsafe coerce complications]
| otherwise
= EnterIt -- Not a function
| 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
= 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))
= 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)
| 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.
-- 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
| isStaticRep rep
= False -- Never black-hole a static closure
LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
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.
-- the former to catch double entry,
-- and the latter to plug space-leaks. KSW/SDM 1999-04.
; entryHeapCheck node arity [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
; 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
(blackHoleIt cl_info)
-- Push update frame
import BasicTypes
import Outputable
import Constants
import BasicTypes
import Outputable
import Constants
-----------------------------------------------------------------------------
-- Representations
-----------------------------------------------------------------------------
-- Representations
CLabel -- The code label
Int -- Its arity
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
-> 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
| 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
| 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
= ASSERT( n_args == 0 ) ReturnIt
-getCallMethod _name _ (LFCon _) n_args
+getCallMethod _ _name _ (LFCon _) n_args
= ASSERT( n_args == 0 ) ReturnIt
= 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
| 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
{- 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
= ASSERT( n_args == 0 )
DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
= 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
= 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
= 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
= 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
= JumpToIt
isStandardFormThunk :: LambdaFormInfo -> Bool
-- Other functions over ClosureInfo
--------------------------------------
-- 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.
-- 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
| isStaticRep rep
= False -- Never black-hole a static closure
LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
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.
-- the former to catch double entry,
-- and the latter to plug space-leaks. KSW/SDM 1999-04.
<*> mkBranch blk_id) }
cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
<*> 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?
-- A value in WHNF, so we can just return it.
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
import Module
import Name
import Id
import Module
import Name
import Id
import BasicTypes
import FastString
import Constants
import Outputable
import BasicTypes
import FastString
import Constants
import Outputable
-- Turgid imports for showTypeCategory
import PrelNames
import TcType
-- Turgid imports for showTypeCategory
import PrelNames
import TcType
-- Ticky utils
ifTicky :: FCode () -> FCode ()
-- 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 ()
-- All the ticky-ticky counters are declared "unsigned long" in C
bumpTickyCounter :: LitString -> FCode ()
updOptLevel,
setTmpDir,
setPackageName,
updOptLevel,
setTmpDir,
setPackageName,
-- ** Parsing DynFlags
parseDynamicFlags,
-- ** Parsing DynFlags
parseDynamicFlags,
isNoLink NoLink = True
isNoLink _ = False
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
data PackageFlag
= ExposePackage String
| HidePackage String
-- profiling opts
opt_SccProfilingOn,
-- profiling opts
opt_SccProfilingOn,
-- profiling opts
opt_SccProfilingOn :: Bool
opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling")
-- 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
-- Hpc opts
opt_Hpc :: Bool