-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ClosureInfo]{Data structures which describe closures}
EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ UpdateFlag,
closureSize, closureHdrSize,
closureNonHdrSize, closureSizeWithoutFixedHdr,
- closureGoodStuffSize, closurePtrsSize, -- UNUSED: closureNonPtrsSize,
+ closureGoodStuffSize, closurePtrsSize,
slopSize, fitsMinUpdSize,
layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ mkVirtHeapOffsets,
+
+ nodeMustPointToIt, getEntryConvention,
+ SYN_IE(FCode), CgInfoDownwards, CgState,
- nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
- staticClosureRequired,
+ staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
stdVapRequired, noUpdVapRequired,
+ StgBinderInfo,
- closureId, infoTableLabelFromCI,
+ closureId, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
+ GenStgArg,
---OLD auxInfoTableLabelFromCI, isIntLikeRep, -- go away in 0.23
-
+ isToplevClosure,
closureKind, closureTypeDescr, -- profiling
- isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
isStaticClosure, allocProfilingMsg,
blackHoleClosureInfo,
- getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr, --UNUSED: equivSMRepHdr,
maybeSelectorInfo,
- dataConLiveness, -- concurrency
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset, MagicId,
- CgInfoDownwards, CgState, CgIdInfo, CompilationInfo,
- CLabel, Id, Maybe, PrimKind, FCode(..), TyCon, StgExpr,
- StgAtom, StgBinderInfo,
- DataCon(..), PlainStgExpr(..), PlainStgLiveVars(..),
- PlainStgAtom(..),
- UniqSet(..), UniqFM, UpdateFlag(..) -- not abstract
-
- IF_ATTACK_PRAGMAS(COMMA mkClosureLabel)
- IF_ATTACK_PRAGMAS(COMMA getUniDataSpecTyCon_maybe)
+ dataConLiveness -- concurrency
) where
-import AbsCSyn
-import CgMonad
-import SMRep
+IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking
+#endif
+
+import AbsCSyn ( MagicId, node, mkLiveRegsMask,
+ {- GHC 0.29 only -} AbstractC, CAddrMode
+ )
import StgSyn
+import CgMonad
-import AbsUniType
-import CgCompInfo -- some magic constants
-import CgRetConv
-import CLabelInfo -- Lots of label-making things
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id
-import IdInfo -- SIGH
-import Maybes ( maybeToBool, assocMaybe, Maybe(..) )
-import Outputable -- needed for INCLUDE_FRC_METHOD
-import Pretty -- ( ppStr, Pretty(..) )
-import PrimKind ( PrimKind, getKindSize, separateByPtrFollowness )
-import Util
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+ mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
+ mAX_SPEC_ALL_NONPTRS,
+ oTHER_TAG
+ )
+import CgRetConv ( assignRegs, dataReturnConvAlg,
+ DataReturnConvention(..)
+ )
+import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
+ mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkConInfoTableLabel, mkStaticClosureLabel,
+ mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
+ mkStaticInfoTableLabel, mkStaticConEntryLabel,
+ mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
+ )
+import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
+import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
+ SYN_IE(VirtualHeapOffset), HeapOffset
+ )
+import Id ( idType, getIdArity,
+ externallyVisibleId,
+ dataConTag, fIRST_TAG,
+ isDataCon, isNullaryDataCon, dataConTyCon,
+ isTupleCon, SYN_IE(DataCon),
+ GenId{-instance Eq-}, SYN_IE(Id)
+ )
+import IdInfo ( ArityInfo(..) )
+import Maybes ( maybeToBool )
+import Name ( getOccString )
+import Outputable ( PprStyle(..), Outputable(..) )
+import PprType ( getTyDescription, GenType{-instance Outputable-} )
+import Pretty --ToDo:rm
+import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
+import SMRep -- all of it
+import TyCon ( TyCon{-instance NamedThing-} )
+import Type ( isPrimType, splitFunTyExpandingDictsAndPeeking,
+ mkFunTys, maybeAppSpecDataTyConExpandingDicts,
+ SYN_IE(Type)
+ )
+import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
\end{code}
The ``wrapper'' data type for closure information:
| LFTuple -- Tuples
DataCon -- The tuple constructor (may be specialised)
Bool -- True <=> zero arity
-
+
| LFThunk -- Thunk (zero arity)
Bool -- True <=> top level
Bool -- True <=> no free vars
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
Int -- arity;
- PlainStgLiveVars-- list of variables live in the RHS of the let.
+ StgLiveVars-- list of variables live in the RHS of the let.
-- (ToDo: maybe not used)
| LFBlackHole -- Used for the closures allocated to hold the result
= NonStandardThunk -- No, it isn't
- | SelectorThunk
+ | SelectorThunk
Id -- Scrutinee
DataCon -- Constructor
Int -- 0-origin offset of ak within the "goods" of constructor
-- (Recall that the a1,...,an may be laid out in the heap
-- in a non-obvious order.)
-
+
{- A SelectorThunk is of form
- case x of
- con a1,..,an -> ak
-
- and the constructor is from a single-constr type.
+ case x of
+ con a1,..,an -> ak
+
+ and the constructor is from a single-constr type.
If we can't convert the heap-offset of the selectee into an Int, e.g.,
it's "GEN_VHS+i", we just give up.
-}
-
+
| VapThunk
Id -- Function
- [PlainStgAtom] -- Args
- Bool -- True <=> the function is not top-level, so
+ [StgArg] -- Args
+ Bool -- True <=> the function is not top-level, so
-- must be stored in the thunk too
-
+
{- A VapThunk is of form
- f a1 ... an
+ f a1 ... an
- where f is a known function, with arity n
- So for this thunk we can use the label for f's heap-entry
- info table (generated when f's defn was dealt with),
- rather than generating a one-off info table and entry code
- for this one thunk.
+ where f is a known function, with arity n
+ So for this thunk we can use the label for f's heap-entry
+ info table (generated when f's defn was dealt with),
+ rather than generating a one-off info table and entry code
+ for this one thunk.
-}
-
+
mkLFArgument = LFArgument
mkLFBlackHole = LFBlackHole
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case arityMaybe (getIdArity id) of
- Nothing -> LFImported
- Just 0 -> LFThunk True{-top-lev-} True{-no fvs-}
- True{-updatable-} NonStandardThunk
- Just n -> LFReEntrant True n True -- n > 0
+ = case getIdArity id of
+ ArityExactly 0 -> LFThunk True{-top-lev-} True{-no fvs-}
+ True{-updatable-} NonStandardThunk
+ ArityExactly n -> LFReEntrant True n True -- n > 0
+ other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> PlainStgExpr -- Body of closure: passed so we
- -- can look for selector thunks!
-> LambdaFormInfo
-mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
+mkClosureLFInfo top fvs upd_flag args@(_:_) -- Non-empty args
= LFReEntrant top (length args) (null fvs)
-mkClosureLFInfo top fvs ReEntrant [] body
+mkClosureLFInfo top fvs ReEntrant []
= LFReEntrant top 0 (null fvs)
-\end{code}
-
-OK, this is where we look at the body of the closure to see if it's a
-selector---turgid, but nothing deep. We are looking for a closure of
-{\em exactly} the form:
-\begin{verbatim}
-... = [the_fv] \ u [] ->
- case the_fv of
- con a_1 ... a_n -> a_i
-\end{verbatim}
-Here we go:
-\begin{code}
-mkClosureLFInfo False -- don't bother if at top-level
- [the_fv] -- just one...
- Updatable
- [] -- no args (a thunk)
- (StgCase (StgApp (StgVarAtom scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
- (StgAlgAlts case_ty
- [(con, params, use_mask,
- (StgApp (StgVarAtom selectee) [{-no args-}] _))]
- StgNoDefault))
- | the_fv == scrutinee -- Scrutinee is the only free variable
- && maybeToBool maybe_offset -- Selectee is a component of the tuple
- && maybeToBool offset_into_int_maybe
- && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
- =
- -- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
- LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
- where
- (_, params_w_offsets) = layOutDynCon con getIdKind params
- maybe_offset = assocMaybe params_w_offsets selectee
- Just the_offset = maybe_offset
- offset_into_int_maybe = intOffsetIntoGoods the_offset
- Just offset_into_int = offset_into_int_maybe
- is_single_constructor = maybeToBool (maybeSingleConstructorTyCon tycon)
- (_,_,_, tycon) = getDataConSig con
-\end{code}
-
-Same kind of thing, looking for vector-apply thunks, of the form:
- x = [...] \ .. [] -> f a1 .. an
-
-where f has arity n. We rely on the arity info inside the Id being correct.
-
-\begin{code}
-mkClosureLFInfo top_level
- fvs
- upd_flag
- [] -- No args; a thunk
- (StgApp (StgVarAtom fun_id) args _)
- | not top_level -- A top-level thunk would require a static
- -- vap_info table, which we don't generate just
- -- now; so top-level thunks are never standard
- -- form.
- && isLocallyDefined fun_id -- Must be defined in this module
- && maybeToBool arity_maybe -- A known function with known arity
- && fun_arity > 0 -- It'd better be a function!
- && fun_arity == length args -- Saturated application
- = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
- where
- arity_maybe = arityMaybe (getIdArity fun_id)
- Just fun_arity = arity_maybe
-
- -- If the function is a free variable then it must be stored
- -- in the thunk too; if it isn't a free variable it must be
- -- because it's constant, so it doesn't need to be stored in the thunk
- store_fun_in_vap = fun_id `is_elem` fvs
-
- is_elem = isIn "mkClosureLFInfo"
-\end{code}
-
-Finally, the general updatable-thing case:
-\begin{code}
-mkClosureLFInfo top fvs upd_flag [] body
+mkClosureLFInfo top fvs upd_flag []
= LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
isUpdatable ReEntrant = False
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con
- = ASSERT(isDataCon con)
- let
- arity = getDataConArity con
- in
- if isTupleCon con then
- LFTuple con (arity == 0)
- else
- LFCon con (arity == 0)
+ = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
+ (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
+
+mkSelectorLFInfo scrutinee con offset
+ = LFThunk False False True (SelectorThunk scrutinee con offset)
+
+mkVapLFInfo fvs upd_flag fun_id args fun_in_vap
+ = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap)
\end{code}
@ConstantRep@ and @CharLikeRep@ closures always use the address of
a static closure. They are never allocated or
collected (eg hold forwarding pointer) hence never any slop.
-
+
\item
@IntLikeRep@ are never updatable.
May need slop to be collected (as they will be size 1 or more
\begin{code}
layOutDynClosure, layOutStaticClosure
:: Id -- STG identifier w/ which this closure assoc'd
- -> (a -> PrimKind) -- function w/ which to be able to get a PrimKind
+ -> (a -> PrimRep) -- function w/ which to be able to get a PrimRep
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
-> (ClosureInfo, -- info about the closure
A wrapper for when used with data constructors:
\begin{code}
layOutDynCon :: DataCon
- -> (a -> PrimKind)
+ -> (a -> PrimRep)
-> [a]
-> (ClosureInfo, [(a,VirtualHeapOffset)])
-layOutDynCon con kind_fn args
+layOutDynCon con kind_fn args
= ASSERT(isDataCon con)
layOutDynClosure con kind_fn args (mkConLFInfo con)
\end{code}
else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
else SpecRep
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
_ -> SpecRep
in
the result list
\begin{code}
-mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
- -> (a -> PrimKind) -- To be able to grab kinds;
- -- w/ a kind, we can find boxedness
- -> [a] -- Things to make offsets for
- -> (Int, -- *Total* number of words allocated
- Int, -- Number of words allocated for *pointers*
- [(a, VirtualHeapOffset)]) -- Things with their offsets from start of object
- -- in order of increasing offset
+mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
+ -> (a -> PrimRep) -- To be able to grab kinds;
+ -- w/ a kind, we can find boxedness
+ -> [a] -- Things to make offsets for
+ -> (Int, -- *Total* number of words allocated
+ Int, -- Number of words allocated for *pointers*
+ [(a, VirtualHeapOffset)])
+ -- Things with their offsets from start of object
+ -- in order of increasing offset
-- First in list gets lowest offset, which is initial offset + 1.
where
offset_of_first_word = totHdrSize sm_rep
computeOffset wds_so_far thing
- = (wds_so_far + (getKindSize . kind_fun) thing,
+ = (wds_so_far + (getPrimRepSize . kind_fun) thing,
(thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
)
\end{code}
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling ->
-
+ = let
+ do_profiling = opt_SccProfilingOn
+ in
case lf_info of
LFReEntrant top arity no_fvs -> returnFC (
not no_fvs || -- Certainly if it has fvs we need to point to it
-- is not top level as special case cgRhsClosure
-- has been dissabled in favour of let floating
---OLD: || (arity == 0 && do_profiling)
--- -- Access to cost centre required for 0 arity if profiling
--- -- Simon: WHY? (94/12)
-
-- For lex_profiling we also access the cost centre for a
-- non-inherited function i.e. not top level
-- the not top case above ensures this is ok.
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ no_fvs updatable _
+ LFThunk _ no_fvs updatable NonStandardThunk
-> returnFC (updatable || not no_fvs || do_profiling)
-- For the non-updatable (single-entry case):
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
+ LFThunk _ no_fvs updatable some_standard_form_thunk
+ -> returnFC True
+ -- Node must point to any standard-form thunk.
+ -- For example,
+ -- x = f y
+ -- generates a Vap thunk for (f y), and even if y is a global
+ -- variable we must still make Node point to the thunk before entering it
+ -- because that's what the standard-form code expects.
+
LFArgument -> returnFC True
LFImported -> returnFC True
LFBlackHole -> returnFC True
0 arg, fvs @\u@ & yes & yes & n/a & node\\
\end{tabular}
-When black-holing, single-entry closures could also be entered via node
+When black-holing, single-entry closures could also be entered via node
(rather than directly) to catch double-entry.
\begin{code}
= ViaNode -- The "normal" convention
| StdEntry CLabel -- Jump to this code, with args on stack
- (Maybe CLabel) -- possibly setting infoptr to this
+ (Maybe CLabel) -- possibly setting infoptr to this
| DirectEntry -- Jump directly to code, with args in regs
CLabel -- The code label
Int -- Its arity
[MagicId] -- Its register assignments (possibly empty)
-getEntryConvention :: Id -- Function being applied
- -> LambdaFormInfo -- Its info
- -> [PrimKind] -- Available arguments
+getEntryConvention :: Id -- Function being applied
+ -> LambdaFormInfo -- Its info
+ -> [PrimRep] -- Available arguments
-> FCode EntryConvention
getEntryConvention id lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ let
+ is_concurrent = opt_ForConcurrent
+ in
returnFC (
if (node_points && is_concurrent) then ViaNode else
case lf_info of
- LFReEntrant _ arity _ ->
- if arity == 0 || (length arg_kinds) < arity then
+ LFReEntrant _ arity _ ->
+ if arity == 0 || (length arg_kinds) < arity then
StdEntry (mkStdEntryLabel id) Nothing
- else
+ else
DirectEntry (mkFastEntryLabel id arity) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
+ (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
- LFCon con zero_arity
- -> let itbl = if zero_arity then
+ LFCon con zero_arity
+ -> let itbl = if zero_arity then
mkPhantomInfoTableLabel con
else
- mkInfoTableLabel con
- in StdEntry (mkStdEntryLabel con) (Just itbl)
- -- Should have no args
- LFTuple tup zero_arity
- -> StdEntry (mkStdEntryLabel tup)
- (Just (mkInfoTableLabel tup))
- -- Should have no args
+ mkConInfoTableLabel con
+ in
+ --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel con) (Just itbl)
+
+ LFTuple tup zero_arity
+ -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
LFThunk _ _ updatable std_form_info
-> if updatable
then ViaNode
else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole -> ViaNode -- Presumably the black hole has by now
+ LFArgument -> ViaNode
+ LFImported -> ViaNode
+ LFBlackHole -> ViaNode -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we enter via Node
-> ASSERT(arity == length arg_kinds)
DirectEntry (mkStdEntryLabel id) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs arg_kinds
+ (arg_regs, _) = assignRegs live_regs arg_kinds
live_regs = if node_points then [node] else []
)
-> if updatable
then not no_black_holing
else not no_fvs
- other -> panic "blackHoleOnEntry" -- Should never happen
+ other -> panic "blackHoleOnEntry" -- Should never happen
-getStandardFormThunkInfo
- :: LambdaFormInfo
- -> Maybe [PlainStgAtom] -- Nothing => not a standard-form thunk
+getStandardFormThunkInfo
+ :: LambdaFormInfo
+ -> Maybe [StgArg] -- Nothing => not a standard-form thunk
-- Just atoms => a standard-form thunk with payload atoms
getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
= --trace "Selector thunk: missed opportunity to save info table + code"
Nothing
- -- Just [StgVarAtom scrutinee]
+ -- Just [StgVarArg scrutinee]
-- We can't save the info tbl + code until we have a way to generate
-- a fixed family thereof.
getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
- | fun_in_payload = Just (StgVarAtom fun_id : args)
+ | fun_in_payload = Just (StgVarArg fun_id : args)
| otherwise = Just args
getStandardFormThunkInfo other_lf_info = Nothing
OR (b) the function is passed as an arg
OR (c) if the function has free vars (ie not top level)
- Why case (a) here? Because if the arg-satis check fails,
+ Why case (a) here? Because if the arg-satis check fails,
UpdatePAP stuffs a pointer to the function closure in the PAP.
[Could be changed; UpdatePAP could stuff in a code ptr instead,
but doesn't seem worth it.]
- [NB: these conditions imply that we might need the closure
+ [NB: these conditions imply that we might need the closure
without the slow-entry code. Here's how.
f x y = let g w = ...x..y..w...
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) the function has free vars (ie not top level)
-
+
NB. In the sequential world, (c) is only required so that the function closure has
an info table to point to, to keep the storage manager happy.
If (c) alone is true we could fake up an info table by choosing
* Single-update vap-entry code
Single-update vap-entry info table
- Needed iff we have any non-updatable thunks of the
+ Needed iff we have any non-updatable thunks of the
standard vap-entry shape.
-
+
\begin{code}
staticClosureRequired
:: Id
- -> StgBinderInfo
+ -> StgBinderInfo
-> LambdaFormInfo
-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
(LFReEntrant top_level _ _) -- It's a function
= ASSERT( top_level ) -- Assumption: it's a top-level, no-free-var binding
arg_occ -- There's an argument occurrence
slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
:: Id
-> StgBinderInfo
+ -> EntryConvention
-> Bool
-slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
= arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
|| externallyVisibleId binder
- {- HAS FREE VARS AND IS PARALLEL WORLD -}
+ || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
+ {- The last case deals with the parallel world; a function usually
+ as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
-slowFunEntryCodeRequired binder NoStgBinderInfo = True
+slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
funInfoTableRequired
:: Id
-> LambdaFormInfo
-> Bool
funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _)
+ (LFReEntrant top_level _ _)
= not top_level
|| arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
funInfoTableRequired other_binder_info binder other_lf_info = True
--- We need the vector-apply entry points for a function if
--- there's a vector-apply occurrence in this module
+-- We need the vector-apply entry points for a function if
+-- there's a vector-apply occurrence in this module
stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
_ -> False
\end{code}
+@lfArity@ extracts the arity of a function from its LFInfo
+
+\begin{code}
+{- Not needed any more
+
+lfArity_maybe (LFReEntrant _ arity _) = Just arity
+
+-- Removed SLPJ March 97. I don't believe these two;
+-- LFCon is used for construcor *applications*, not constructors!
+--
+-- lfArity_maybe (LFCon con _) = Just (dataConArity con)
+-- lfArity_maybe (LFTuple con _) = Just (dataConArity con)
+
+lfArity_maybe other = Nothing
+-}
+\end{code}
+
%************************************************************************
%* *
\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
%************************************************************************
\begin{code}
-isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
-isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
-isConstantRep other = False
-
-isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
-isSpecRep other = False -- True indicates that the _VHS is 0 !
-
-isStaticRep (StaticRep _ _) = True
-isStaticRep _ = False
-
-isPhantomRep PhantomRep = True
-isPhantomRep _ = False
-
-isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
-isIntLikeRep other = False
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
Note: @closureType@ returns appropriately specialised tycon and
datacons.
\begin{code}
-closureType :: ClosureInfo -> Maybe (TyCon, [UniType], [Id])
+closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-- First, a turgid special case. When we are generating the
-- standard code and info-table for Vaps (which is done when the function
-- rather than take it from the Id. The Id is probably just "f"!
closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
- where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+ = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id)
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (getIdUniType id)
+closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id)
\end{code}
@closureReturnsUnboxedType@ is used to check whether a closure, {\em
closureReturnsUnboxedType :: ClosureInfo -> Bool
closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
- = isPrimType (funResultTy de_foralld_ty arity)
- where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+ = isPrimType (fun_result_ty arity fun_id)
closureReturnsUnboxedType other_closure = False
-- All non-function closures aren't functions,
-- and hence are boxed, since they are heap alloc'd
+
+-- ToDo: need anything like this in Type.lhs?
+fun_result_ty arity id
+ = let
+ (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id)
+ in
+-- ASSERT(arity >= 0 && length arg_tys >= arity)
+ (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (hsep [int arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
+ mkFunTys (drop arity arg_tys) res_ty
\end{code}
\begin{code}
closureSemiTag (MkClosureInfo _ lf_info _)
= case lf_info of
- LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
+ LFCon data_con _ -> dataConTag data_con - fIRST_TAG
LFTuple _ _ -> 0
- --UNUSED: LFIndirection -> fromInteger iND_TAG
_ -> fromInteger oTHER_TAG
\end{code}
+\begin{code}
+isToplevClosure :: ClosureInfo -> Bool
+
+isToplevClosure (MkClosureInfo _ lf_info _)
+ = case lf_info of
+ LFReEntrant top _ _ -> top
+ LFThunk top _ _ _ -> top
+ _ -> panic "ClosureInfo:isToplevClosure"
+\end{code}
+
Label generation.
\begin{code}
-infoTableLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI (MkClosureInfo id lf_info _)
+{- [SLPJ Changed March 97]
+ (was ok, but is the only call to lfArity,
+ and the id should guarantee to have the correct arity in it.
+ = case lfArity_maybe lf_info of
+ Just arity ->
+-}
+ = case getIdArity id of
+ ArityExactly arity -> mkFastEntryLabel id arity
+ other -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
+
+infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
LFCon con _ -> mkConInfoPtr con rep
LFBlackHole -> mkBlackHoleInfoTableLabel
LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
- -- Use the standard vap info table
+ -- Use the standard vap info table
-- for the function, rather than a one-off one
-- for this particular closure
else -} mkInfoTableLabel id
mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel id
- StaticRep _ _ -> mkStaticInfoTableLabel id
- _ -> mkInfoTableLabel id
+mkConInfoPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ PhantomRep -> mkPhantomInfoTableLabel con
+ StaticRep _ _ -> mkStaticInfoTableLabel con
+ _ -> mkConInfoTableLabel con
mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel id
- _ -> mkConEntryLabel id
+mkConEntryPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ StaticRep _ _ -> mkStaticConEntryLabel con
+ _ -> mkConEntryLabel con
-closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
+closureLabelFromCI (MkClosureInfo id _ rep)
+ | isConstantRep rep
+ = mkStaticClosureLabel id
+ -- This case catches those pesky static closures for nullary constructors
+
+closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
-- I don't think it needs to deal with the SelectorThunk case
-- Well, it's falling over now, so I've made it deal with it. (JSM)
-thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
+thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
= mkVapEntryLabel fun_id is_updatable
-thunkEntryLabel thunk_id _ is_updatable
+thunkEntryLabel thunk_id _ is_updatable
= mkStdEntryLabel thunk_id
-
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
- where
- arity_maybe = arityMaybe (getIdArity id)
- fun_arity = case arity_maybe of
- Just x -> x
- _ -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
\end{code}
\begin{code}
LFTuple _ _ -> SLIT("ALLOC_CON")
LFThunk _ _ _ _ -> SLIT("ALLOC_THK")
LFBlackHole -> SLIT("ALLOC_BH")
- --UNUSED: LFIndirection -> panic "ALLOC_IND"
LFImported -> panic "ALLOC_IMP"
\end{code}
-We need a black-hole closure info to pass to @allocDynClosure@
-when we want to allocate the black hole on entry to a CAF.
+We need a black-hole closure info to pass to @allocDynClosure@ when we
+want to allocate the black hole on entry to a CAF.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _) = MkClosureInfo id LFBlackHole BlackHoleRep
+blackHoleClosureInfo (MkClosureInfo id _ _)
+ = MkClosureInfo id LFBlackHole BlackHoleRep
\end{code}
-The register liveness when returning from a constructor. For simplicity,
-we claim just [node] is live for all but PhantomRep's. In truth, this means
-that non-constructor info tables also claim node, but since their liveness
-information is never used, we don't care.
+The register liveness when returning from a constructor. For
+simplicity, we claim just [node] is live for all but PhantomRep's. In
+truth, this means that non-constructor info tables also claim node,
+but since their liveness information is never used, we don't care.
\begin{code}
-
-dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs regs -> mkLiveRegsBitMask regs
+dataConLiveness (MkClosureInfo con _ PhantomRep)
+ = case (dataReturnConvAlg con) of
+ ReturnInRegs regs -> mkLiveRegsMask regs
ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-dataConLiveness _ _ = mkLiveRegsBitMask [node]
+dataConLiveness _ = mkLiveRegsMask [node]
\end{code}
%************************************************************************
LFTuple _ _ -> "CON_K"
LFThunk _ _ _ _ -> "THK_K"
LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
- --UNUSED: LFIndirection -> panic "IND_KIND"
LFImported -> panic "IMP_KIND"
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the ->
+ = if (isDataCon id) then -- DataCon has function types
+ getOccString (dataConTyCon id) -- We want the TyCon not the ->
else
- getUniTyDescription (getIdUniType id)
+ getTyDescription (idType id)
\end{code}
-
projects / ghc-hetmet.git / blobdiff