EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ UpdateFlag,
closureSize, closureHdrSize,
closureNonHdrSize, closureSizeWithoutFixedHdr,
layOutStaticNoFVClosure, layOutPhantomClosure,
mkVirtHeapOffsets,
- nodeMustPointToIt, getEntryConvention,
+ nodeMustPointToIt, getEntryConvention,
+ SYN_IE(FCode), CgInfoDownwards, CgState,
+
blackHoleOnEntry,
staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
stdVapRequired, noUpdVapRequired,
+ StgBinderInfo,
- closureId, infoTableLabelFromCI,
+ closureId, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
+ GenStgArg,
+ isToplevClosure,
closureKind, closureTypeDescr, -- profiling
isStaticClosure, allocProfilingMsg,
dataConLiveness -- concurrency
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking
+#endif
-import AbsCSyn
+import AbsCSyn ( MagicId, node, mkLiveRegsMask,
+ {- GHC 0.29 only -} AbstractC, CAddrMode
+ )
import StgSyn
import CgMonad
-import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE,
- mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+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 ( mkStdEntryLabel, mkFastEntryLabel,
+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,
- intOffsetIntoGoods,
- VirtualHeapOffset(..)
+ SYN_IE(VirtualHeapOffset), HeapOffset
)
-import Id ( idType, idPrimRep, getIdArity,
- externallyVisibleId, dataConSig,
+import Id ( idType, getIdArity,
+ externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, dataConArity, dataConTyCon,
- isTupleCon, DataCon(..),
- GenId{-instance Eq-}
+ isDataCon, isNullaryDataCon, dataConTyCon,
+ isTupleCon, SYN_IE(DataCon),
+ GenId{-instance Eq-}, SYN_IE(Id)
)
-import IdInfo ( arityMaybe )
-import Maybes ( assocMaybe, maybeToBool )
-import Name ( isLocallyDefined, getLocalName )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness )
+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 ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type ( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
+import TyCon ( TyCon{-instance NamedThing-} )
+import Type ( isPrimType, splitFunTyExpandingDictsAndPeeking,
+ mkFunTys, maybeAppSpecDataTyConExpandingDicts,
+ SYN_IE(Type)
+ )
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
-
-maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
-maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
-getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
-getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code}
The ``wrapper'' data type for closure information:
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
- -> StgExpr -- 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 (StgVarArg scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
- (StgAlgAlts case_ty
- [(con, params, use_mask,
- (StgApp (StgVarArg 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 idPrimRep 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 (maybeTyConSingleCon tycon)
- (_,_,_, tycon) = dataConSig 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 (StgVarArg 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 = dataConArity 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}
-- 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
Int -- Its arity
[MagicId] -- Its register assignments (possibly empty)
-getEntryConvention :: Id -- Function being applied
- -> LambdaFormInfo -- Its info
+getEntryConvention :: Id -- Function being applied
+ -> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
-> FCode EntryConvention
-> let itbl = if zero_arity then
mkPhantomInfoTableLabel con
else
- mkInfoTableLabel con
- in StdEntry (mkStdEntryLabel con) (Just itbl)
- -- 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
- -> StdEntry (mkStdEntryLabel tup)
- (Just (mkInfoTableLabel tup))
- -- Should have no args
+ -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
LFThunk _ _ updatable std_form_info
-> if updatable
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
_ -> 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.}
-- rather than take it from the Id. The Id is probably just "f"!
closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
+ = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id)
-closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
+closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id)
\end{code}
@closureReturnsUnboxedType@ is used to check whether a closure, {\em
-- ToDo: need anything like this in Type.lhs?
fun_result_ty arity id
= let
- (_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTyWithDictsAsArgs de_foralld_ty
+ (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id)
in
- ASSERT(arity >= 0 && length arg_tys >= arity)
+-- 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}
_ -> 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
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 _ rep)
+ | isConstantRep rep
+ = mkStaticClosureLabel id
+ -- This case catches those pesky static closures for nullary constructors
-closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
+closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
= mkVapEntryLabel fun_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}
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getLocalName (dataConTyCon 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
getTyDescription (idType id)
\end{code}
projects / ghc-hetmet.git / blobdiff