--
-----------------------------------------------------------------------------
-
module StgCmmClosure (
SMRep,
DynTag, tagForCon, isSmallFamily,
closureValDescr, closureTypeDescr, -- profiling
isStaticClosure,
- cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
+ cafBlackHoleClosureInfo,
staticClosureNeedsLink, clHasCafRefs
) where
import StgSyn
import SMRep
-import Cmm ( ClosureTypeInfo(..) )
+import CmmDecl ( ClosureTypeInfo(..), ConstrDescription )
import CmmExpr
import CLabel
import IdInfo
import DataCon
import Name
-import OccName
import Type
import TypeRep
import TcType
import BasicTypes
import Outputable
import Constants
-
+import DynFlags
-----------------------------------------------------------------------------
-- Representations
-------------
mkLFReEntrant :: TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [Id] -- Free vars
-> [Id] -- Args
-> ArgDescr -- Argument descriptor
-> LambdaFormInfo
{- Note [Data constructor dynamic tags]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The family size of a data type (the number of constructors)
-can be either:
+The family size of a data type (the number of constructors
+or the arity of a function) can be either:
* small, if the family size < 2**tag_bits
* big, otherwise.
Small families can have the constructor tag in the tag bits.
-Big families only use the tag value 1 to represent evaluatedness. -}
+Big families only use the tag value 1 to represent evaluatedness.
+We don't have very many tag bits: for example, we have 2 bits on
+x86-32 and 3 bits on x86-64. -}
isSmallFamily :: Int -> Bool
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
| otherwise = 0
lfDynTag :: LambdaFormInfo -> DynTag
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
lfDynTag (LFCon con) = tagForCon con
lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
lfDynTag _other = 0
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
= 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
closureSMRep :: !SMRep, -- representation used by storage mgr
closureSRT :: !C_SRT, -- What SRT applies to this closure
closureType :: !Type, -- Type of closure (ToDo: remove)
- closureDescr :: !String -- closure description (for profiling)
+ closureDescr :: !String, -- closure description (for profiling)
+ closureCafs :: !CafInfo -- whether the closure may have CAFs
}
-- Constructor closures don't have a unique info table label (they use
closureSMRep = sm_rep,
closureSRT = srt_info,
closureType = idType id,
- closureDescr = descr }
+ closureDescr = descr,
+ closureCafs = idCafInfo id }
where
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
+ closureType = ty,
+ closureCafs = cafs })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
- closureDescr = "" }
+ closureDescr = "",
+ closureCafs = cafs }
cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
-seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
-seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
- = ClosureInfo { closureName = nm,
- closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT,
- closureType = ty,
- closureDescr = "" }
-seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
--------------------------------------
-- Extracting ClosureTypeInfo
--------------------------------------
-closureTypeInfo :: ClosureInfo -> ClosureTypeInfo
-closureTypeInfo cl_info
+-- JD: I've added the continuation arguments not for fun but because
+-- I don't want to pipe the monad in here (circular module dependencies),
+-- and I don't want to pull this code out of this module, which would
+-- require us to expose a bunch of abstract types.
+
+closureTypeInfo ::
+ ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
+ (ClosureTypeInfo -> a) -> a
+closureTypeInfo cl_info k_with_con_name k_simple
= case cl_info of
ConInfo { closureCon = con }
- -> ConstrInfo (ptrs, nptrs)
- (fromIntegral (dataConTagZ con))
- con_name
+ -> k_with_con_name (ConstrInfo (ptrs, nptrs)
+ (fromIntegral (dataConTagZ con))) con info_lbl
where
- con_name = panic "closureTypeInfo"
+ --con_name = panic "closureTypeInfo"
-- Was:
-- cstr <- mkByteStringCLit $ dataConIdentity con
-- con_name = makeRelativeRefTo info_lbl cstr
ClosureInfo { closureName = name,
closureLFInfo = LFReEntrant _ arity _ arg_descr,
closureSRT = srt }
- -> FunInfo (ptrs, nptrs)
- srt
- (fromIntegral arity)
- arg_descr
- (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
+ -> k_simple $ FunInfo (ptrs, nptrs)
+ srt
+ (fromIntegral arity)
+ arg_descr
+ (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
closureSRT = srt }
- -> ThunkSelectorInfo (fromIntegral offset) srt
+ -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
ClosureInfo { closureLFInfo = LFThunk {},
closureSRT = srt }
- -> ThunkInfo (ptrs, nptrs) srt
+ -> k_simple $ ThunkInfo (ptrs, nptrs) srt
_ -> panic "unexpected lambda form in mkCmmInfo"
where
--- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ptrs = fromIntegral $ closurePtrsSize cl_info
size = fromIntegral $ closureNonHdrSize cl_info
nptrs = size - ptrs
-- 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
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.
-- SRTs/CAFs
--------------------------------------
--- This is horrible, but we need to know whether a closure may have CAFs.
+-- We need to know whether a closure may have CAFs.
clHasCafRefs :: ClosureInfo -> CafInfo
-clHasCafRefs (ClosureInfo {closureSRT = srt}) =
- case srt of NoC_SRT -> NoCafRefs
- _ -> MayHaveCafRefs
+clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
clHasCafRefs (ConInfo {}) = NoCafRefs
projects / ghc-hetmet.git / blobdiff