layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
+ isToplevClosure,
closureKind, closureTypeDescr, -- profiling
isStaticClosure, allocProfilingMsg,
dataConLiveness -- concurrency
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking
import AbsCSyn
import StgSyn
)
import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkConInfoTableLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
intOffsetIntoGoods,
- VirtualHeapOffset(..)
+ SYN_IE(VirtualHeapOffset)
)
import Id ( idType, idPrimRep, getIdArity,
- externallyVisibleId, dataConSig,
+ externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, dataConArity, dataConTyCon,
- isTupleCon, DataCon(..),
+ isDataCon, isNullaryDataCon, dataConTyCon,
+ isTupleCon, SYN_IE(DataCon),
GenId{-instance Eq-}
)
import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
-import Name ( isLocallyDefined, getLocalName )
+import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
+import PprType ( getTyDescription, GenType{-instance Outputable-} )
+--import Pretty--ToDo:rm
+import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
import SMRep -- all of it
import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
+import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
+ mkFunTys, maybeAppSpecDataTyConExpandingDicts
+ )
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:
offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- (_,_,_, tycon) = dataConSig con
+ tycon = dataConTyCon con
\end{code}
Same kind of thing, looking for vector-apply thunks, of the form:
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)
\end{code}
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
-- 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
fun_result_ty arity id
= let
(_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty
+ (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking de_foralld_ty
in
ASSERT(arity >= 0 && length arg_tys >= arity)
+-- (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt 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}
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
arity_maybe = arityMaybe (getIdArity id)
fun_arity = case arity_maybe of
Just x -> x
- _ -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
+ _ -> panic "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
+ _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the ->
else
getTyDescription (idType id)
\end{code}
projects / ghc-hetmet.git / blobdiff