EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
mkLFImported, mkLFArgument, mkLFLetNoEscape,
closureSize, closureHdrSize,
slowFunEntryCodeRequired, funInfoTableRequired,
stdVapRequired, noUpdVapRequired,
- closureId, infoTableLabelFromCI,
+ closureId, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
+ isToplevClosure,
closureKind, closureTypeDescr, -- profiling
isStaticClosure, allocProfilingMsg,
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 CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
- mkConInfoTableLabel,
+ 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,
+import Id ( idType, getIdArity,
externallyVisibleId,
dataConTag, fIRST_TAG,
isDataCon, isNullaryDataCon, dataConTyCon,
- isTupleCon, DataCon(..),
- GenId{-instance Eq-}
+ 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 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 )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
-import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDicts,
- mkFunTys, maybeAppSpecDataTyConExpandingDicts
+import TyCon ( TyCon{-instance NamedThing-} )
+import Type ( isPrimType, splitFunTyExpandingDictsAndPeeking,
+ mkFunTys, maybeAppSpecDataTyConExpandingDicts,
+ SYN_IE(Type)
)
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
-
-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 = dataConTyCon 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 con
= -- 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}
_ -> 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.}
-- ToDo: need anything like this in Type.lhs?
fun_result_ty arity id
= let
- (_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTyExpandingDicts 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
_ -> 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)
= 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}