#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
+#define ASSERTM(e) ASSERT(e) do
#else
#define ASSERT(e)
#define ASSERT2(e,msg)
+#define ASSERTM(e)
#define WARN(e,msg)
#endif
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.50 2002/09/13 15:02:25 simonpj Exp $
+% $Id: AbsCSyn.lhs,v 1.51 2002/12/11 15:36:21 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
-- *** the next three [or so...] are DATA (those above are CODE) ***
| CStaticClosure
+ CLabel -- The closure's label
ClosureInfo -- Todo: maybe info_lbl & closure_lbl instead?
CAddrMode -- cost centre identifier to place in closure
[CAddrMode] -- free vars; ptrs, then non-ptrs.
| CSRT CLabel [CLabel] -- SRT declarations: basically an array of
-- pointers to static closures.
- | CBitmap CLabel LivenessMask -- A bitmap to be emitted if and only if
+ | CBitmap Liveness -- A bitmap to be emitted if and only if
-- it is larger than a target machine word.
| CClosureInfoAndCode
ClosureInfo -- Explains placement and layout of closure
- AbstractC -- Slow entry point code
- (Maybe AbstractC)
- -- Fast entry point code, if any
- String -- Closure description; NB we can't get this
- -- from ClosureInfo, because the latter refers
- -- to the *right* hand side of a defn, whereas
- -- the "description" refers to *left* hand side
+ AbstractC -- Entry point code
| CRetVector -- A labelled block of static data
CLabel
overflow. This enumeration type lists all such macros:
\begin{code}
data CStmtMacro
- = ARGS_CHK -- arg satisfaction check
- | ARGS_CHK_LOAD_NODE -- arg check for top-level functions
- | UPD_CAF -- update CAF closure with indirection
+ = UPD_CAF -- update CAF closure with indirection
| UPD_BH_UPDATABLE -- eager backholing
| UPD_BH_SINGLE_ENTRY -- more eager blackholing
| PUSH_UPD_FRAME -- push update frame
- | PUSH_SEQ_FRAME -- push seq frame
- | UPDATE_SU_FROM_UPD_FRAME -- pull Su out of the update frame
| SET_TAG -- set TagReg if it exists
-- dataToTag# primop -- *only* used in unregisterised builds.
-- (see AbsCUtils.dsCOpStmt)
= HP_CHK_NP -- heap/stack checks when
| STK_CHK_NP -- node points to the closure
| HP_STK_CHK_NP
- | HP_CHK_SEQ_NP -- for 'seq' style case alternatives
- | HP_CHK -- heap/stack checks when
- | STK_CHK -- node doesn't point
- | HP_STK_CHK
+ | HP_CHK_FUN -- heap/stack checks when
+ | STK_CHK_FUN -- node doesn't point
+ | HP_STK_CHK_FUN
-- case alternative heap checks:
| HP_CHK_NOREGS -- no registers live
| HP_CHK_F1 -- FloatReg1 (only) is live
| HP_CHK_D1 -- DblReg1 (only) is live
| HP_CHK_L1 -- LngReg1 (only) is live
- | HP_CHK_UT_ALT -- unboxed tuple return.
- | HP_CHK_GEN -- generic heap check
+ | HP_CHK_UNBX_TUPLE -- unboxed tuple heap check
\end{code}
\item[@CCallProfCtrMacro@:]
\begin{code}
type LivenessMask = [BitSet]
-data Liveness = Liveness CLabel LivenessMask
+data Liveness = Liveness CLabel !Int LivenessMask
\end{code}
%************************************************************************
-- STG registers
| Sp -- Stack ptr; points to last occupied stack location.
- | Su -- Stack update frame pointer
| SpLim -- Stack limit
| Hp -- Heap ptr; points to last occupied heap location.
| HpLim -- Heap limit register
where
tag BaseReg = (_ILIT(0) :: FastInt)
tag Sp = _ILIT(1)
- tag Su = _ILIT(2)
tag SpLim = _ILIT(3)
tag Hp = _ILIT(4)
tag HpLim = _ILIT(5)
magicIdPrimRep (DoubleReg _) = DoubleRep
magicIdPrimRep (LongReg kind _) = kind
magicIdPrimRep Sp = PtrRep
-magicIdPrimRep Su = PtrRep
magicIdPrimRep SpLim = PtrRep
magicIdPrimRep Hp = PtrRep
magicIdPrimRep HpLim = PtrRep
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
-flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
- = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
- flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
- CClosureInfoAndCode cl_info slow_heres fast_heres descr]
+flatAbsC (CClosureInfoAndCode cl_info entry)
+ = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) ->
+ returnFlt (AbsCNop, mkAbstractCs [entry_tops,
+ CClosureInfoAndCode cl_info entry_heres]
)
flatAbsC (CCodeBlock lbl abs_C)
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
-flatAbsC stmt@(CStaticClosure _ _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-% $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $
+% (c) The University of Glasgow, 1992-2002
%
\section[CLabel]{@CLabel@: Information to make C Labels}
mkClosureLabel,
mkSRTLabel,
mkInfoTableLabel,
- mkStdEntryLabel,
- mkFastEntryLabel,
+ mkEntryLabel,
+ mkSlowEntryLabel,
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
mkSelectorInfoLabel,
mkSelectorEntryLabel,
+ mkRtsApplyInfoLabel,
+ mkRtsApplyEntryLabel,
+
mkForeignLabel,
mkCC_Label, mkCCS_Label,
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
-
| SRT -- Static reference table
-
- | InfoTbl -- Info table for a closure; always read-only
-
- | EntryStd -- Thunk, or "slow", code entry point
-
- | EntryFast Int -- entry pt when no arg satisfaction chk needed;
- -- Int is the arity of the function (to be
- -- encoded into the name)
+ | InfoTbl -- Info tables for closures; always read-only
+ | Entry -- entry point
+ | Slow -- slow entry point
-- Ticky-ticky counting
| RednCounts -- Label of place to keep reduction-count info for
-- this Id
+
+ | Bitmap -- A bitmap (function or case return)
+
deriving (Eq, Ord)
data DataConLabelInfo
| CaseVecTbl
| CaseAlt ConTag
| CaseDefault
- | CaseBitmap
deriving (Eq, Ord)
data RtsLabelInfo
= RtsShouldNeverHappenCode
- | RtsBlackHoleInfoTbl FastString -- black hole with info table name
+ | RtsBlackHoleInfoTbl LitString -- black hole with info table name
| RtsUpdInfo -- upd_frame_info
| RtsSeqInfo -- seq_frame_info
| RtsModuleRegd
+ | RtsApplyInfoLabel LitString
+ | RtsApplyEntryLabel LitString
+
deriving (Eq, Ord)
-- Label Type: for generating C declarations.
data CLabelType
- = InfoTblType
+ = RetInfoTblType
+ | InfoTblType
| ClosureType
| VecTblType
| ClosureTblType
\begin{code}
mkClosureLabel id = IdLabel id Closure
mkSRTLabel id = IdLabel id SRT
-mkInfoTableLabel id = IdLabel id InfoTbl
-mkStdEntryLabel id = IdLabel id EntryStd
-mkFastEntryLabel id arity = ASSERT(arity > 0)
- IdLabel id (EntryFast arity)
-
+mkInfoTableLabel id = IdLabel id InfoTbl
+mkEntryLabel id = IdLabel id Entry
+mkSlowEntryLabel id = IdLabel id Slow
+mkBitmapLabel id = IdLabel id Bitmap
mkRednCountsLabel id = IdLabel id RednCounts
mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl
mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
mkDefaultLabel uniq = CaseLabel uniq CaseDefault
-mkBitmapLabel uniq = CaseLabel uniq CaseBitmap
+
mkClosureTblLabel tycon = TyConLabel tycon
mkEMPTY_MVAR_infoLabel = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info")
mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
-mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_BLACKHOLE_info"))
-mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_CAF_BLACKHOLE_info"))
+mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
+mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
- RtsLabel (RtsBlackHoleInfoTbl FSLIT("stg_SE_CAF_BLACKHOLE_info"))
+ RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info"))
else -- RTS won't have info table unless -ticky is on
panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
mkCC_Label cc = CC_Label cc
mkCCS_Label ccs = CCS_Label ccs
+
+-- Std RTS application routines
+
+mkRtsApplyInfoLabel = RtsLabel . RtsApplyInfoLabel
+mkRtsApplyEntryLabel = RtsLabel . RtsApplyEntryLabel
\end{code}
\begin{code}
let-no-escapes, which can be recursive.
\begin{code}
+ -- don't bother declaring SRT & Bitmap labels, we always make sure
+ -- they are defined before use.
+needsCDecl (IdLabel _ SRT) = False
+needsCDecl (IdLabel _ Bitmap) = False
needsCDecl (IdLabel _ _) = True
needsCDecl (CaseLabel _ CaseReturnPt) = True
needsCDecl (DataConLabel _ _) = True
externallyVisibleCLabel (CCS_Label _) = False -- not strictly true
\end{code}
-For generating correct types in label declarations...
+For generating correct types in label declarations, and also for
+deciding whether the C compiler would like us to use '&' before the
+label to get its address:
\begin{code}
labelType :: CLabel -> CLabelType
labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType
labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
-labelType (RtsLabel RtsUpdInfo) = InfoTblType
+labelType (RtsLabel RtsUpdInfo) = RetInfoTblType
+labelType (RtsLabel RtsSeqInfo) = RetInfoTblType
+labelType (RtsLabel RtsTopTickyCtr) = CodeType -- XXX
labelType (RtsLabel (Rts_Info _)) = InfoTblType
-labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
+labelType (RtsLabel (RtsApplyInfoLabel _)) = RetInfoTblType
+labelType (RtsLabel (RtsApplyEntryLabel _)) = CodeType
+labelType (CaseLabel _ CaseReturnInfo) = RetInfoTblType
labelType (CaseLabel _ CaseReturnPt) = CodeType
labelType (CaseLabel _ CaseVecTbl) = VecTblType
labelType (TyConLabel _) = ClosureTblType
labelType (ModuleInitLabel _ _) = CodeType
labelType (PlainModuleInitLabel _) = CodeType
+labelType (CC_Label _) = CodeType -- hack
+labelType (CCS_Label _) = CodeType -- hack
labelType (IdLabel _ info) =
case info of
- InfoTbl -> InfoTblType
- Closure -> ClosureType
- _ -> CodeType
+ InfoTbl -> InfoTblType
+ Closure -> ClosureType
+ Bitmap -> DataType
+ _ -> CodeType
labelType (DataConLabel _ info) =
case info of
info Info table
srt Static reference table
entry Entry code
+ slow Slow entry code (if any)
ret Direct return address
vtbl Vector table
<n>_alt Case alternative (tag n)
= hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
-pprCLbl (CaseLabel u CaseBitmap)
- = hcat [pprUnique u, pp_cSEP, ptext SLIT("btm")]
pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
-- used to be stg_error_entry but Windows can't have DLL entry points as static
pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
-pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ftext info
+pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
= hcat [ptext SLIT("stg_sel_"), text (show offset),
else SLIT("_noupd_entry"))
]
+pprCLbl (RtsLabel (RtsApplyInfoLabel fs))
+ = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsApplyEntryLabel fs))
+ = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_ret")
+
pprCLbl (RtsLabel (RtsPrimOp primop))
= ppr primop <> ptext SLIT("_fast")
(case x of
Closure -> ptext SLIT("closure")
SRT -> ptext SLIT("srt")
- InfoTbl -> ptext SLIT("info")
- EntryStd -> ptext SLIT("entry")
- EntryFast arity -> --false:ASSERT (arity > 0)
- (<>) (ptext SLIT("fast")) (int arity)
+ InfoTbl -> ptext SLIT("info")
+ Entry -> ptext SLIT("entry")
+ Slow -> ptext SLIT("slow")
RednCounts -> ptext SLIT("ct")
+ Bitmap -> ptext SLIT("btm")
)
ppConFlavor x = pp_cSEP <>
StaticInfoTbl -> ptext SLIT("static_info")
)
\end{code}
-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: Costs.lhs,v 1.31 2002/01/02 12:32:19 simonmar Exp $
+% $Id: Costs.lhs,v 1.32 2002/12/11 15:36:22 simonmar Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
CCallTypedef _ _ _ _ _ -> nullCosts
- CStaticClosure _ _ _ -> nullCosts
+ CStaticClosure _ _ _ _ -> nullCosts
CSRT _ _ -> nullCosts
- CBitmap _ _ -> nullCosts
+ CBitmap _ -> nullCosts
- CClosureInfoAndCode _ _ _ _ -> nullCosts
+ CClosureInfoAndCode _ _ -> nullCosts
CRetVector _ _ _ _ -> nullCosts
stmtMacroCosts macro modes =
case macro of
- ARGS_CHK_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- -- p=probability of PAP (instead of AP): + p*(3,1,0,0,0)
- ARGS_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- Updates.h -}
- PUSH_SEQ_FRAME -> Cost (2, 0, 0, 3, 0) {- StgMacros.h !-}
- UPDATE_SU_FROM_UPD_FRAME -> Cost (1, 0, 1, 0, 0) {- StgMacros.h !-}
SET_TAG -> nullCosts {- COptRegs.lh -}
GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
playThreadSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
- needsCDecl, pprCLabel,
+ needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
- mkClosureLabel, mkErrorStdEntryLabel,
CLabel, CLabelType(..), labelType, labelDynamic
)
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( pprStringInCStyle, pprCLabelString )
+import CStrings ( pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
-import Maybes ( maybeToBool, catMaybes )
+import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
-import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
import BitSet ( BitSet, intBS )
import Outputable
import FastString
-import Util ( lengthExceeds, listLengthCmp )
+import Util ( lengthExceeds )
+import Constants ( wORD_SIZE )
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
#endif
+#ifdef DEBUG
+import Util ( listLengthCmp )
+#endif
+
+import Maybe ( isJust )
import GLAEXTS
import MONAD_ST
else
do_if_stmt discrim tag2 alt_code2 alt_code1 c
where
- empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
+ empty_deflt = not (isJust (nonemptyAbsC deflt))
pprAbsC (CSwitch discrim alts deflt) c -- general case
| isFloatingRep (getAmodeRep discrim)
<> ptext SLIT("};")
}
-pprAbsC stmt@(CBitmap lbl mask) c
- = pp_bitmap_switch mask semi $
+pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
+ = pp_liveness_switch liveness semi $
hcat [ ptext SLIT("BITMAP"), lparen,
pprCLabel lbl, comma,
- int (length mask), comma,
+ int size, comma,
pp_bitmap mask, rparen ]
pprAbsC (CSimultaneous abs_c) c
in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
pprAbsC (CCodeBlock lbl abs_C) _
- = if not (maybeToBool(nonemptyAbsC abs_C)) then
+ = if not (isJust(nonemptyAbsC abs_C)) then
pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
pp_exts,
hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
- else "IFN_("),
+ else "IF_("),
pprCLabel lbl, text ") {"],
pp_temps,
info_lbl = infoTableLabelFromCI cl_info
-pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _
+pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
pp_exts,
ptext SLIT("};") ]
}
where
- closure_lbl = closureLabelFromCI cl_info
info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
where
rep = getAmodeRep item
-
-pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
- = vcat [
- hcat [
- ptext SLIT("INFO_TABLE"),
- ( if is_selector then
- ptext SLIT("_SELECTOR")
- else if is_constr then
- ptext SLIT("_CONSTR")
- else if needs_srt then
- ptext SLIT("_SRT")
- else empty ), char '(',
-
- pprCLabel info_lbl, comma,
- pprCLabel slow_lbl, comma,
- pp_rest, {- ptrs,nptrs,[srt,]type,-} comma,
-
- ppLocalness info_lbl, comma,
- ppLocalnessMacro True{-include dyn-} slow_lbl, comma,
-
- if_profiling pp_descr, comma,
- if_profiling pp_type,
- text ");"
- ],
- pp_slow,
- case maybe_fast of
- Nothing -> empty
- Just fast -> let stuff = CCodeBlock fast_lbl fast in
- pprAbsC stuff (costs stuff)
- ]
+pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
+ = pprInfoTable info_lbl (mkInfoTable cl_info)
+ $$ let stuff = CCodeBlock entry_lbl entry in
+ pprAbsC stuff (costs stuff)
where
- info_lbl = infoTableLabelFromCI cl_info
- fast_lbl = fastLabelFromCI cl_info
-
- (slow_lbl, pp_slow)
- = case (nonemptyAbsC slow) of
- Nothing -> (mkErrorStdEntryLabel, empty)
- Just xx -> (entryLabelFromCI cl_info,
- let stuff = CCodeBlock slow_lbl xx in
- pprAbsC stuff (costs stuff))
-
- maybe_selector = maybeSelectorInfo cl_info
- is_selector = maybeToBool maybe_selector
- (Just select_word_i) = maybe_selector
-
- maybe_tag = closureSemiTag cl_info
- is_constr = maybeToBool maybe_tag
- (Just tag) = maybe_tag
-
- srt = closureSRT cl_info
- needs_srt = case srt of
- NoC_SRT -> False
- other -> True
-
-
- size = closureNonHdrSize cl_info
-
- ptrs = closurePtrsSize cl_info
- nptrs = size - ptrs
-
- pp_rest | is_selector = int select_word_i
- | otherwise = hcat [
- int ptrs, comma,
- int nptrs, comma,
- if is_constr then
- hcat [ int tag, comma ]
- else if needs_srt then
- pp_srt_info srt
- else empty,
- type_str ]
-
- type_str = pprSMRep (closureSMRep cl_info)
-
- pp_descr = pprStringInCStyle cl_descr
- pp_type = pprStringInCStyle (closureTypeDescr cl_info)
+ entry_lbl = entryLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
pprAbsC stmt@(CClosureTbl tycon) _
= vcat (
) $$ ptext SLIT("};")
pprAbsC stmt@(CRetDirect uniq code srt liveness) _
- = vcat [
- hcat [
- ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen,
- pprCLabel info_lbl, comma,
- pprCLabel entry_lbl, comma,
- pp_liveness liveness, comma, -- bitmap
- pp_srt_info srt, -- SRT
- closure_type, comma, -- closure type
- ppLocalness info_lbl, comma, -- info table storage class
- ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class
- int 0, comma,
- int 0, text ");"
- ],
- pp_code
- ]
+ = pprInfoTable info_lbl (mkRetInfoTable entry_lbl srt liveness)
+ $$ let stuff = CCodeBlock entry_lbl code in
+ pprAbsC stuff (costs stuff)
where
- info_lbl = mkReturnInfoLabel uniq
- entry_lbl = mkReturnPtLabel uniq
-
- pp_code = let stuff = CCodeBlock entry_lbl code in
- pprAbsC stuff (costs stuff)
-
- closure_type = pp_liveness_switch liveness
- (ptext SLIT("RET_SMALL"))
- (ptext SLIT("RET_BIG"))
+ info_lbl = mkReturnInfoLabel uniq
+ entry_lbl = mkReturnPtLabel uniq
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [
- ptext SLIT("VEC_INFO_") <> int size,
- lparen,
- pprCLabel lbl, comma,
- pp_liveness liveness, comma, -- bitmap liveness mask
- pp_srt_info srt, -- SRT
- closure_type, comma,
- ppLocalness lbl, comma
- ],
- nest 2 (sep (punctuate comma (map ppr_item amodes))),
- text ");"
- ]
- }
-
- where
- ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
- size = length amodes
-
- closure_type = pp_liveness_switch liveness
- (ptext SLIT("RET_VEC_SMALL"))
- (ptext SLIT("RET_VEC_BIG"))
-
+ = pprInfoTable lbl (mkVecInfoTable amodes srt liveness)
pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
= vcat [
pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
+Info tables... just arrays of words (the translation is done in
+ClosureInfo).
+
+\begin{code}
+pprInfoTable info_lbl amodes
+ = (case snd (initTE (ppr_decls_Amodes amodes)) of
+ Just pp -> pp
+ Nothing -> empty)
+ $$ hcat [ ppLocalness info_lbl, ptext SLIT("StgWord "),
+ pprCLabel info_lbl, ptext SLIT("[] = {") ]
+ $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
+ $$ ptext SLIT("};")
+
+castToWord s = text "(W_)(" <> s <> char ')'
+\end{code}
+
\begin{code}
-- Print a CMachOp in a way suitable for emitting via C.
pprMachOp_for_C MO_Nat_Add = char '+'
visiblity_prefix,
dyn_prefix,
case label_type of
- ClosureType -> ptext SLIT("C_")
- CodeType -> ptext SLIT("F_")
- InfoTblType -> ptext SLIT("I_")
- ClosureTblType -> ptext SLIT("CP_")
- DataType -> ptext SLIT("D_")
+ ClosureType -> ptext SLIT("C_")
+ CodeType -> ptext SLIT("F_")
+ InfoTblType -> ptext SLIT("I_")
+ RetInfoTblType -> ptext SLIT("RI_")
+ ClosureTblType -> ptext SLIT("CP_")
+ DataType -> ptext SLIT("D_")
]
where
is_visible = externallyVisibleCLabel clabel
(($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
--- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and
+-- pp_basic_{saves,restores}: The BaseReg, Sp, Hp and
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- depending on the platform. (The "volatile regs" stuff handles all
-- other registers.) Just be *sure* BaseReg is OK before trying to do
\end{code}
\begin{code}
-pp_srt_info NoC_SRT = hcat [ int 0, comma,
- int 0, comma,
- int 0, comma ]
-pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma,
- int off, comma,
- int len, comma ]
-\end{code}
-
-\begin{code}
pp_closure_lbl lbl
| labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
| otherwise = char '&' <> pprCLabel lbl
ppr_amode (CAddr reg_rel)
= case (pprRegRelative True{-sign wanted-} reg_rel) of
(pp_reg, Nothing) -> pp_reg
- (pp_reg, Just offset) -> (<>) pp_reg offset
+ (pp_reg, Just offset) -> pp_reg <> offset
ppr_amode (CReg magic_id) = pprMagicId magic_id
cExprMacroText PTRS_ARR_CTS = SLIT("PTRS_ARR_CTS")
cExprMacroText ForeignObj_CLOSURE_DATA = SLIT("ForeignObj_CLOSURE_DATA")
-cStmtMacroText ARGS_CHK = SLIT("ARGS_CHK")
-cStmtMacroText ARGS_CHK_LOAD_NODE = SLIT("ARGS_CHK_LOAD_NODE")
cStmtMacroText UPD_CAF = SLIT("UPD_CAF")
cStmtMacroText UPD_BH_UPDATABLE = SLIT("UPD_BH_UPDATABLE")
cStmtMacroText UPD_BH_SINGLE_ENTRY = SLIT("UPD_BH_SINGLE_ENTRY")
cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME")
-cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
-cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh")
cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
cCheckMacroText HP_CHK_NP = SLIT("HP_CHK_NP")
cCheckMacroText STK_CHK_NP = SLIT("STK_CHK_NP")
cCheckMacroText HP_STK_CHK_NP = SLIT("HP_STK_CHK_NP")
-cCheckMacroText HP_CHK_SEQ_NP = SLIT("HP_CHK_SEQ_NP")
-cCheckMacroText HP_CHK = SLIT("HP_CHK")
-cCheckMacroText STK_CHK = SLIT("STK_CHK")
-cCheckMacroText HP_STK_CHK = SLIT("HP_STK_CHK")
+cCheckMacroText HP_CHK_FUN = SLIT("HP_CHK_FUN")
+cCheckMacroText STK_CHK_FUN = SLIT("STK_CHK_FUN")
+cCheckMacroText HP_STK_CHK_FUN = SLIT("HP_STK_CHK_FUN")
cCheckMacroText HP_CHK_NOREGS = SLIT("HP_CHK_NOREGS")
cCheckMacroText HP_CHK_UNPT_R1 = SLIT("HP_CHK_UNPT_R1")
cCheckMacroText HP_CHK_UNBX_R1 = SLIT("HP_CHK_UNBX_R1")
cCheckMacroText HP_CHK_F1 = SLIT("HP_CHK_F1")
cCheckMacroText HP_CHK_D1 = SLIT("HP_CHK_D1")
cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1")
-cCheckMacroText HP_CHK_UT_ALT = SLIT("HP_CHK_UT_ALT")
-cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN")
+cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE")
\end{code}
\begin{code}
%************************************************************************
\begin{code}
-pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc
-pp_bitmap_switch ([ ]) small large = small
-pp_bitmap_switch ([_ ]) small large = small
-pp_bitmap_switch ([_,_]) small large = hcat
- [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen]
-pp_bitmap_switch (_ ) small large = large
+pp_bitmap_switch :: Int -> SDoc -> SDoc -> SDoc
+pp_bitmap_switch size small large
+ | size <= mAX_SMALL_BITMAP_SIZE = small
+ | otherwise = large
+
+-- magic numbers, must agree with BITMAP_BITS_SHIFT in InfoTables.h
+mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27
+ | otherwise = 58
pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc
-pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask
+pp_liveness_switch (Liveness _ size _) = pp_bitmap_switch size
pp_bitset :: BitSet -> SDoc
pp_bitset s
pp_bitmap :: [BitSet] -> SDoc
pp_bitmap [] = int 0
-pp_bitmap ss = hcat (punctuate delayed_comma (bundle ss)) where
- delayed_comma = hcat [space, ptext SLIT("COMMA"), space]
+pp_bitmap ss = hcat (punctuate (ptext SLIT(" COMMA ")) (bundle ss)) where
bundle [] = []
bundle [s] = [hcat bitmap32]
where bitmap32 = [ptext SLIT("BITMAP32"), lparen,
bundle (s1:s2:ss) = hcat bitmap64 : bundle ss
where bitmap64 = [ptext SLIT("BITMAP64"), lparen,
pp_bitset s1, comma, pp_bitset s2, rparen]
-
-pp_liveness :: Liveness -> SDoc
-pp_liveness (Liveness lbl mask)
- = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl)
\end{code}
%************************************************************************
pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n)
pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n)
pprMagicId Sp = ptext SLIT("Sp")
-pprMagicId Su = ptext SLIT("Su")
pprMagicId SpLim = ptext SLIT("SpLim")
pprMagicId Hp = ptext SLIT("Hp")
pprMagicId HpLim = ptext SLIT("HpLim")
-- no real reason to, anyway.
ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CStaticClosure closure_info cost_centre amodes)
+ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _)
+ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
= ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
- ppr_decls_AbsC slow `thenTE` \ p2 ->
- (case maybe_fast of
- Nothing -> returnTE (Nothing, Nothing)
- Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
- returnTE (maybe_vcat [p1, p2, p3])
+ ppr_decls_AbsC entry `thenTE` \ p2 ->
+ returnTE (maybe_vcat [p1, p2])
where
- entry_lbl = CLbl slow_lbl CodePtrRep
- slow_lbl = case (nonemptyAbsC slow) of
- Nothing -> mkErrorStdEntryLabel
- Just _ -> entryLabelFromCI cl_info
+ entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
ppr_decls_AbsC (CSRT _ closure_lbls)
= mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
pprCLabelAddr :: CLabel -> SDoc
pprCLabelAddr clabel =
case labelType clabel of
- InfoTblType -> addr_of_label
- ClosureType -> addr_of_label
- VecTblType -> addr_of_label
- _ -> pp_label
+ InfoTblType -> addr_of_label
+ RetInfoTblType -> addr_of_label
+ ClosureType -> addr_of_label
+ VecTblType -> addr_of_label
+ DataType -> addr_of_label
+
+ _ -> pp_label
where
addr_of_label = ptext SLIT("(P_)&") <> pp_label
pp_label = pprCLabel clabel
-
\end{code}
-----------------------------------------------------------------------------
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
- buildLivenessMask, buildContLivenessMask
+ buildContLivenessMask
) where
#include "HsVersions.h"
import CgMonad
import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
-import CgStackery ( freeStackSlots )
+import CgStackery ( freeStackSlots, getStackFrame )
import CLabel ( mkClosureLabel,
mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
import VarSet ( varSetElems )
import Literal ( Literal )
import Maybes ( catMaybes, maybeToBool, seqMaybe )
-import Name ( isInternalName, NamedThing(..) )
+import Name ( Name, isInternalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
| TempVarLoc Unique
| RegLoc MagicId -- in one of the magic registers
- -- (probably {Int,Float,Char,etc}Reg
+ -- (probably {Int,Float,Char,etc}Reg)
| VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
bindNewToStack (name, offset)
= addBindC name info
where
- info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
+ info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name)
bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
bindNewToNode name offset lf_info
-- temporary.
bindNewToTemp :: Id -> FCode CAddrMode
bindNewToTemp name
- = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
+ = let (temp_amode, id_info) = newTempAmodeAndIdInfo name (mkLFArgument name)
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
bindArgsToRegs args regs
= listCs (zipWithEqual "bindArgsToRegs" bind args regs)
where
- arg `bind` reg = bindNewToReg arg reg mkLFArgument
+ arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
\end{code}
@bindNewPrimToAmode@ works only for certain addressing modes. Making
\begin{code}
buildLivenessMask
- :: Unique -- unique for for large bitmap label
- -> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode Liveness -- mask for free/unlifted slots
+ :: VirtualSpOffset -- offset from which the bitmap should start
+ -> FCode LivenessMask -- mask for free/unlifted slots
+
+buildLivenessMask sp = do {
+
+ -- find all unboxed stack-resident ids
+ binds <- getBinds;
+ ((vsp, _, free, _, _), heap_usage) <- getUsage;
+
+ let {
+ unboxed_slots =
+ [ (ofs, size) |
+ (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ let rep = idPrimRep id; size = getPrimRepSize rep,
+ not (isFollowableRep rep),
+ size > 0
+ ];
+
+ -- flatten this list into a list of unboxed stack slots
+ flatten_slots = sortLt (<)
+ (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
+ unboxed_slots);
+
+ -- merge in the free slots
+ all_slots = mergeSlots flatten_slots (map fst free) ++
+ if vsp < sp then [vsp+1 .. sp] else [];
+
+ -- recalibrate the list to be sp-relative
+ rel_slots = reverse (map (sp-) all_slots);
+ };
+
+ ASSERT(all (>=0) rel_slots && rel_slots == sortLt (<) rel_slots)
+ return (listToLivenessMask rel_slots)
+ }
-buildLivenessMask uniq sp = do
-
- -- find all unboxed stack-resident ids
- binds <- getBinds
- ((vsp, free, _, _), heap_usage) <- getUsage
-
- let unboxed_slots =
- [ (ofs, size) |
- (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- let rep = idPrimRep id; size = getPrimRepSize rep,
- not (isFollowableRep rep),
- size > 0
- ]
-
- -- flatten this list into a list of unboxed stack slots
- let flatten_slots = sortLt (<)
- (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
- unboxed_slots)
-
- -- merge in the free slots
- let all_slots = mergeSlots flatten_slots (map fst free) ++
- if vsp < sp then [vsp+1 .. sp] else []
-
- -- recalibrate the list to be sp-relative
- let rel_slots = reverse (map (sp-) all_slots)
-
- -- build the bitmap
- let liveness_mask
- = ASSERT(all (>=0) rel_slots
- && rel_slots == sortLt (<) rel_slots)
- (listToLivenessMask rel_slots)
-
- livenessToAbsC uniq liveness_mask
mergeSlots :: [Int] -> [Int] -> [Int]
mergeSlots cs [] = cs
listToLivenessMask slots =
mkBS this : listToLivenessMask (map (\x -> x-32) rest)
where (this,rest) = span (<32) slots
-
-livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq mask =
- absC (CBitmap lbl mask) `thenC`
- returnFC (Liveness lbl mask)
- where lbl = mkBitmapLabel uniq
\end{code}
In a continuation, we want a liveness mask that starts from just after
the return address, which is on the stack at realSp.
\begin{code}
-buildContLivenessMask
- :: Unique
- -> FCode Liveness
-buildContLivenessMask uniq = do
+buildContLivenessMask :: Name -> FCode Liveness
+buildContLivenessMask name = do
realSp <- getRealSp
- buildLivenessMask uniq (realSp-1)
+ mask <- buildLivenessMask (realSp-1)
+
+ let lbl = mkBitmapLabel name
+
+ -- realSp points to the frame-header for the current stack frame,
+ -- and the end of this frame is frame_sp. The size is therefore
+ -- realSp - frame_sp - 1 (subtract one for the frame-header).
+ frame_sp <- getStackFrame
+ let liveness = Liveness lbl (realSp-1-frame_sp) mask
+
+ absC (CBitmap liveness)
+ return liveness
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $
+% $Id: CgCase.lhs,v 1.61 2002/12/11 15:36:25 simonmar Exp $
%
%********************************************************
%* *
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
getAmodeRep, nonemptyAbsC
)
-import CgUpdate ( reserveSeqFrame )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
bindNewPrimToAmode, getCAddrModeAndInfo,
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
-import CgHeapery ( altHeapCheck )
+import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
deAllocStackTop, freeStackSlots, dataStackSlots
)
-import CgTailCall ( tailCallFun )
+import CgTailCall ( performTailCall )
import CgUsages ( getSpRelOffset )
import CLabel ( mkVecTblLabel, mkClosureTblLabel,
mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
+import Name ( getName )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
import Util ( only )
`thenC`
-- compile the alts
- cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
- False{-not poly case-} alts deflt
- False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
+ cgAlgAlts NoGC False{-not polymorphic-} (getUnique bndr)
+ Nothing{-cc_slot-} False{-no semi-tagging-}
+ alts deflt False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
\begin{code}
cgCase (StgApp fun args)
live_in_whole_case live_in_alts bndr srt alts
- = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
- -- Squish the environment
+ -- Nuking dead bindings *before* calculating the saves is the
+ -- value-add here. We might end up freeing up some slots currently
+ -- occupied by variables only required for the call.
+ -- NOTE: we need to look up the variables used in the call before
+ -- doing this, because some of them may not be in the environment
+ -- afterward.
nukeDeadBindings live_in_alts `thenC`
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- allocStackTop retPrimRepSize `thenFC` \_ ->
-
- forkEval alts_eob_info nopC (
- deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts)
+ forkEval alts_eob_info
+ ( allocStackTop retPrimRepSize
+ `thenFC` \_ -> nopC )
+ ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts )
`thenFC` \ scrut_eob_info ->
setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
- tailCallFun fun' fun_amode lf_info arg_amodes save_assts
+ performTailCall fun' fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
- setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
cgExpr expr
\end{code}
could be anywhere within the record).
\begin{code}
--- We need to reserve a seq frame for a polymorphic case
-maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
-maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
+maybeReserveSeqFrame (StgAlgAlts Nothing _ _)
+ (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
+ = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
+
+maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
%************************************************************************
=
let uniq = getUnique bndr in
- buildContLivenessMask uniq `thenFC` \ liveness_mask ->
+ buildContLivenessMask (getName bndr) `thenFC` \ liveness ->
case alts of
StgAlgAlts maybe_tycon alts deflt ->
-- bind the default binder (it covers all the alternatives)
- bindNewToReg bndr node mkLFArgument `thenC`
+ bindNewToReg bndr node (mkLFArgument bndr) `thenC`
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
in
cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
getSRTInfo srt `thenFC` \ srt_info ->
- absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
- returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
+ absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
+ returnFC (CaseAlts (CLbl lbl RetRep) Nothing False)
-- normal algebraic (or polymorphic) case alternatives
else let
Nothing -- no semi-tagging info
in
- cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
+ cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts
alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
- mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
+ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness
ret_conv `thenFC` \ return_vec ->
- returnFC (CaseAlts return_vec semi_tagged_stuff)
+ returnFC (CaseAlts return_vec semi_tagged_stuff False)
-- primitive alts...
StgPrimAlts tycon alts deflt ->
-- Generate the labelled block, starting with restore-cost-centre
getSRTInfo srt `thenFC` \srt_info ->
absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
- srt_info liveness_mask) `thenC`
+ srt_info liveness) `thenC`
-- Return an amode for the block
- returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
+ returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing False)
\end{code}
\begin{code}
cgAlgAlts :: GCFlag
+ -> Bool -- polymorphic case
-> Unique
-> Maybe VirtualSpOffset
-> Bool -- True <=> branches must be labelled
- -> Bool -- True <=> polymorphic case
-> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
-> StgCaseDefault -- The default
-> Bool -- Context switch at alts?
AbstractC -- The default case
)
-cgAlgAlts gc_flag uniq restore_cc must_label_branches is_poly alts deflt
+cgAlgAlts gc_flag is_poly uniq restore_cc must_label_branches alts deflt
emit_yield{-should a yield macro be emitted?-}
= forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
\begin{code}
cgAlgDefault :: GCFlag
- -> Bool -- could be a function-typed result?
+ -> Bool -- polymorphic case
-> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
-> StgCaseDefault -- input
-> Bool
--(if emit_yield
-- then yield [node] True
-- else absC AbsCNop) `thenC`
- algAltHeapCheck gc_flag is_poly [node] [] Nothing (cgExpr rhs)
+ algAltHeapCheck gc_flag is_poly [node] (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
-- Hence no need to re-enter Node.
NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
GCMayHappen -> bindConArgs con args
) `thenC`
- algAltHeapCheck gc_flag False [node] [] Nothing (
+ algAltHeapCheck gc_flag False{-not poly-} [node] (
cgExpr rhs)
) `thenFC` \ abs_c ->
let
cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
= getAbsC (
bindUnboxedTupleComponents args
- `thenFC` \ (live_regs,tags,stack_res) ->
+ `thenFC` \ (live_regs, ptrs, nptrs, stack_res) ->
restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
absC restore_cc `thenC`
-- (if emit_yield
-- then yield live_regs True -- XXX live regs wrong?
-- else absC AbsCNop) `thenC`
- let
- -- ToDo: could maybe use Nothing here if stack_res is False
- -- since the heap-check can just return to the top of the
- -- stack.
- ret_addr = Just lbl
- in
-
- -- free up stack slots containing tags,
- freeStackSlots (map fst tags) `thenC`
-- generate a heap check if necessary
- primAltHeapCheck GCMayHappen live_regs tags ret_addr (
+ possibleUnbxTupleHeapCheck GCMayHappen live_regs ptrs nptrs (
-- and finally the code for the alternative
cgExpr rhs)
= getAbsC rhs_code `thenFC` \ absC ->
returnFC (lit,absC)
where
- rhs_code = primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs)
+ rhs_code = primAltHeapCheck gc_flag regs (cgExpr rhs)
cgPrimDefault :: GCFlag
-> [MagicId] -- live registers
= panic "cgPrimDefault: No default in prim case"
cgPrimDefault gc_flag regs (StgBindDefault rhs)
- = getAbsC (primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs))
+ = getAbsC (primAltHeapCheck gc_flag regs (cgExpr rhs))
\end{code}
(CLbl ret_label RetRep,
absC (CRetDirect uniq
(mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- srt_info
- liveness));
+ srt_info liveness));
VectoredReturn table_size ->
let
%* *
%************************************************************************
-@possibleHeapCheck@ tests a flag passed in to decide whether to do a
+'possibleHeapCheck' tests a flag passed in to decide whether to do a
heap check or not. These heap checks are always in a case
alternative, so we use altHeapCheck.
\begin{code}
-algAltHeapCheck
+algAltHeapCheck
+ :: GCFlag
+ -> Bool -- polymorphic case
+ -> [MagicId] -- live registers
+ -> Code -- continuation
+ -> Code
+
+algAltHeapCheck GCMayHappen is_poly regs code = altHeapCheck is_poly regs code
+algAltHeapCheck NoGC _ _ code = code
+
+primAltHeapCheck
:: GCFlag
- -> Bool -- True <=> polymorphic case
- -> [MagicId] -- live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> Maybe Unique -- return address unique
- -> Code -- continuation
+ -> [MagicId] -- live registers
+ -> Code -- continuation
-> Code
-algAltHeapCheck GCMayHappen is_poly regs tags lbl code
- = altHeapCheck is_poly False regs tags AbsCNop lbl code
-algAltHeapCheck NoGC _ _ tags lbl code
- = code
+primAltHeapCheck GCMayHappen regs code = altHeapCheck True regs code
+primAltHeapCheck NoGC _ code = code
+
+possibleUnbxTupleHeapCheck
+ :: GCFlag
+ -> [MagicId] -- live registers
+ -> Int -- no. of stack slots containing ptrs
+ -> Int -- no. of stack slots containing nonptrs
+ -> Code -- continuation
+ -> Code
-primAltHeapCheck GCMayHappen regs tags lbl code
- = altHeapCheck False True regs tags AbsCNop lbl code
-primAltHeapCheck NoGC _ _ _ code
- = code
+possibleUnbxTupleHeapCheck GCMayHappen regs ptrs nptrs code
+ = unbxTupleHeapCheck regs ptrs nptrs AbsCNop code
+possibleUnbxTupleHeapCheck NoGC _ _ _ code
+ = code
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.58 2002/09/13 15:02:27 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
-import AbsCSyn
-import StgSyn
-
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgBindery ( getCAddrMode, getArgAmodes,
- getCAddrModeAndInfo, bindNewToNode,
- bindNewToStack,
- bindNewToReg, bindArgsToRegs,
- stableAmodeIdInfo, heapIdInfo, CgIdInfo
- )
+import CgBindery
import CgUpdate ( pushUpdateFrame )
-import CgHeapery ( allocDynClosure,
- fetchAndReschedule, yield, -- HWL
- fastEntryChecks, thunkChecks
- )
-import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
-import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
- getSpRelOffset, getHpRelOffset
- )
-import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
- mkRednCountsLabel, mkInfoTableLabel
- )
+import CgHeapery
+import CgStackery
+import CgUsages
import ClosureInfo -- lots and lots of stuff
+
+import AbsCUtils ( getAmodeRep, mkAbstractCs )
+import AbsCSyn
+import CLabel
+
+import StgSyn
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
import CostCentre
import Id ( Id, idName, idType, idPrimRep )
import Name ( Name, isInternalName )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import PrimRep ( PrimRep(..) )
+import PrimRep ( PrimRep(..), getPrimRepSize )
import PprType ( showTypeCategory )
import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Name ( nameOccName )
import OccName ( occNameFS )
-import FastTypes ( iBox )
\end{code}
%********************************************************
=
-- LAY OUT THE OBJECT
getSRTInfo srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
let
name = idName id
- closure_info = layOutStaticNoFVClosure name lf_info srt_info
+ descr = closureDescription mod_name name
+ closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
closure_label = mkClosureLabel name
cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
in
(
({- if staticClosureRequired name binder_info lf_info
then -}
- absC (mkStaticClosure closure_info ccs [] True)
+ absC (mkStaticClosure closure_label closure_info ccs [] True)
{- else
nopC -}
)
-- AHA! A STANDARD-FORM THUNK
= (
-- LAY OUT THE OBJECT
- getArgAmodes payload `thenFC` \ amodes ->
+ getArgAmodes payload `thenFC` \ amodes ->
+ moduleName `thenFC` \ mod_name ->
let
+ descr = closureDescription mod_name (idName binder)
+
(closure_info, amodes_w_offsets)
- = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT
+ = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
-- No SRT for a standard-form closure
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
+
-- BUILD THE OBJECT
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
)
then fvs `minusList` [binder]
else fvs
in
+
mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
getSRTInfo srt `thenFC` \ srt_info ->
+ moduleName `thenFC` \ mod_name ->
let
+ descr = closureDescription mod_name (idName binder)
+
closure_info :: ClosureInfo
bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, bind_details)
- = layOutDynClosure (idName binder) get_kind
- fvs_w_amodes_and_info lf_info srt_info
+ = layOutDynClosure binder get_kind
+ fvs_w_amodes_and_info lf_info srt_info descr
bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
get_kind (id, _, _) = idPrimRep id
in
+
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
-- Bind the fvs
There are two main cases for the code for closures. If there are {\em
no arguments}, then the closure is a thunk, and not in normal form.
-So it should set up an update frame (if it is shared). Also, it has
-no argument satisfaction check, so fast and slow entry-point labels
-are the same.
+So it should set up an update frame (if it is shared).
\begin{code}
closureCodeBody binder_info closure_info cc [] body
= -- thunks cannot have a primitive type!
getAbsC body_code `thenFC` \ body_absC ->
- moduleName `thenFC` \ mod_name ->
- absC (CClosureInfoAndCode closure_info body_absC Nothing
- (cl_descr mod_name))
+ absC (CClosureInfoAndCode closure_info body_absC)
where
- cl_descr mod_name = closureDescription mod_name (closureName closure_info)
-
- body_label = entryLabelFromCI closure_info
-
is_box = case body of { StgApp fun [] -> True; _ -> False }
ticky_ent_lit = if (isStaticClosure closure_info)
body_code = profCtrC ticky_ent_lit [] `thenC`
-- node always points when profiling, so this is ok:
ldvEnter `thenC`
- thunkWrapper closure_info body_label (
+ thunkWrapper closure_info (
-- We only enter cc after setting up update so
-- that cc of enclosing scope will be recorded
-- in update frame CAF/DICT functions will be
\end{code}
-If there is {\em at least one argument}, then this closure is in
-normal form, so there is no need to set up an update frame. On the
-other hand, we do have to check that there are enough args, and
-perform an update if not!
+If there is /at least one argument/, then this closure is in
+normal form, so there is no need to set up an update frame.
The Macros for GrAnSim are produced at the beginning of the
argSatisfactionCheck (by calling fetchAndReschedule). There info if
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
- = getEntryConvention name lf_info
- (map idPrimRep all_args) `thenFC` \ entry_conv ->
+ = let arg_reps = map idPrimRep all_args in
- -- get the current virtual Sp (it might not be zero, eg. if we're
- -- compiling a let-no-escape).
- getVirtSp `thenFC` \vSp ->
+ getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
let
- -- Figure out what is needed and what isn't
-
- -- SDM: need everything for now in case the heap/stack check refers
- -- to it. (ToDo)
- slow_code_needed = True
- --slowFunEntryCodeRequired name binder_info entry_conv
- info_table_needed = True
- --funInfoTableRequired name binder_info lf_info
-
- -- Arg mapping for standard (slow) entry point; all args on stack,
- -- with tagging.
- (sp_all_args, arg_offsets, _)
- = mkTaggedVirtStkOffsets vSp idPrimRep all_args
-
- -- Arg mapping for the fast entry point; as many args as poss in
+ -- Arg mapping for the entry point; as many args as poss in
-- registers; the rest on the stack
-- arg_regs are the registers used for arg passing
-- stk_args are the args which are passed on the stack
--
- -- Args passed on the stack are tagged, but the tags may not
- -- actually be present (just gaps) if the function is called
- -- by jumping directly to the fast entry point.
+ -- Args passed on the stack are not tagged.
--
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- other -> [] -- "(HWL ignored; no args passed in regs)"
-
- (reg_args, stk_args) = splitAtList arg_regs all_args
-
- (sp_stk_args, stk_offsets, stk_tags)
- = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
-
- -- HWL; Note: empty list of live regs in slow entry code
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
- -- where node = UnusedReg PtrRep 1
- --slow_entry_code = forceHeapCheck [] True slow_entry_code'
-
- slow_entry_code
- = profCtrC slow_ticky_ent_lit [
- CLbl ticky_ctr_label DataPtrRep
- ] `thenC`
-
- -- Bind args, and record expected position of stk ptrs
- mapCs bindNewToStack arg_offsets `thenC`
- setRealAndVirtualSp sp_all_args `thenC`
-
- argSatisfactionCheck closure_info arg_regs `thenC`
-
- -- OK, so there are enough args. Now we need to stuff as
- -- many of them in registers as the fast-entry code
- -- expects. Note that the zipWith will give up when it hits
- -- the end of arg_regs.
+ _ -> panic "closureCodeBody"
+ in
- mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
- absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
- `thenC`
+ -- If this function doesn't have a specialised ArgDescr, we need
+ -- to generate the function's arg bitmap, slow-entry code, and
+ -- register-save code for the heap-check failure
+ --
+ (case closureFunInfo closure_info of
+ Just (_, ArgGen slow_lbl liveness) ->
+ absC (CBitmap liveness) `thenC`
+ absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
+ returnFC (mkRegSaveCode arg_regs arg_reps)
- -- Now adjust real stack pointers (no need to adjust Hp,
- -- but call this function for convenience).
- adjustSpAndHp sp_stk_args `thenC`
+ other -> returnFC AbsCNop
+ )
+ `thenFC` \ reg_save_code ->
- absC (CFallThrough (CLbl fast_label CodePtrRep))
+ -- get the current virtual Sp (it might not be zero, eg. if we're
+ -- compiling a let-no-escape).
+ getVirtSp `thenFC` \vSp ->
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
+ let
+ (reg_args, stk_args) = splitAtList arg_regs all_args
- -- HWL
- -- Old version (reschedule combined with heap check);
- -- see argSatisfactionCheck for new version
- -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
+ (sp_stk_args, stk_offsets)
+ = mkVirtStkOffsets vSp idPrimRep stk_args
- fast_entry_code = do
+ entry_code = do
mod_name <- moduleName
profCtrC FSLIT("TICK_CTR") [
CLbl ticky_ctr_label DataPtrRep,
mkCString (mkFastString (map (showTypeCategory . idType) all_args))
]
let prof =
- profCtrC fast_ticky_ent_lit [
+ profCtrC ticky_ent_lit [
CLbl ticky_ctr_label DataPtrRep
]
--- Nuked for now; see comment at end of file
--- CString (mkFastString (show_wrapper_name wrapper_maybe)),
--- CString (mkFastString (show_wrapper_arg_kinds wrapper_maybe))
-
-
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps.
bindArgsToRegs reg_args arg_regs
mapCs bindNewToStack stk_offsets
setRealAndVirtualSp sp_stk_args
- -- free up the stack slots containing tags
- freeStackSlots (map fst stk_tags)
-
-- Enter the closures cc, if required
enterCostCentreCode closure_info cc IsFunction False
-- Do the business
- funWrapper closure_info arg_regs stk_tags info_label
+ funWrapper closure_info arg_regs reg_save_code
(prof >> cgExpr body)
in
setTickyCtrLabel ticky_ctr_label (
- -- Make a labelled code-block for the slow and fast entry code
- forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
- `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
+ forkAbsC entry_code `thenFC` \ entry_abs_c ->
moduleName `thenFC` \ mod_name ->
- -- Now either construct the info table, or put the fast code in alone
- -- (We never have slow code without an info table)
- -- XXX probably need the info table and slow entry code in case of
- -- a heap check failure.
- absC (
- if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
- (cl_descr mod_name)
- else
- CCodeBlock fast_label fast_abs_c
- )
+ -- Now construct the info table
+ absC (CClosureInfoAndCode closure_info entry_abs_c)
)
where
ticky_ctr_label = mkRednCountsLabel name
- (slow_ticky_ent_lit, fast_ticky_ent_lit) =
+ ticky_ent_lit =
if (isStaticClosure closure_info)
- then (FSLIT("TICK_ENT_STATIC_FUN_STD"), FSLIT("TICK_ENT_STATIC_FUN_DIRECT"))
- else (FSLIT("TICK_ENT_DYN_FUN_STD"), FSLIT("TICK_ENT_DYN_FUN_DIRECT"))
+ then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
+ else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
stg_arity = length all_args
lf_info = closureLFInfo closure_info
- cl_descr mod_name = closureDescription mod_name name
-
-- Manufacture labels
name = closureName closure_info
- fast_label = mkFastEntryLabel name stg_arity
- info_label = mkInfoTableLabel name
-- When printing the name of a thing in a ticky file, we want to
| otherwise = showSDocDebug (ppr name)
\end{code}
+The "slow entry" code for a function. This entry point takes its
+arguments on the stack. It loads the arguments into registers
+according to the calling convention, and jumps to the function's
+normal entry point. The function's closure is assumed to be in
+R1/node.
+
+The slow entry point is used in two places:
+
+ (a) unknown calls: eg. stg_PAP_entry
+ (b) returning from a heap-check failure
+
+\begin{code}
+mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
+mkSlowEntryCode name lbl regs reps
+ = CCodeBlock lbl (
+ mkAbstractCs [assts, stk_adj, jump]
+ )
+ where
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
+
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
+ stk_final_offset = head (drop (length regs) stk_offsets)
+
+ jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
+
+mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
+mkRegSaveCode regs reps
+ = mkAbstractCs [stk_adj, assts]
+ where
+ stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
+
+ stk_final_offset = head (drop (length regs) stk_offsets)
+ stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
+
+ assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
+ mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
+\end{code}
+
For lexically scoped profiling we have to load the cost centre from
the closure entered, if the costs are not supposed to be inherited.
This is done immediately on entering the fast entry point.
%************************************************************************
%* *
-\subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
-%* *
-%************************************************************************
-
-The argument-satisfaction check code is placed after binding
-the arguments to their stack locations. Hence, the virtual stack
-pointer is pointing after all the args, and virtual offset 1 means
-the base of frame and hence most distant arg. Hence
-virtual offset 0 is just beyond the most distant argument; the
-relative offset of this word tells how many words of arguments
-are expected.
-
-\begin{code}
-argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
-
-argSatisfactionCheck closure_info arg_regs
-
- = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
--- let
--- emit_gran_macros = opt_GranMacros
--- in
-
- -- HWL ngo' ngoq:
- -- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- --(if opt_GranMacros
- -- then if node_points
- -- then fetchAndReschedule arg_regs node_points
- -- else yield arg_regs node_points
- -- else absC AbsCNop) `thenC`
-
- getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
- let
- off = iBox sp
- rel_arg = mkIntCLit off
- in
- ASSERT(off /= 0)
- if node_points then
- absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
- else
- absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
- where
- -- We must tell the arg-satis macro whether Node is pointing to
- -- the closure or not. If it isn't so pointing, then we give to
- -- the macro the (static) address of the closure.
-
- set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection[closure-code-wrappers]{Wrappers around closure code}
%* *
%************************************************************************
\begin{code}
-thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
-thunkWrapper closure_info lbl thunk_code
+thunkWrapper:: ClosureInfo -> Code -> Code
+thunkWrapper closure_info thunk_code
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
else yield [] node_points
else absC AbsCNop) `thenC`
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
+ in
+
-- stack and/or heap checks
- thunkChecks lbl node_points (
+ thunkChecks closure_lbl (
-- Overwrite with black hole if necessary
blackHoleIt closure_info node_points `thenC`
funWrapper :: ClosureInfo -- Closure whose code body this is
-> [MagicId] -- List of argument registers (if any)
- -> [(VirtualSpOffset,Int)] -- tagged stack slots
- -> CLabel -- info table for heap check ret.
+ -> AbstractC -- reg saves for the heap check failure
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs stk_tags info_label fun_body
+funWrapper closure_info arg_regs reg_save_code fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
then yield arg_regs node_points
else absC AbsCNop) `thenC`
+ let closure_lbl
+ | node_points = Nothing
+ | otherwise = Just (closureLabelFromCI closure_info)
+ in
+
-- heap and/or stack checks
- fastEntryChecks arg_regs stk_tags info_label node_points (
+ funEntryChecks closure_lbl reg_save_code (
-- Finally, do the business
fun_body
ppr name,
char '>'])
\end{code}
-
+
\begin{code}
chooseDynCostCentres ccs args fvs body
= let
idInfoToAmode, stableAmodeIdInfo,
heapIdInfo, CgIdInfo, bindNewToStack
)
-import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots,
- updateFrameSize
- )
+import CgStackery ( mkVirtStkOffsets, freeStackSlots, updateFrameSize )
import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
getSpRelOffset )
import CgRetConv ( assignRegs )
import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
mIN_UPD_SIZE )
import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
- mkUnboxedTupleReturnCode )
+import CgTailCall ( performReturn, mkStaticAlgReturnCode,
+ returnUnboxedTuple )
import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkConLFInfo, mkLFArgument, closureLFInfo,
- layOutDynConstr, layOutDynClosure,
+import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr,
layOutStaticConstr, closureSize, mkStaticClosure
)
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
-import DataCon ( DataCon, dataConName, dataConTag,
+import DataCon ( DataCon, dataConTag,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConWrapId, dataConRepArity
)
import Unique ( Uniquable(..) )
import Util
import Outputable
+
+import List ( partition )
\end{code}
%************************************************************************
let
name = idName id
- lf_info = closureLFInfo closure_info
+ lf_info = mkConLFInfo con
closure_label = mkClosureLabel name
(closure_info, amodes_w_offsets)
- = layOutStaticConstr name con getAmodeRep amodes
+ = layOutStaticConstr con getAmodeRep amodes
in
-- BUILD THE OBJECT
absC (mkStaticClosure
+ closure_label
closure_info
dontCareCCS -- because it's static data
(map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
= allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
returnFC (heapIdInfo binder hp_off lf_info)
where
- (closure_info, amodes_w_offsets)
- = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT
lf_info = mkConLFInfo con
+ (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args
+
use_cc -- cost-centre to stick in the object
= if currentOrSubsumedCCS ccs
then CReg CurCostCentre
= ASSERT(not (isUnboxedTupleCon con))
mapCs bind_arg args_w_offsets
where
- bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
- (_, args_w_offsets) = layOutDynConstr bogus_name con idPrimRep args
-
-bogus_name = panic "bindConArgs"
+ bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+ (_, args_w_offsets) = layOutDynConstr con idPrimRep args
\end{code}
Unboxed tuples are handled slightly differently - the object is
\begin{code}
bindUnboxedTupleComponents
- :: [Id] -- args
- -> FCode ([MagicId], -- regs assigned
- [(VirtualSpOffset,Int)], -- tag slots
- Bool) -- any components on stack?
+ :: [Id] -- args
+ -> FCode ([MagicId], -- regs assigned
+ Int, -- number of pointer stack slots
+ Int, -- number of non-pointer stack slots
+ Bool) -- any components on stack?
bindUnboxedTupleComponents args
= -- Assign as many components as possible to registers
let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
(reg_args, stk_args) = splitAtList arg_regs args
- in
- -- Allocate the rest on the stack (ToDo: separate out pointers)
+ -- separate the rest of the args into pointers and non-pointers
+ ( ptr_args, nptr_args ) =
+ partition (isFollowableRep . idPrimRep) stk_args
+ in
+
+ -- Allocate the rest on the stack
getVirtSp `thenFC` \ vsp ->
getRealSp `thenFC` \ rsp ->
- let (top_sp, stk_offsets, tags) =
- mkTaggedVirtStkOffsets rsp idPrimRep stk_args
+ let
+ (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args
+ (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
in
-- The stack pointer points to the last stack-allocated component
- setRealAndVirtualSp top_sp `thenC`
+ setRealAndVirtualSp nptr_sp `thenC`
-- need to explicitly free any empty slots we just jumped over
(if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack stk_offsets `thenC`
- returnFC (arg_regs,tags, notNull stk_offsets)
+ mapCs bindNewToStack ptr_offsets `thenC`
+ mapCs bindNewToStack nptr_offsets `thenC`
+
+ returnFC (arg_regs,
+ ptr_sp - rsp, nptr_sp - ptr_sp,
+ notNull ptr_offsets || notNull ptr_offsets
+ )
\end{code}
%************************************************************************
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
+ CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl)))) False
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
inPlaceAllocDynClosure closure_info temp (CReg CurCostCentre) stuff
`thenC`
- -- don't forget to update Su from the update frame
- absC (CMacroStmt UPDATE_SU_FROM_UPD_FRAME [CAddr sp_rel]) `thenC`
-
-- set Node to point to the closure being returned
-- (can't be done earlier: node might conflict with amodes)
absC (CAssign (CReg node) temp) `thenC`
performReturn (AbsCNop) (mkStaticAlgReturnCode con)
where
- (closure_info, stuff)
- = layOutDynConstr (dataConName con) con getAmodeRep amodes
+ (closure_info, stuff) = layOutDynConstr con getAmodeRep amodes
other_sequel -- The usual case
-
- | isUnboxedTupleCon con ->
- -- Return unboxed tuple in registers
- let (ret_regs, leftovers) =
- assignRegs [] (map getAmodeRep amodes)
- in
- profCtrC FSLIT("TICK_RET_UNBOXED_TUP")
- [mkIntCLit (length amodes)] `thenC`
-
- doTailCall amodes ret_regs
- mkUnboxedTupleReturnCode
- (length leftovers) {- fast args arity -}
- AbsCNop {-no pending assigments-}
- Nothing {-not a let-no-escape-}
- False {-node doesn't point-}
-
- | otherwise ->
- build_it_then (mkStaticAlgReturnCode con)
+ | isUnboxedTupleCon con -> returnUnboxedTuple amodes
+ | otherwise -> build_it_then (mkStaticAlgReturnCode con)
where
move_to_reg :: CAddrMode -> MagicId -> AbstractC
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
-import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
-import Name ( getOccName )
-import OccName ( occNameUserString )
+import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon )
import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
import Type ( typePrimRep )
import CmdLineOpts
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
+ (static_ci,_) = layOutStaticConstr data_con typePrimRep arg_tys
static_body = initC comp_info (
profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC`
ldv_enter_and_body_code = ldvEnter `thenC` body_code
- con_descr = occNameUserString (getOccName data_con)
-
-- Don't need any dynamic closure code for zero-arity constructors
closure_code = if zero_arity_con then
AbsCNop
else
- CClosureInfoAndCode closure_info closure_body Nothing con_descr
+ CClosureInfoAndCode closure_info closure_body
- static_code = CClosureInfoAndCode static_ci static_body Nothing con_descr
+ static_code = CClosureInfoAndCode static_ci static_body
zero_arity_con = isNullaryDataCon data_con
-- We used to check that all the arg-sizes were zero, but we don't
-- just one more thing to go wrong.
arg_tys = dataConRepArgTys data_con
- con_name = dataConName data_con
\end{code}
\begin{code}
= let
arg_tys = dataConRepArgTys con
- (closure_info, arg_things)
- = layOutDynConstr (dataConName con) con typePrimRep arg_tys
+ (closure_info, arg_things) = layOutDynConstr con typePrimRep arg_tys
body_code
= -- NB: We don't set CC when entering data (WDP 94/06)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.51 2002/09/13 15:02:28 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.52 2002/12/11 15:36:26 simonmar Exp $
%
%********************************************************
%* *
import CgRetConv ( dataReturnConvPrim )
import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
mkDynamicAlgReturnCode, mkPrimReturnCode,
- tailCallPrimOp, returnUnboxedTuple
+ tailCallPrimOp, ccallReturnUnboxedTuple
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
mkApLFInfo, layOutDynConstr )
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
-import Id ( idPrimRep, idType, Id )
+import Id ( idPrimRep, Id )
import VarSet
import PrimOp ( primOpOutOfLine, getPrimOpResultInfo,
PrimOp(..), PrimOpResultInfo(..) )
-- will evaluate to.
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
- lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
- (isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
+ lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr con idPrimRep params
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
- bogus_name = panic "mkRhsClosure"
\end{code}
Ap thunks
= cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
where
- lf_info = mkApLFInfo (idType bndr) upd_flag arity
+ lf_info = mkApLFInfo bndr upd_flag arity
-- the payload has to be in the correct order, hence we can't
-- just use the fvs.
payload = StgVarArg fun_id : args
temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
- returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
+ ccallReturnUnboxedTuple temp_amodes
+ (absC (COpStmt temp_amodes op arg_temps []))
+
shimFCallArg arg amode
| tycon == foreignObjPrimTyCon
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $
+% $Id: CgHeapery.lhs,v 1.35 2002/12/11 15:36:26 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
- fastEntryChecks, altHeapCheck, thunkChecks,
+ funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks,
allocDynClosure, inPlaceAllocDynClosure
-- new functions, basically inserting macro calls into Code -- HWL
import CLabel
import CgMonad
-import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
+import CgStackery ( getFinalStackHW )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
slopSize, allocProfilingMsg, ClosureInfo
)
import PrimRep ( PrimRep(..), isFollowableRep )
-import Unique ( Unique )
import CmdLineOpts ( opt_GranMacros )
import Outputable
an automatic context switch is done.
-----------------------------------------------------------------------------
-A heap/stack check at a fast entry point.
+A heap/stack check at a function or thunk entry point.
\begin{code}
-
-fastEntryChecks
- :: [MagicId] -- Live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> CLabel -- return point
- -> Bool -- node points to closure
+funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
+funEntryChecks closure_lbl reg_save_code code
+ = hpStkCheck closure_lbl True reg_save_code code
+
+thunkChecks :: Maybe CLabel -> Code -> Code
+thunkChecks closure_lbl code
+ = hpStkCheck closure_lbl False AbsCNop code
+
+hpStkCheck
+ :: Maybe CLabel -- function closure
+ -> Bool -- is a function? (not a thunk)
+ -> AbstractC -- register saves
-> Code
-> Code
-fastEntryChecks regs tags ret node_points code
- = mkTagAssts tags `thenFC` \tag_assts ->
- getFinalStackHW (\ spHw ->
+hpStkCheck closure_lbl is_fun reg_save_code code
+ = getFinalStackHW (\ spHw ->
getRealSp `thenFC` \ sp ->
let stk_words = spHw - sp in
initHeapUsage (\ hHw ->
getTickyCtrLabel `thenFC` \ ticky_ctr ->
- ( if all_pointers then -- heap checks are quite easy
- -- HWL: gran-yield immediately before heap check proper
- --(if node `elem` regs
- -- then yield regs True
- -- else absC AbsCNop ) `thenC`
- absC (checking_code stk_words hHw tag_assts
- free_reg (length regs) ticky_ctr)
-
- else -- they are complicated
-
- -- save all registers on the stack and adjust the stack pointer.
- -- ToDo: find the initial all-pointer segment and don't save them.
-
- mkTaggedStkAmodes sp addrmode_regs
- `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
+ absC (checking_code stk_words hHw ticky_ctr) `thenC`
- -- only let the extra stack assignments affect the stack
- -- high water mark if we were doing a stack check anyway;
- -- otherwise we end up generating unnecessary stack checks.
- -- Careful about knot-tying loops!
- let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
- then new_sp - sp
- else stk_words
- in
+ setRealHp hHw `thenC`
+ code))
- let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
-
- absC (checking_code real_stk_words hHw
- (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
- adjust_sp])
- (CReg node) 0 ticky_ctr)
-
- ) `thenC`
+ where
+ node_asst
+ | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep)
+ | otherwise = AbsCNop
- setRealHp hHw `thenC`
- code))
+ save_code = mkAbstractCs [node_asst, reg_save_code]
- where
-
- checking_code stk hp assts ret regs ctr
+ checking_code stk hp ctr
= mkAbstractCs
- [ real_check,
- if hp == 0 then AbsCNop
- else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit hp, CLbl ctr DataPtrRep ]
+ [ if is_fun
+ then do_checks_fun stk hp save_code
+ else do_checks_np stk hp save_code,
+ if hp == 0
+ then AbsCNop
+ else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit hp, CLbl ctr DataPtrRep ]
]
- where real_check
- | node_points = do_checks_np stk hp assts (regs+1)
- | otherwise = do_checks stk hp assts ret regs
- -- When node points to the closure for the function:
+-- For functions:
- do_checks_np
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> Int -- number of pointer registers live
+do_checks_fun
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
-> AbstractC
- do_checks_np 0 0 _ _ = AbsCNop
- do_checks_np 0 hp_words tag_assts ptrs =
- CCheck HP_CHK_NP [
- mkIntCLit hp_words,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks_np stk_words 0 tag_assts ptrs =
- CCheck STK_CHK_NP [
- mkIntCLit stk_words,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks_np stk_words hp_words tag_assts ptrs =
- CCheck HP_STK_CHK_NP [
- mkIntCLit stk_words,
- mkIntCLit hp_words,
- mkIntCLit ptrs
- ]
- tag_assts
-
- -- When node doesn't point to the closure (we need an explicit retn addr)
-
- do_checks
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> CAddrMode -- a register to hold the retn addr.
- -> Int -- number of pointer registers live
+do_checks_fun 0 0 _ = AbsCNop
+do_checks_fun 0 hp_words assts =
+ CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts
+do_checks_fun stk_words 0 assts =
+ CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts
+do_checks_fun stk_words hp_words assts =
+ CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
+
+-- For thunks:
+
+do_checks_np
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
-> AbstractC
-
- do_checks 0 0 _ _ _ = AbsCNop
- do_checks 0 hp_words tag_assts ret_reg ptrs =
- CCheck HP_CHK [
- mkIntCLit hp_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks stk_words 0 tag_assts ret_reg ptrs =
- CCheck STK_CHK [
- mkIntCLit stk_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks stk_words hp_words tag_assts ret_reg ptrs =
- CCheck HP_STK_CHK [
- mkIntCLit stk_words,
- mkIntCLit hp_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
-
- free_reg = case length regs + 1 of
- I# x -> CReg (VanillaReg PtrRep x)
-
- all_pointers = all pointer regs
- pointer (VanillaReg rep _) = isFollowableRep rep
- pointer _ = False
-
- addrmode_regs = map CReg regs
-
--- Checking code for thunks is just a special case of fast entry points:
-
-thunkChecks :: CLabel -> Bool -> Code -> Code
-thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
+do_checks_np 0 0 _ = AbsCNop
+do_checks_np 0 hp_words assts =
+ CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts
+do_checks_np stk_words 0 assts =
+ CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts
+do_checks_np stk_words hp_words assts =
+ CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
\end{code}
Heap checks in a case alternative are nice and easy, provided this is
entering the top value on the stack, which in turn will return through
the return address, getting us back to where we were. This is
therefore only valid if the return value is *lifted* (just being
-boxed isn't good enough). Only a PtrRep will do.
+boxed isn't good enough).
For primitive returns, we have an unlifted value in some register
(either R1 or FloatReg1 or DblReg1). This means using specialised
\begin{code}
altHeapCheck
- :: Bool -- is a polymorphic case alt
- -> Bool -- is an primitive case alt
- -> [MagicId] -- live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> AbstractC
- -> Maybe Unique -- uniq of ret address (possibly)
- -> Code
+ :: Bool -- do not enter node on return
+ -> [MagicId] -- live registers
+ -> Code -- continuation
-> Code
--- unboxed tuple alternatives and let-no-escapes (the two most annoying
--- constructs to generate code for!):
-
-altHeapCheck is_poly is_prim regs tags fail_code (Just ret_addr) code
- = mkTagAssts tags `thenFC` \tag_assts1 ->
- let tag_assts = mkAbstractCs [fail_code, tag_assts1]
- in
- initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
- where
- do_heap_chk words_required tag_assts
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ checking_code tag_assts,
- profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ]
- ) `thenC`
- setRealHp words_required
-
- where
- non_void_regs = filter (/= VoidReg) regs
-
- checking_code tag_assts =
- case non_void_regs of
-
-{- no: there might be stuff on top of the retn. addr. on the stack.
- [{-no regs-}] ->
- CCheck HP_CHK_NOREGS
- [mkIntCLit words_required]
- tag_assts
--}
- -- this will cover all cases for x86
- [VanillaReg rep 1#]
-
- | isFollowableRep rep ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
- CReg (VanillaReg RetRep 2#),
- CLbl (mkReturnInfoLabel ret_addr) RetRep]
- tag_assts
-
- | otherwise ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
- CReg (VanillaReg RetRep 2#),
- CLbl (mkReturnInfoLabel ret_addr) RetRep]
- tag_assts
-
- several_regs ->
- let liveness = mkRegLiveness several_regs
- in
- CCheck HP_CHK_GEN
- [mkIntCLit words_required,
- mkIntCLit (I# (word2Int# liveness)),
- -- HP_CHK_GEN needs a direct return address,
- -- not an info table (might be different if
- -- we're not assembly-mangling/tail-jumping etc.)
- CLbl (mkReturnPtLabel ret_addr) RetRep]
- tag_assts
-- normal algebraic and primitive case alternatives:
-altHeapCheck is_poly is_prim regs [] AbsCNop Nothing code
+altHeapCheck no_enter regs code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
where
do_heap_chk :: HeapOffset -> Code
[] ->
CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
- -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
- --
- -- We also lump the polymorphic case in here, because we don't
- -- want to enter R1 if it is a function, and we're guarnateed
- -- that the return point has a direct return.
[VanillaReg rep 1#]
- | isFollowableRep rep && (is_poly || is_prim) ->
+ -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
+ | isFollowableRep rep && no_enter ->
CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-- R1 is lifted (the common case)
| isFollowableRep rep ->
CCheck HP_CHK_NP
- [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ [mkIntCLit words_required]
AbsCNop
-- R1 is unboxed
_ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
#endif
+-- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- constructs to generate code for!):
+
+unbxTupleHeapCheck
+ :: [MagicId] -- live registers
+ -> Int -- no. of stack slots containing ptrs
+ -> Int -- no. of stack slots containing nonptrs
+ -> AbstractC -- code to insert in the failure path
+ -> Code
+ -> Code
+
+unbxTupleHeapCheck regs ptrs nptrs fail_code code
+ -- we can't manage more than 255 pointers/non-pointers in a generic
+ -- heap check.
+ | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
+ | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+ where
+ do_heap_chk words_required
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code,
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
+ setRealHp words_required
+
+ where
+ checking_code =
+ let liveness = mkRegLiveness regs ptrs nptrs
+ in
+ CCheck HP_CHK_UNBX_TUPLE
+ [mkIntCLit words_required,
+ mkIntCLit (I# (word2Int# liveness))]
+ fail_code
+
-- build up a bitmap of the live pointer registers
#if __GLASGOW_HASKELL__ >= 503
shiftL = shiftL#
#endif
-mkRegLiveness :: [MagicId] -> Word#
-mkRegLiveness [] = int2Word# 0#
-mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
- = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs
-mkRegLiveness (_ : regs) = mkRegLiveness regs
+mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
+mkRegLiveness [] (I# ptrs) (I# nptrs) =
+ (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
+mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
+ = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
+mkRegLiveness (_ : regs) ptrs nptrs = mkRegLiveness regs ptrs nptrs
-- The two functions below are only used in a GranSim setup
-- Emit macro for simulating a fetch and then reschedule
then fetch_code `thenC` reschedule_code
else absC AbsCNop
where
- liveness_mask = mkRegLiveness regs
+ liveness_mask = mkRegLiveness regs 0 0
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit (I# (word2Int# liveness_mask)),
mkIntCLit (if node_reqd then 1 else 0)])
then yield_code
else absC AbsCNop
where
- liveness_mask = mkRegLiveness regs
+ liveness_mask = mkRegLiveness regs 0 0
yield_code =
absC (CMacroStmt GRAN_YIELD
[mkIntCLit (I# (word2Int# liveness_mask))])
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.18 2002/09/13 15:02:28 simonpj Exp $
+% $Id: CgLetNoEscape.lhs,v 1.19 2002/12/11 15:36:26 simonmar Exp $
%
%********************************************************
%* *
bindNewToStack, buildContLivenessMask, CgIdInfo,
nukeDeadBindings
)
-import CgHeapery ( altHeapCheck )
+import CgHeapery ( unbxTupleHeapCheck )
import CgRetConv ( assignRegs )
-import CgStackery ( mkTaggedVirtStkOffsets,
+import CgStackery ( mkVirtStkOffsets,
allocStackTop, deAllocStackTop, freeStackSlots )
import CgUsages ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
import CLabel ( mkReturnInfoLabel )
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
+import Name ( getName )
import Id ( idPrimRep, Id )
import Var ( idUnique )
-import PrimRep ( PrimRep(..), retPrimRepSize )
+import PrimRep ( PrimRep(..), retPrimRepSize, isFollowableRep )
import BasicTypes ( RecFlag(..) )
import Unique ( Unique )
import Util ( splitAtList )
+
+import List ( partition )
\end{code}
%************************************************************************
nukeDeadBindings full_live_in_rhss)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
- buildContLivenessMask uniq `thenFC` \ liveness ->
+ buildContLivenessMask (getName binder) `thenFC` \ liveness ->
forkAbsC (cgLetNoEscapeBody binder cc args body uniq)
`thenFC` \ code ->
getSRTInfo srt `thenFC` \ srt_info ->
-- this is where the stack frame lives:
getRealSp `thenFC` \sp ->
+ -- This is very much like bindUnboxedTupleComponents (ToDo)
let
arg_kinds = map idPrimRep all_args
(arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
(reg_args, stk_args) = splitAtList arg_regs all_args
- (sp_stk_args, stk_offsets, stk_tags)
- = mkTaggedVirtStkOffsets sp idPrimRep stk_args
+ -- separate the rest of the args into pointers and non-pointers
+ ( ptr_args, nptr_args ) =
+ partition (isFollowableRep . idPrimRep) stk_args
+
+ (ptr_sp, ptr_offsets) = mkVirtStkOffsets sp idPrimRep ptr_args
+ (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
+
+ ptrs = ptr_sp - sp
+ nptrs = nptr_sp - ptr_sp
in
-- Bind args to appropriate regs/stk locns
bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack stk_offsets `thenC`
- setRealAndVirtualSp sp_stk_args `thenC`
+ mapCs bindNewToStack ptr_offsets `thenC`
+ mapCs bindNewToStack nptr_offsets `thenC`
- -- free up the stack slots containing tags, and the slot
- -- containing the return address (really frame header).
- -- c.f. CgCase.cgUnboxedTupleAlt.
- freeStackSlots (sp : map fst stk_tags) `thenC`
+ setRealAndVirtualSp nptr_sp `thenC`
+
+ -- free up the stack slots containing the return address
+ -- (frame header itbl). c.f. CgCase.cgUnboxedTupleAlt.
+ freeStackSlots [sp] `thenC`
-- Enter the closures cc, if required
--enterCostCentreCode closure_info cc IsFunction `thenC`
-- Do heap check [ToDo: omit for non-recursive case by recording in
-- in envt and absorbing at call site]
- altHeapCheck False True arg_regs stk_tags frame_hdr_asst (Just uniq) (
+ unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst (
cgExpr body
)
-
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.35 2002/09/13 15:02:28 simonpj Exp $
+% $Id: CgMonad.lhs,v 1.36 2002/12/11 15:36:26 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
import {-# SOURCE #-} CgUsages ( getSpRelOffset )
import AbsCSyn
+import CLabel
import StgSyn ( SRT(..) )
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
import Module ( Module )
import DataCon ( ConTag )
import Id ( Id )
-- addressing mode (I think)
SemiTaggingStuff
- | SeqFrame -- like CaseAlts but push a seq frame too.
- CAddrMode
- SemiTaggingStuff
+ Bool -- True <=> polymorphic, push a SEQ frame too
+
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
returnFC (CVal sp_rel RetRep)
sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
-sequelToAmode (CaseAlts amode _) = returnFC amode
-sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
+
+sequelToAmode (CaseAlts amode _ False) = returnFC amode
+sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep)
type CgStksAndHeapUsage -- stacks and heap usage information
= (StackUsage, HeapUsage)
#endif
type StackUsage =
- (Int, -- virtSp: Virtual offset of topmost allocated slot
- [(Int,Slot)], -- free: List of free slots, in increasing order
- Int, -- realSp: Virtual offset of real stack pointer
- Int) -- hwSp: Highest value ever taken by virtSp
+ (Int, -- virtSp: Virtual offset of topmost allocated slot
+ Int, -- frameSp: End of the current stack frame
+ [(Int,Slot)], -- free: List of free slots, in increasing order
+ Int, -- realSp: Virtual offset of real stack pointer
+ Int) -- hwSp: Highest value ever taken by virtSp
type HeapUsage =
(HeapOffset, -- virtHp: Virtual offset of highest-allocated word
initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (0,0))
+initUsage = ((0,0,[],0,0), (0,0))
\end{code}
-"envInitForAlternatives" initialises the environment for a case alternative,
-assuming that the alternative is entered after an evaluation.
-This involves:
-
- - zapping any volatile bindings, which aren't valid.
-
- - zapping the heap usage. It should be restored by a heap check.
-
- - setting the virtual AND real stack pointer fields to the given
- virtual stack offsets. this doesn't represent any {\em code}; it is a
- prediction of where the real stack pointer will be when we come back
- from the case analysis.
-
- - BUT LEAVING the rest of the stack-usage info because it is all
- valid. In particular, we leave the tail stack pointers unchanged,
- becuase the alternative has to de-allocate the original @case@
- expression's stack. \end{itemize}
-
@stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
marks found in $e_2$.
\begin{code}
stateIncUsage :: CgState -> CgState -> CgState
-stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
- (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
+stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1)))
+ (MkCgState _ _ ((_,_,_,_,h2),(vH2, _)))
= MkCgState abs_c
bs
- ((v,f,r,h1 `max` h2),
+ ((v,t,f,r,h1 `max` h2),
(vH1 `max` vH2, rH1))
\end{code}
do
info_down <- getInfoDown
(MkCgState absC1 bs usage) <- getState
- let ((),MkCgState absC2 _ ((_, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
- let ((v, f, r, h1), heap_usage) = usage
- let new_usage = ((v, f, r, h1 `max` h2), heap_usage)
+ let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
+ let ((v, t, f, r, h1), heap_usage) = usage
+ let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage)
setState $ MkCgState absC1 bs new_usage
return absC2
\end{code}
info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
state <- getState
let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
- let (_,MkCgState _ binds ((v,f,_,_),_)) =
+ let (_,MkCgState _ binds ((v,t,f,_,_),_)) =
doFCode env_code info_down_for_body state
let state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((v,f,v,v), (0,0))
+ ((v,t,f,v,v), (0,0))
let (value_returned, state_at_end_return) =
doFCode body_code info_down_for_body state_for_body
setState $ state `stateIncUsageEval` state_at_end_return
return (v,value_returned)
stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
- (MkCgState absC2 _ ((_,_,_,h2), _))
+stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage))
+ (MkCgState absC2 _ ((_,_,_,_,h2), _))
= MkCgState (absC1 `mkAbsCStmts` absC2)
-- The AbsC coming back should consist only of nested declarations,
-- notably of the return vector!
bs
- ((v,f,r,h1 `max` h2), heap_usage)
+ ((v,t,f,r,h1 `max` h2), heap_usage)
-- We don't max the heap high-watermark because stateIncUsageEval is
-- used only in forkEval, which in turn is only used for blocks of code
-- which do their own heap-check.
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.22 2002/09/13 15:02:29 simonpj Exp $
+% $Id: CgStackery.lhs,v 1.23 2002/12/11 15:36:27 simonmar Exp $
%
\section[CgStackery]{Stack management functions}
\begin{code}
module CgStackery (
allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
- adjustStackHW, getFinalStackHW,
- mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
+ adjustStackHW, getFinalStackHW,
+ setStackFrame, getStackFrame,
+ mkVirtStkOffsets, mkStkAmodes,
freeStackSlots, dataStackSlots, addFreeSlots,
- updateFrameSize, seqFrameSize
+ updateFrameSize,
+ constructSlowCall, slowArgs,
) where
#include "HsVersions.h"
import CgMonad
import AbsCSyn
+import CLabel ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel )
import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
+import PrimRep
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import Panic ( panic )
import Constants
import Util ( sortLt )
-
+import FastString ( LitString )
+import Panic
+
import TRACE ( trace )
\end{code}
%* *
%************************************************************************
-@mkTaggedVirtStkOffsets@ is given a list of arguments. The first
-argument gets the {\em largest} virtual stack offset (remember,
-virtual offsets increase towards the top of stack). This function
-also computes the correct tagging arrangement for standard function
-entry points. Each non-pointer on the stack is preceded by a tag word
-indicating the number of non-pointer words above it on the stack.
-
- offset --> | | <---- last allocated stack word
- --------- <
- | | .
- --------- .
- | | total_nptrs (words)
- --------- .
- | | .
- --------- <
-offset + tot_nptrs + 1 --> | tag |
- ---------
+'mkVirtStkOffsets' is given a list of arguments. The first argument
+gets the /largest/ virtual stack offset (remember, virtual offsets
+increase towards the top of stack).
\begin{code}
-mkTaggedVirtStkOffsets
+mkVirtStkOffsets
:: VirtualSpOffset -- Offset of the last allocated thing
-> (a -> PrimRep) -- to be able to grab kinds
-> [a] -- things to make offsets for
-> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
- [(a, VirtualSpOffset)], -- things with offsets
- [(VirtualSpOffset,Int)]) -- offsets for tags
+ [(a, VirtualSpOffset)]) -- things with offsets
-mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
- = loop init_Sp_offset [] [] (reverse things)
+mkVirtStkOffsets init_Sp_offset kind_fun things
+ = loop init_Sp_offset [] (reverse things)
where
- loop offset tags offs [] = (offset,offs,tags)
- loop offset tags offs (t:things)
- | isFollowableRep (kind_fun t) =
- loop (offset+1) tags ((t,offset+1):offs) things
- | otherwise =
+ loop offset offs [] = (offset,offs)
+ loop offset offs (t:things) =
let
size = getPrimRepSize (kind_fun t)
- tag_slot = offset+size+1
+ thing_slot = offset + size
in
- loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
+ loop thing_slot ((t,thing_slot):offs) things
-- offset of thing is offset+size, because we're growing the stack
-- *downwards* as the offsets increase.
-\end{code}
-@mkTaggedStkAmodes@ is a higher-level version of
-@mkTaggedVirtStkOffsets@. It starts from the tail-call locations. It
-returns a single list of addressing modes for the stack locations, and
-therefore is in the monad.
-It *doesn't* adjust the high water mark.
+-- | 'mkStkAmodes' is a higher-level version of
+-- 'mkVirtStkOffsets'. It starts from the tail-call locations.
+-- It returns a single list of addressing modes for the stack
+-- locations, and therefore is in the monad. It /doesn't/ adjust the
+-- high water mark.
-\begin{code}
-mkTaggedStkAmodes
+mkStkAmodes
:: VirtualSpOffset -- Tail call positions
-> [CAddrMode] -- things to make offsets for
-> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
- AbstractC, -- Assignments to appropriate stk slots
- AbstractC) -- Assignments for tagging
+ AbstractC) -- Assignments to appropriate stk slots
-mkTaggedStkAmodes tail_Sp things
+mkStkAmodes tail_Sp things
= getRealSp `thenFC` \ realSp ->
let
- (last_Sp_offset, offsets, tags)
- = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
+ (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things
abs_cs =
[ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
| (thing, offset) <- offsets
]
-
- tag_cs =
- [ CAssign (CVal (spRel realSp offset) WordRep)
- (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
- | (offset,size) <- tags
- ]
in
- returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
+ returnFC (last_Sp_offset, mkAbstractCs abs_cs)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Pushing the arguments for a slow call}
+%* *
+%************************************************************************
-mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
-mkTagAssts tags =
- getRealSp `thenFC` \realSp ->
- returnFC (mkAbstractCs
- [ CAssign (CVal (spRel realSp offset) WordRep)
- (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
- | (offset,size) <- tags
- ])
+For a slow call, we must take a bunch of arguments and intersperse
+some stg_ap_<pattern>_ret_info return addresses.
+\begin{code}
+constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode])
+ -- don't forget the zero case
+constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , [])
+constructSlowCall amodes =
+ -- traceSlowCall amodes $
+ (CLbl lbl CodePtrRep, these ++ slowArgs rest)
+ where (tag, these, rest) = matchSlowPattern amodes
+ lbl = mkRtsApplyEntryLabel tag
+
+stg_ap_0 = mkRtsApplyEntryLabel SLIT("0")
+
+-- | 'slowArgs' takes a list of function arguments and prepares them for
+-- pushing on the stack for "extra" arguments to a function which requires
+-- fewer arguments than we currently have.
+slowArgs :: [CAddrMode] -> [CAddrMode]
+slowArgs [] = []
+slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest
+ where (tag, args, rest) = matchSlowPattern amodes
+ lbl = mkRtsApplyInfoLabel tag
+
+matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode])
+matchSlowPattern amodes = (tag, these, rest)
+ where reps = map getAmodeRep amodes
+ (tag, n) = findMatch (map primRepToArgRep reps)
+ (these, rest) = splitAt n amodes
+
+-- These cases were found to cover about 99% of all slow calls:
+findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7)
+findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("pppppp"), 6)
+findMatch (RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppp"), 5)
+findMatch (RepP: RepP: RepP: RepP: _) = (SLIT("pppp"), 4)
+findMatch (RepP: RepP: RepP: _) = (SLIT("ppp"), 3)
+findMatch (RepP: RepP: RepV: _) = (SLIT("ppv"), 3)
+findMatch (RepP: RepP: _) = (SLIT("pp"), 2)
+findMatch (RepP: RepV: _) = (SLIT("pv"), 2)
+findMatch (RepP: _) = (SLIT("p"), 1)
+findMatch (RepV: _) = (SLIT("v"), 1)
+findMatch (RepN: _) = (SLIT("n"), 1)
+findMatch (RepF: _) = (SLIT("f"), 1)
+findMatch (RepD: _) = (SLIT("d"), 1)
+findMatch (RepL: _) = (SLIT("l"), 1)
+findMatch _ = panic "CgStackery.findMatch"
+
+#ifdef DEBUG
+primRepChar p | isFollowableRep p = 'p'
+primRepChar VoidRep = 'v'
+primRepChar FloatRep = 'f'
+primRepChar DoubleRep = 'd'
+primRepChar p | getPrimRepSize p == 1 = 'n'
+primRepChar p | is64BitRep p = 'l'
+
+traceSlowCall amodes and_then
+ = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then
+#endif
\end{code}
%************************************************************************
allocPrimStack :: Int -> FCode VirtualSpOffset
allocPrimStack size = do
- ((virt_sp, free_stk, real_sp, hw_sp),h_usage) <- getUsage
+ ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage
let push_virt_sp = virt_sp + size
let (chosen_slot, new_stk_usage) =
case find_block free_stk of
- Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
- hw_sp `max` push_virt_sp))
+ Nothing -> (push_virt_sp,
+ (push_virt_sp, frame, free_stk, real_sp,
+ hw_sp `max` push_virt_sp))
-- Adjust high water mark
- Just slot -> (slot, (virt_sp,
- delete_block free_stk slot, real_sp, hw_sp))
+ Just slot -> (slot,
+ (virt_sp, frame,
+ delete_block free_stk slot,
+ real_sp, hw_sp))
setUsage (new_stk_usage, h_usage)
return chosen_slot
\begin{code}
allocStackTop :: Int -> FCode VirtualSpOffset
allocStackTop size = do
- ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
+ ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
let push_virt_sp = virt_sp + size
- let new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
+ let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp,
+ hw_sp `max` push_virt_sp)
setUsage (new_stk_usage, h_usage)
return push_virt_sp
\end{code}
\begin{code}
deAllocStackTop :: Int -> FCode VirtualSpOffset
deAllocStackTop size = do
- ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
+ ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
let pop_virt_sp = virt_sp - size
- let new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
+ let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp)
setUsage (new_stk_usage, h_usage)
return pop_virt_sp
\end{code}
\begin{code}
adjustStackHW :: VirtualSpOffset -> Code
adjustStackHW offset = do
- ((vSp,fSp,realSp,hwSp), h_usage) <- getUsage
- setUsage ((vSp, fSp, realSp, max offset hwSp), h_usage)
+ ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage
+ setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage)
\end{code}
A knot-tying beast.
getFinalStackHW fcode = do
fixC (\hwSp -> do
fcode hwSp
- ((_,_,_, hwSp),_) <- getUsage
+ ((_,_,_,_, hwSp),_) <- getUsage
return hwSp)
return ()
\end{code}
\begin{code}
+setStackFrame :: VirtualSpOffset -> Code
+setStackFrame offset = do
+ ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage
+ setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage)
+
+getStackFrame :: FCode VirtualSpOffset
+getStackFrame = do
+ ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
+ return frame
+\end{code}
+
+\begin{code}
updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
| opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
| otherwise = uF_SIZE
-
-seqFrameSize | opt_SccProfilingOn = pROF_SEQ_FRAME_SIZE
- | opt_GranMacros = gRAN_SEQ_FRAME_SIZE
- | otherwise = sEQ_FRAME_SIZE
\end{code}
%************************************************************************
\begin{code}
addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
addFreeStackSlots extra_free slot = do
- ((vsp, free, real, hw),heap_usage) <- getUsage
+ ((vsp, frame,free, real, hw),heap_usage) <- getUsage
let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
let (new_vsp, new_free) = trim vsp all_free
- let new_usage = ((new_vsp, new_free, real, hw), heap_usage)
+ let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage)
setUsage new_usage
freeStackSlots :: [VirtualSpOffset] -> Code
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.35 2002/10/25 16:54:56 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.36 2002/12/11 15:36:27 simonmar Exp $
%
%********************************************************
%* *
\begin{code}
module CgTailCall (
- cgTailCall,
+ cgTailCall, performTailCall,
performReturn, performPrimReturn,
mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
- mkUnboxedTupleReturnCode, returnUnboxedTuple,
+ returnUnboxedTuple, ccallReturnUnboxedTuple,
mkPrimReturnCode,
-
- tailCallFun,
tailCallPrimOp,
- doTailCall,
pushReturnAddress
) where
#include "HsVersions.h"
import CgMonad
-import AbsCSyn
-
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgRetConv ( dataReturnConvPrim,
- ctrlReturnConvAlg, CtrlReturnConvention(..),
- assignAllRegs, assignRegs
- )
-import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
+import CgRetConv
+import CgStackery
import CgUsages ( getSpRelOffset, adjustSpAndHp )
-import CgUpdate ( pushSeqFrame )
-import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel )
-import ClosureInfo ( nodeMustPointToIt,
- getEntryConvention, EntryConvention(..), LambdaFormInfo
- )
-import CmdLineOpts ( opt_DoSemiTagging )
+import ClosureInfo
+
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import AbsCSyn
+import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel, mkSeqInfoLabel )
+
import Id ( Id, idType, idName )
import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg )
import Type ( isUnLiftedType )
+import Name ( Name )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
import Util ( zipWithEqual, splitAtList )
import ListSetOps ( assocMaybe )
+import PrimRep ( isFollowableRep )
import Outputable
import Panic ( panic, assertPanic )
-\end{code}
-%************************************************************************
-%* *
-\subsection[tailcall-doc]{Documentation}
-%* *
-%************************************************************************
+import List ( partition )
+
+-----------------------------------------------------------------------------
+-- Tail Calls
-\begin{code}
cgTailCall :: Id -> [StgArg] -> Code
-\end{code}
-Here's the code we generate for a tail call. (NB there may be no
-arguments, in which case this boils down to just entering a variable.)
-
-\begin{itemize}
-\item Adjust the stack ptr to \tr{tailSp + #args}.
-\item Put args in the top locations of the resulting stack.
-\item Make Node point to the function closure.
-\item Enter the function closure.
-\end{itemize}
-
-Things to be careful about:
-\begin{itemize}
-\item Don't overwrite stack locations before you have finished with
- them (remember you need the function and the as-yet-unmoved
- arguments).
-\item Preferably, generate no code to replace x by x on the stack (a
- common situation in tail-recursion).
-\item Adjust the stack high water mark appropriately.
-\end{itemize}
-
-Treat unboxed locals exactly like literals (above) except use the addr
-mode for the local instead of (CLit lit) in the assignment.
-
-Case for unboxed @Ids@ first:
-\begin{code}
+-- Here's the code we generate for a tail call. (NB there may be no
+-- arguments, in which case this boils down to just entering a variable.)
+--
+-- * Put args in the top locations of the stack.
+-- * Adjust the stack ptr
+-- * Make R1 point to the function closure if necessary.
+-- * Perform the call.
+--
+-- Things to be careful about:
+--
+-- * Don't overwrite stack locations before you have finished with
+-- them (remember you need the function and the as-yet-unmoved
+-- arguments).
+-- * Preferably, generate no code to replace x by x on the stack (a
+-- common situation in tail-recursion).
+-- * Adjust the stack high water mark appropriately.
+--
+-- Treat unboxed locals exactly like literals (above) except use the addr
+-- mode for the local instead of (CLit lit) in the assignment.
+
+-- Case for unboxed returns first:
cgTailCall fun []
| isUnLiftedType (idType fun)
= getCAddrMode fun `thenFC` \ amode ->
performPrimReturn (ppr fun) amode
-\end{code}
-The general case (@fun@ is boxed):
-\begin{code}
-cgTailCall fun args = performTailCall fun args
-\end{code}
+-- The general case (@fun@ is boxed):
+cgTailCall fun args
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ performTailCall fun' fun_amode lf_info arg_amodes AbsCNop
-%************************************************************************
-%* *
-\subsection[return-and-tail-call]{Return and tail call}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- The guts of a tail-call
+
+performTailCall
+ :: Id -- function
+ -> CAddrMode -- function amode
+ -> LambdaFormInfo
+ -> [CAddrMode]
+ -> AbstractC -- Pending simultaneous assignments
+ -- *** GUARANTEED to contain only stack assignments.
+ -> Code
+
+performTailCall fun fun_amode lf_info arg_amodes pending_assts =
+ nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ let
+ -- assign to node if necessary
+ node_asst
+ | node_points = CAssign (CReg node) fun_amode
+ | otherwise = AbsCNop
+ in
+
+ getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+
+ let
+ -- set up for a let-no-escape if necessary
+ join_sp = case fun_amode of
+ CJoinPoint sp -> sp
+ other -> args_sp
+ in
+
+ -- decide how to code the tail-call: which registers assignments to make,
+ -- what args to push on the stack, and how to make the jump
+ constructTailCall (idName fun) lf_info arg_amodes join_sp
+ node_points fun_amode sequel
+ `thenFC` \ (final_sp, arg_assts, jump_code) ->
+
+ let sim_assts = mkAbstractCs [node_asst,
+ pending_assts,
+ arg_assts]
+
+ is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False }
+ in
+
+ doFinalJump final_sp sim_assts is_lne (const jump_code)
+
+
+-- Figure out how to do a particular tail-call.
+
+constructTailCall
+ :: Name
+ -> LambdaFormInfo
+ -> [CAddrMode]
+ -> VirtualSpOffset -- Sp at which to make the call
+ -> Bool -- node points to the fun closure?
+ -> CAddrMode -- addressing mode of the function
+ -> Sequel -- the sequel, in case we need it
+ -> FCode (
+ VirtualSpOffset, -- Sp after pushing the args
+ AbstractC, -- assignments
+ Code -- code to do the jump
+ )
+
+constructTailCall name lf_info arg_amodes sp node_points fun_amode sequel =
+
+ getEntryConvention name lf_info (map getAmodeRep arg_amodes)
+ `thenFC` \ entry_conv ->
+
+ case entry_conv of
+ EnterIt -> returnFC (sp, AbsCNop, code)
+ where code = profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
+ absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
+ [CVal (nodeRel 0) DataPtrRep]))
+
+ -- A function, but we have zero arguments. It is already in WHNF,
+ -- so we can just return it.
+ ReturnIt -> returnFC (sp, asst, code)
+ where -- if node doesn't already point to the closure, we have to
+ -- load it up.
+ asst | node_points = AbsCNop
+ | otherwise = CAssign (CReg node) fun_amode
+
+ code = sequelToAmode sequel `thenFC` \ dest_amode ->
+ absC (CReturn dest_amode DirectReturn)
+
+ JumpToIt lbl -> returnFC (sp, AbsCNop, code)
+ where code = absC (CJump (CLbl lbl CodePtrRep))
+
+ -- a slow function call via the RTS apply routines
+ SlowCall ->
+ let (apply_fn, new_amodes) = constructSlowCall arg_amodes
+
+ -- if node doesn't already point to the closure,
+ -- we have to load it up.
+ node_asst | node_points = AbsCNop
+ | otherwise = CAssign (CReg node) fun_amode
+ in
+
+ -- Fill in all the arguments on the stack
+ mkStkAmodes sp new_amodes `thenFC`
+ \ (final_sp, stk_assts) ->
+
+ returnFC
+ (final_sp + 1, -- add one, because the stg_ap functions
+ -- expect there to be a free slot on the stk
+ mkAbstractCs [node_asst, stk_assts],
+ absC (CJump apply_fn)
+ )
+
+ -- A direct function call (possibly with some left-over arguments)
+ DirectEntry lbl arity regs
+
+ -- A let-no-escape is slightly different, because we
+ -- arrange the stack arguments into pointers and non-pointers
+ -- to make the heap check easier. The tail-call sequence
+ -- is very similar to returning an unboxed tuple, so we
+ -- share some code.
+ | is_let_no_escape ->
+ pushUnboxedTuple sp arg_amodes `thenFC` \ (final_sp, assts) ->
+ returnFC (final_sp, assts, absC (CJump (CLbl lbl CodePtrRep)))
+
+
+ -- A normal fast call
+ | otherwise ->
+ let
+ -- first chunk of args go in registers
+ (reg_arg_amodes, stk_arg_amodes) =
+ splitAtList regs arg_amodes
+
+ -- the rest of this function's args go straight on the stack
+ (stk_args, extra_stk_args) =
+ splitAt (arity - length regs) stk_arg_amodes
+
+ -- any "extra" arguments are placed in frames on the
+ -- stack after the other arguments.
+ slow_stk_args = slowArgs extra_stk_args
+
+ reg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2"
+ assign_to_reg regs reg_arg_amodes)
+
+ in
+ mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC`
+ \ (final_sp, stk_assts) ->
+
+ returnFC
+ (final_sp,
+ mkAbstractCs [reg_assts, stk_assts],
+ absC (CJump (CLbl lbl CodePtrRep))
+ )
+
+ where is_let_no_escape = case fun_amode of
+ CJoinPoint _ -> True
+ _ -> False
+
+-- -----------------------------------------------------------------------------
+-- The final clean-up before we do a jump at the end of a basic block.
+-- This code is shared by tail-calls and returns.
+
+doFinalJump :: VirtualSpOffset -> AbstractC -> Bool -> (Sequel -> Code) -> Code
+doFinalJump final_sp sim_assts is_let_no_escape jump_code =
+
+ -- adjust the high-water mark if necessary
+ adjustStackHW final_sp `thenC`
+
+ -- Do the simultaneous assignments,
+ absC (CSimultaneous sim_assts) `thenC`
+
+ -- push a return address if necessary (after the assignments
+ -- above, in case we clobber a live stack location)
+ --
+ -- DONT push the return address when we're about to jump to a
+ -- let-no-escape: the final tail call in the let-no-escape
+ -- will do this.
+ getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+ (if is_let_no_escape then nopC
+ else pushReturnAddress eob) `thenC`
+
+ -- Final adjustment of Sp/Hp
+ adjustSpAndHp final_sp `thenC`
+
+ -- and do the jump
+ jump_code sequel
+
+-- -----------------------------------------------------------------------------
+-- A general return (just a special case of doFinalJump, above)
+
+performReturn :: AbstractC -- Simultaneous assignments to perform
+ -> (Sequel -> Code) -- The code to execute to actually do
+ -- the return, given an addressing mode
+ -- for the return address
+ -> Code
+
+performReturn sim_assts finish_code
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+ doFinalJump args_sp sim_assts False{-not a LNE-} finish_code
+
+-- -----------------------------------------------------------------------------
+-- Primitive Returns
+
+-- Just load the return value into the right register, and return.
+
performPrimReturn :: SDoc -- Just for debugging (sigh)
-> CAddrMode -- The thing to return
-> Code
ret_reg = dataReturnConvPrim kind
assign_possibly = case kind of
- VoidRep -> AbsCNop
- kind -> (CAssign (CReg ret_reg) amode)
+ VoidRep -> AbsCNop
+ kind -> (CAssign (CReg ret_reg) amode)
in
performReturn assign_possibly (mkPrimReturnCode doc)
absC (CReturn dest_amode DirectReturn)
-- Direct, no vectoring
+-- -----------------------------------------------------------------------------
+-- Algebraic constructor returns
+
-- Constructor is built on the heap; Node is set.
-- All that remains is
-- (a) to set TagReg, if necessary
absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
return_info)
- CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
+ CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so
-- we can go right to the alternative
case assocMaybe alts tag of
-- it's the subject of a wad of special-case
-- code in cgReturnCon
- -- can't be a SeqFrame, because we're returning a constructor
-
other -> -- OnStack, or (CaseAlts ret_amode Nothing)
sequelToAmode sequel `thenFC` \ ret_amode ->
absC (CReturn ret_amode return_info)
UnvectoredReturn _ -> DirectReturn
VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
-mkUnboxedTupleReturnCode :: Sequel -> Code
-mkUnboxedTupleReturnCode sequel
- = case sequel of
- -- can't update with an unboxed tuple!
- UpdateCode -> panic "mkUnboxedTupleReturnCode"
-
- CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) ->
- absC (CJump (CLbl join_lbl CodePtrRep))
-
- -- can't be a SeqFrame
- other -> -- OnStack, or (CaseAlts ret_amode something)
- sequelToAmode sequel `thenFC` \ ret_amode ->
- absC (CReturn ret_amode DirectReturn)
+-- -----------------------------------------------------------------------------
+-- Returning an enumerated type from a PrimOp
-- This function is used by PrimOps that return enumerated types (i.e.
-- all the comparison operators).
sequelToAmode sequel `thenFC` \ ret_addr ->
-- Generate the right jump or return
absC (CReturn ret_addr DirectReturn)
-\end{code}
-
-\begin{code}
-performReturn :: AbstractC -- Simultaneous assignments to perform
- -> (Sequel -> Code) -- The code to execute to actually do
- -- the return, given an addressing mode
- -- for the return address
- -> Code
-
--- this is just a special case of doTailCall, later.
-performReturn sim_assts finish_code
- = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- -- Do the simultaneous assignments,
- doSimAssts sim_assts `thenC`
- -- push a return address if necessary
- -- (after the assignments above, in case we clobber a live
- -- stack location)
- pushReturnAddress eob `thenC`
+-- ---------------------------------------------------------------------------
+-- Unboxed tuple returns
- -- Adjust Sp/Hp
- adjustSpAndHp args_sp `thenC`
+-- These are a bit like a normal tail call, except that:
+--
+-- - The tail-call target is an info table on the stack
+--
+-- - We separate stack arguments into pointers and non-pointers,
+-- to make it easier to leave things in a sane state for a heap check.
+-- This is OK because we can never partially-apply an unboxed tuple,
+-- unlike a function. The same technique is used when calling
+-- let-no-escape functions, because they also can't be partially
+-- applied.
- -- Do the return
- finish_code sequel -- "sequel" is `robust' in that it doesn't
- -- depend on stk-ptr values
-\end{code}
+returnUnboxedTuple :: [CAddrMode] -> Code
+returnUnboxedTuple amodes =
+ getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-Returning unboxed tuples. This is mainly to support _ccall_GC_, where
-we want to do things in a slightly different order to normal:
+ profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
- - push return address
- - adjust stack pointer
- - r = call(args...)
- - assign regs for unboxed tuple (usually just R1 = r)
- - return to continuation
+ pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) ->
+ doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode
-The return address (i.e. stack frame) must be on the stack before
-doing the call in case the call ends up in the garbage collector.
-Sadly, the information about the continuation is lost after we push it
-(in order to avoid pushing it again), so we end up doing a needless
-indirect jump (ToDo).
+pushUnboxedTuple
+ :: VirtualSpOffset -- Sp at which to start pushing
+ -> [CAddrMode] -- amodes of the components
+ -> FCode (VirtualSpOffset, -- final Sp
+ AbstractC) -- assignments (regs+stack)
-\begin{code}
-returnUnboxedTuple :: [CAddrMode] -> Code -> Code
-returnUnboxedTuple amodes before_jump
- = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-
- -- push a return address if necessary
- pushReturnAddress eob `thenC`
- setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
+pushUnboxedTuple sp amodes =
+ let
+ (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes)
- -- Adjust Sp/Hp
- adjustSpAndHp args_sp `thenC`
+ (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes
- before_jump `thenC`
+ -- separate the rest of the args into pointers and non-pointers
+ ( ptr_args, nptr_args ) =
+ partition (isFollowableRep . getAmodeRep) stk_arg_amodes
- let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
+ reg_arg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2"
+ assign_to_reg arg_regs reg_arg_amodes)
in
- profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
-
- doTailCall amodes ret_regs
- mkUnboxedTupleReturnCode
- (length leftovers) {- fast args arity -}
- AbsCNop {-no pending assigments-}
- Nothing {-not a let-no-escape-}
- False {-node doesn't point-}
- )
-\end{code}
-
-\begin{code}
-performTailCall :: Id -> [StgArg] -> Code
-performTailCall fun args
- = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
- tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
-\end{code}
-
-Generating code for a tail call to a function (or closure)
-
-\begin{code}
-tailCallFun
- :: Id -- Function
- -> CAddrMode
- -> LambdaFormInfo
- -> [CAddrMode] -- Arguments
- -> AbstractC -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack
- -- assignments.
- -- In ptic, we don't need to look in
- -- here to discover all live regs
- -> Code
-
-tailCallFun fun fun_amode lf_info arg_amodes pending_assts
- = nodeMustPointToIt lf_info `thenFC` \ node_points ->
- -- we use the name of fun', the Id from the environment, rather than
- -- fun from the STG tree, in case it is a top-level name that we externalised
- -- (see cgTopRhsClosure).
- getEntryConvention (idName fun) lf_info
- (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
- let
- node_asst
- = if node_points then
- CAssign (CReg node) fun_amode
- else
- AbsCNop
-
- (arg_regs, finish_code, arity)
- = case entry_conv of
- ViaNode ->
- ([],
- profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
- absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
- [CVal (nodeRel 0) DataPtrRep]))
- , 0)
- StdEntry lbl -> ([], absC (CJump (CLbl lbl CodePtrRep)), 0)
- DirectEntry lbl arity regs ->
- (regs, absC (CJump (CLbl lbl CodePtrRep)),
- arity - length regs)
+ -- push ptrs, then nonptrs, on the stack
+ mkStkAmodes sp ptr_args `thenFC` \ (ptr_sp, ptr_assts) ->
+ mkStkAmodes ptr_sp nptr_args `thenFC` \ (final_sp, nptr_assts) ->
- -- set up for a let-no-escape if necessary
- join_sp = case fun_amode of
- CJoinPoint sp -> Just sp
- other -> Nothing
- in
- doTailCall arg_amodes arg_regs (const finish_code) arity
- (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
+ returnFC (final_sp,
+ mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts])
+
+
+mkUnboxedTupleReturnCode :: Sequel -> Code
+mkUnboxedTupleReturnCode sequel
+ = case sequel of
+ -- can't update with an unboxed tuple!
+ UpdateCode -> panic "mkUnboxedTupleReturnCode"
--- this generic tail call code is used for both function calls and returns.
+ CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False ->
+ absC (CJump (CLbl join_lbl CodePtrRep))
-doTailCall
- :: [CAddrMode] -- args to pass to function
- -> [MagicId] -- registers to use
- -> (Sequel->Code) -- code to perform jump
- -> Int -- number of "fast" stack arguments
- -> AbstractC -- pending assignments
- -> Maybe VirtualSpOffset -- sp offset to trim stack to:
- -- USED iff destination is a let-no-escape
- -> Bool -- node points to the closure to enter
- -> Code
+ other -> -- OnStack, or (CaseAlts ret_amode something)
+ sequelToAmode sequel `thenFC` \ ret_amode ->
+ absC (CReturn ret_amode DirectReturn)
-doTailCall arg_amodes arg_regs finish_code arity pending_assts
- maybe_join_sp node_points
+-- -----------------------------------------------------------------------------
+-- Returning unboxed tuples. This is mainly to support _ccall_GC_, where
+-- we want to do things in a slightly different order to normal:
+--
+-- - push return address
+-- - adjust stack pointer
+-- - r = call(args...)
+-- - assign regs for unboxed tuple (usually just R1 = r)
+-- - return to continuation
+--
+-- The return address (i.e. stack frame) must be on the stack before
+-- doing the call in case the call ends up in the garbage collector.
+--
+-- Sadly, the information about the continuation is lost after we push it
+-- (in order to avoid pushing it again), so we end up doing a needless
+-- indirect jump (ToDo).
+
+ccallReturnUnboxedTuple :: [CAddrMode] -> Code -> Code
+ccallReturnUnboxedTuple amodes before_jump
= getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- let
- (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs arg_amodes
- -- We get some stk_arg_amodes if (a) no regs, or
- -- (b) args beyond arity
-
- reg_arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg2"
- assign_to_reg arg_regs reg_arg_amodes)
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
- join_sp = case maybe_join_sp of
- Just sp -> ASSERT(not (args_sp > sp)) sp
- -- If ASSERTion fails: Oops: the join point has *lower*
- -- stack ptrs than the continuation Note that we take
- -- the Sp point without the return address here. The
- -- return address is put on by the let-no-escapey thing
- -- when it finishes.
- Nothing -> args_sp
-
- (fast_stk_amodes, tagged_stk_amodes) =
- splitAt arity stk_arg_amodes
-
- -- eager blackholing, at the end of the basic block.
- (r1_tmp_asst, bh_asst)
- = case sequel of
-#if 0
- -- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
- -- we might be in a case continuation later down the line. Also,
- -- we might have pushed a return address on the stack, if we're in
- -- a case scrut, and still be in the thunk's entry code.
- UpdateCode ->
- (CAssign node_save nodeReg,
- CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep)
- PtrRep)
- (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
- where
- node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
-#endif
- _ -> (AbsCNop, AbsCNop)
- in
- -- We can omit tags on the arguments passed to the fast entry point,
- -- but we have to be careful to fill in the tags on any *extra*
- -- arguments we're about to push on the stack.
-
- mkTaggedStkAmodes join_sp tagged_stk_amodes `thenFC`
- \ (fast_sp, tagged_arg_assts, tag_assts) ->
-
- mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
- \ (final_sp, fast_arg_assts, _) ->
-
- -- adjust the high-water mark if necessary
- adjustStackHW final_sp `thenC`
-
- -- The stack space for the pushed return addess,
- -- with any args pushed on top, is recorded in final_sp.
-
- -- Do the simultaneous assignments,
- doSimAssts (mkAbstractCs [r1_tmp_asst,
- pending_assts,
- reg_arg_assts,
- fast_arg_assts,
- tagged_arg_assts,
- tag_assts]) `thenC`
- absC bh_asst `thenC`
-
- -- push a return address if necessary
- -- (after the assignments above, in case we clobber a live
- -- stack location)
-
- -- DONT push the return address when we're about
- -- to jump to a let-no-escape: the final tail call
- -- in the let-no-escape will do this.
- (if (maybeToBool maybe_join_sp)
- then nopC
- else pushReturnAddress eob) `thenC`
-
- -- Final adjustment of Sp/Hp
- adjustSpAndHp final_sp `thenC`
-
- -- Now decide about semi-tagging
- let
- semi_tagging_on = opt_DoSemiTagging
- in
- case (semi_tagging_on, arg_amodes, node_points, sequel) of
+ -- push a return address if necessary
+ pushReturnAddress eob `thenC`
+ setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
- --
- -- *************** The semi-tagging case ***************
- --
- {- XXX leave this out for now.
- ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
-
- -- Whoppee! Semi-tagging rules OK!
- -- (a) semi-tagging is switched on
- -- (b) there are no arguments,
- -- (c) Node points to the closure
- -- (d) we have a case-alternative sequel with
- -- some visible alternatives
-
- -- Why is test (c) necessary?
- -- Usually Node will point to it at this point, because we're
- -- scrutinsing something which is either a thunk or a
- -- constructor.
- -- But not always! The example I came across is when we have
- -- a top-level Double:
- -- lit.3 = D# 3.000
- -- ... (case lit.3 of ...) ...
- -- Here, lit.3 is built as a re-entrant thing, which you must enter.
- -- (OK, the simplifier should have eliminated this, but it's
- -- easy to deal with the case anyway.)
- let
- join_details_to_code (load_regs_and_profiling_code, join_lbl)
- = load_regs_and_profiling_code `mkAbsCStmts`
- CJump (CLbl join_lbl CodePtrRep)
-
- semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
- join_details_to_code join_details)
- | (tag, join_details) <- st_alts
- ]
-
- enter_jump
- -- Enter Node (we know infoptr will have the info ptr in it)!
- = mkAbstractCs [
- CCallProfCtrMacro FSLIT("RET_SEMI_FAILED")
- [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
- CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
- in
- -- Final switch
- absC (mkAbstractCs [
- CAssign (CReg infoptr)
- (CVal (NodeRel zeroOff) DataPtrRep),
-
- case maybe_deflt_join_details of
- Nothing ->
- CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
- (semi_tagged_alts)
- (enter_jump)
- Just (_, details) ->
- CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
- [(mkMachInt 0, enter_jump)]
- (CSwitch
- (CMacroExpr IntRep INFO_TAG [CReg infoptr])
- (semi_tagged_alts)
- (join_details_to_code details))
- ])
- -}
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
- --
- -- *************** The non-semi-tagging case ***************
- --
- other -> finish_code sequel
-\end{code}
+ before_jump `thenC`
+
+ returnUnboxedTuple amodes
+ )
-%************************************************************************
-%* *
-\subsection[tailCallPrimOp]{@tailCallPrimOp@}
-%* *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- Calling an out-of-line primop
-\begin{code}
tailCallPrimOp :: PrimOp -> [StgArg] -> Code
tailCallPrimOp op args =
-- we're going to perform a normal-looking tail call,
-- except that *all* the arguments will be in registers.
getArgAmodes args `thenFC` \ arg_amodes ->
let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
- in
- ASSERT(null leftovers) -- no stack-resident args
- doTailCall arg_amodes arg_regs
- (const (absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))))
- 0 {- arity shouldn't matter, all args in regs -}
- AbsCNop {- no pending assignments -}
- Nothing {- not a let-no-escape -}
- False {- node doesn't point -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[doSimAssts]{@doSimAssts@}
-%* *
-%************************************************************************
-
-@doSimAssts@ happens at the end of every block of code.
-They are separate because we sometimes do some jiggery-pokery in between.
-
-\begin{code}
-doSimAssts :: AbstractC -> Code
-doSimAssts sim_assts
- = absC (CSimultaneous sim_assts)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[retAddr]{@Return Addresses@}
-%* *
-%************************************************************************
+ reg_arg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2"
+ assign_to_reg arg_regs arg_amodes)
-We always push the return address just before performing a tail call
-or return. The reason we leave it until then is because the stack
-slot that the return address is to go into might contain something
-useful.
+ jump_to_primop =
+ absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))
+ in
-If the end of block info is CaseAlts, then we're in the scrutinee of a
-case expression and the return address is still to be pushed.
+ ASSERT(null leftovers) -- no stack-resident args
-There are cases where it doesn't look necessary to push the return
-address: for example, just before doing a return to a known
-continuation. However, the continuation will expect to find the
-return address on the stack in case it needs to do a heap check.
+ getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
+ doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop)
+
+-- -----------------------------------------------------------------------------
+-- Return Addresses
+
+-- | We always push the return address just before performing a tail call
+-- or return. The reason we leave it until then is because the stack
+-- slot that the return address is to go into might contain something
+-- useful.
+--
+-- If the end of block info is 'CaseAlts', then we're in the scrutinee of a
+-- case expression and the return address is still to be pushed.
+--
+-- There are cases where it doesn't look necessary to push the return
+-- address: for example, just before doing a return to a known
+-- continuation. However, the continuation will expect to find the
+-- return address on the stack in case it needs to do a heap check.
-\begin{code}
pushReturnAddress :: EndOfBlockInfo -> Code
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _)) =
+
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) =
getSpRelOffset args_sp `thenFC` \ sp_rel ->
absC (CAssign (CVal sp_rel RetRep) amode)
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(SeqFrame amode _)) =
- pushSeqFrame args_sp `thenFC` \ ret_sp ->
- getSpRelOffset ret_sp `thenFC` \ sp_rel ->
- absC (CAssign (CVal sp_rel RetRep) amode)
+
+-- For a polymorphic case, we have two return addresses to push: the case
+-- return, and stg_seq_frame_info which turns a possible vectored return
+-- into a direct one.
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ True)) =
+ getSpRelOffset (args_sp-1) `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) amode) `thenC`
+ getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) (CLbl mkSeqInfoLabel RetRep))
pushReturnAddress _ = nopC
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
+assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
+
\end{code}
\section[CgUpdate]{Manipulating update frames}
\begin{code}
-module CgUpdate ( pushUpdateFrame, reserveSeqFrame, pushSeqFrame ) where
+module CgUpdate ( pushUpdateFrame ) where
#include "HsVersions.h"
import CgMonad
import AbsCSyn
-import CgStackery ( allocStackTop, updateFrameSize, seqFrameSize )
+import CgStackery ( allocStackTop, updateFrameSize, setStackFrame )
import CgUsages ( getVirtSp, getSpRelOffset )
import Panic ( assertPanic )
\end{code}
allocStackTop updateFrameSize `thenFC` \ _ ->
getVirtSp `thenFC` \ vsp ->
+ setStackFrame vsp `thenC`
+
setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) (
-- Emit the push macro
int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
\end{code}
-
-We push a SEQ frame just before evaluating the scrutinee of a case, if
-the scrutinee has a polymorphic or function type. The SEQ frame acts
-as a barrier in case the scrutinee evaluates to a partial application.
-
-reserveSeqFrame takes the EndOfBlockInfo for the case expression and
-updates the sequel to a SeqFrame, reserving room for the frame at
-args_sp. When the scrutinee comes around to pushing a return address,
-it will also push the SEQ frame, using pushSeqFrame.
-
-\begin{code}
-reserveSeqFrame :: EndOfBlockInfo -> EndOfBlockInfo
-reserveSeqFrame (EndOfBlockInfo args_sp (CaseAlts amode stuff))
- = EndOfBlockInfo (args_sp + seqFrameSize) (SeqFrame amode stuff)
-
-pushSeqFrame :: VirtualSpOffset -> FCode VirtualSpOffset
-pushSeqFrame args_sp
- = getSpRelOffset args_sp `thenFC` \ sp_rel ->
- absC (CMacroStmt PUSH_SEQ_FRAME [CAddr sp_rel]) `thenC`
- returnFC (args_sp - seqFrameSize)
-\end{code}
-> Code
setRealAndVirtualSp sp = do
- ((vsp,f,realSp,hwsp), h_usage) <- getUsage
- let new_usage = ((sp, f, sp, sp), h_usage)
+ ((vsp,frame,f,realSp,hwsp), h_usage) <- getUsage
+ let new_usage = ((sp, frame, f, sp, sp), h_usage)
setUsage new_usage
\end{code}
\begin{code}
getVirtSp :: FCode VirtualSpOffset
getVirtSp = do
- ((virtSp,_,_,_), _) <- getUsage
+ ((virtSp,_,_,_,_), _) <- getUsage
return virtSp
getRealSp :: FCode VirtualSpOffset
getRealSp = do
- ((_,_,realSp,_),_) <- getUsage
+ ((_,_,_,realSp,_),_) <- getUsage
return realSp
\end{code}
\begin{code}
getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
getSpRelOffset virtual_offset = do
- ((_,_,realSp,_),_) <- getUsage
+ ((_,_,_,realSp,_),_) <- getUsage
return $ spRel realSp virtual_offset
\end{code}
adjustSpAndHp newRealSp = do
(MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown
(MkCgState absC binds
- ((vSp,fSp,realSp,hwSp),
+ ((vSp,frame,fSp,realSp,hwSp),
(vHp, rHp))) <- getState
let move_sp = if (newRealSp == realSp) then AbsCNop
else (CAssign (CReg Sp)
profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
]
- let new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
+ let new_usage = ((vSp, frame, fSp, newRealSp, hwSp), (vHp,vHp))
setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.53 2002/09/13 15:02:29 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.54 2002/12/11 15:36:28 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
\begin{code}
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
- StandardFormInfo,
+ StandardFormInfo, ArgDescr(..),
- EntryConvention(..),
+ CallingConvention(..),
mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
closureGoodStuffSize, closurePtrsSize,
slopSize,
- layOutDynClosure, layOutDynConstr, layOutStaticClosure,
- layOutStaticNoFVClosure, layOutStaticConstr,
+ layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure,
+ layOutDynConstr, layOutStaticConstr,
mkVirtHeapOffsets, mkStaticClosure,
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
staticClosureRequired,
- slowFunEntryCodeRequired, funInfoTableRequired,
- closureName, infoTableLabelFromCI, fastLabelFromCI,
+ closureName, infoTableLabelFromCI,
closureLabelFromCI, closureSRT,
entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureReEntrant, closureSemiTag,
- isStandardFormThunk,
+ closureFunInfo, isStandardFormThunk,
GenStgArg,
isToplevClosure,
isStaticClosure,
allocProfilingMsg,
cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
- maybeSelectorInfo,
staticClosureNeedsLink,
+
+ mkInfoTable, mkRetInfoTable, mkVecInfoTable,
) where
+#include "../includes/config.h"
+#include "../includes/MachDeps.h"
#include "HsVersions.h"
import AbsCSyn
import StgSyn
import CgMonad
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
- mAX_SPEC_FUN_SIZE, mAX_SPEC_THUNK_SIZE, mAX_SPEC_CONSTR_SIZE )
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
import CgRetConv ( assignRegs )
-import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
- mkInfoTableLabel,
- mkConInfoTableLabel,
- mkCAFBlackHoleInfoTableLabel,
- mkSECAFBlackHoleInfoTableLabel,
- mkStaticInfoTableLabel, mkStaticConEntryLabel,
- mkConEntryLabel, mkClosureLabel,
- mkSelectorInfoLabel, mkSelectorEntryLabel,
- mkApInfoTableLabel, mkApEntryLabel,
- mkReturnPtLabel
- )
+import CLabel
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
- opt_SMP )
-import Id ( Id, idType, idArity )
+ opt_SMP, opt_Unregisterised )
+import Id ( Id, idType, idArity, idName, idPrimRep )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
-import TyCon ( isBoxedTupleTyCon )
-import Name ( Name, nameUnique, getOccName )
+import Name ( Name, nameUnique, getOccName, getName )
import OccName ( occNameUserString )
import PprType ( getTyDescription )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
+import PrimRep
import SMRep -- all of it
-import Type ( isUnLiftedType, Type )
+import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TyCon ( isFunTyCon )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
import Util ( mapAccumL, listLengthCmp, lengthIs )
import FastString
import Outputable
+import Literal
+import Constants
+import BitSet
+
+import Maybe ( isJust )
+import DATA_WORD
+import DATA_BITS
\end{code}
%************************************************************************
%* *
%************************************************************************
-The ``wrapper'' data type for closure information:
+Information about a closure, from the code generator's point of view.
+
+A ClosureInfo decribes the info pointer of a closure. It has
+enough information
+ a) to construct the info table itself
+ b) to allocate a closure containing that info pointer (i.e.
+ it knows the info table label)
+
+We make a ClosureInfo for
+ - each let binding (both top level and not)
+ - each data constructor (for its shared static and
+ dynamic info tables)
\begin{code}
data ClosureInfo
- = MkClosureInfo {
- closureName :: Name, -- The thing bound to this closure
- closureLFInfo :: LambdaFormInfo, -- Info derivable from the *source*
- closureSMRep :: SMRep, -- representation used by storage manager
- closureSRT :: C_SRT -- What SRT applies to this closure
+ = ClosureInfo {
+ closureName :: !Name, -- The thing bound to this closure
+ closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
+ 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)
+ }
+
+ -- constructor closures don't have a unique info table label (they use
+ -- the constructor's info table), and they don't have an SRT.
+ | ConInfo {
+ closureCon :: !DataCon,
+ closureSMRep :: !SMRep
}
\end{code}
%* *
%************************************************************************
+Information about an identifier, from the code generator's point of
+view. Every identifier is bound to a LambdaFormInfo in the
+environment, which gives the code generator enough info to be able to
+tail call or return that identifier.
+
+Note that a closure is usually bound to an identifier, so a
+ClosureInfo contains a LambdaFormInfo.
+
\begin{code}
data LambdaFormInfo
- = LFReEntrant -- Reentrant closure; used for PAPs too
- Type -- Type of closure (ToDo: remove)
+ = LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
!Int -- Arity
!Bool -- True <=> no fvs
+ ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
| LFCon -- Constructor
DataCon -- The constructor
- Bool -- True <=> zero arity
-
- | LFTuple -- Tuples
- DataCon -- The tuple constructor
- Bool -- True <=> zero arity
| LFThunk -- Thunk (zero arity)
- Type -- Type of the thunk (ToDo: remove)
TopLevelFlag
!Bool -- True <=> no free vars
- Bool -- True <=> updatable (i.e., *not* single-entry)
+ !Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
+ !Bool -- True <=> *might* be a function type
- | LFArgument -- Used for function arguments. We know nothing about
- -- this closure. Treat like updatable "LFThunk"...
-
- | LFImported -- Used for imported things. We know nothing about this
- -- closure. Treat like updatable "LFThunk"...
+ | LFUnknown -- Used for function arguments and imported things.
+ -- We know nothing about this closure. Treat like
+ -- updatable "LFThunk"...
-- Imported things which we do know something about use
-- one of the other LF constructors (eg LFReEntrant for
-- known functions)
+ !Bool -- True <=> *might* be a function type
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
- Int -- arity;
+ !Int -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
-> LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
- = LFReEntrant (idType bndr) top (length args) (null fvs)
-
-mkClosureLFInfo bndr top fvs ReEntrant []
- = LFReEntrant (idType bndr) top 0 (null fvs)
+ = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args)
mkClosureLFInfo bndr top fvs upd_flag []
-#ifdef DEBUG
- | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
-#endif
- | otherwise
- = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
+ = ASSERT( not updatable || not (isUnLiftedType id_ty) )
+ LFThunk top (null fvs) updatable NonStandardThunk
+ (might_be_a_function id_ty)
where
- ty = idType bndr
+ updatable = isUpdatable upd_flag
+ id_ty = idType bndr
+
+might_be_a_function :: Type -> Bool
+might_be_a_function ty
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty),
+ not (isFunTyCon tc) = False
+ | otherwise = True
\end{code}
@mkConLFInfo@ is similar, for constructors.
\begin{code}
mkConLFInfo :: DataCon -> LambdaFormInfo
+mkConLFInfo con = LFCon con
-mkConLFInfo con
- = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
- (if isBoxedTupleTyCon (dataConTyCon con) then LFTuple else LFCon)
- con (isNullaryDataCon con)
+mkSelectorLFInfo id offset updatable
+ = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+ (might_be_a_function (idType id))
-mkSelectorLFInfo rhs_ty offset updatable
- = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
-
-mkApLFInfo rhs_ty upd_flag arity
- = LFThunk rhs_ty NotTopLevel (arity == 0)
- (isUpdatable upd_flag) (ApThunk arity)
+mkApLFInfo id upd_flag arity
+ = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+ (might_be_a_function (idType id))
\end{code}
Miscellaneous LF-infos.
\begin{code}
-mkLFArgument = LFArgument
+mkLFArgument id = LFUnknown (might_be_a_function (idType id))
+
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idArity id of
- n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
- other -> LFImported -- Not sure of exact arity
+ n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
+ other -> mkLFArgument id -- Not sure of exact arity
\end{code}
%************************************************************************
closureNonHdrSize cl_info
= tot_wds + computeSlopSize tot_wds
(closureSMRep cl_info)
- (closureUpdReqd cl_info)
+ (closureNeedsUpdSpace cl_info)
where
tot_wds = closureGoodStuffSize cl_info
+-- we leave space for an update if either (a) the closure is updatable
+-- or (b) it is a static thunk. This is because a static thunk needs
+-- a static link field in a predictable place (after the slop), regardless
+-- of whether it is updatable or not.
+closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
+ LFThunk TopLevel _ _ _ _ }) = True
+closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
+
slopSize :: ClosureInfo -> Int
slopSize cl_info
= computeSlopSize (closureGoodStuffSize cl_info)
(closureSMRep cl_info)
- (closureUpdReqd cl_info)
+ (closureNeedsUpdSpace cl_info)
closureGoodStuffSize :: ClosureInfo -> Int
closureGoodStuffSize cl_info
%************************************************************************
%* *
-\subsection[layOutDynClosure]{Lay out a dynamic closure}
+\subsection[layOutDynClosure]{Lay out a closure}
%* *
%************************************************************************
\begin{code}
layOutDynClosure, layOutStaticClosure
- :: Name -- STG identifier of this closure
+ :: Id -- STG identifier of this closure
+ -> (a -> PrimRep) -- how to get a PrimRep for the fields
+ -> [a] -- the "things" being layed out
+ -> LambdaFormInfo -- what sort of closure it is
+ -> C_SRT -- its SRT
+ -> String -- closure description
+ -> (ClosureInfo, -- info about the closure
+ [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
+
+layOutDynClosure = layOutClosure False
+layOutStaticClosure = layOutClosure True
+
+layOutStaticNoFVClosure id lf_info srt_info descr
+ = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr)
+
+layOutClosure
+ :: Bool -- True <=> static closure
+ -> Id -- STG identifier of this closure
-> (a -> PrimRep) -- how to get a PrimRep for the fields
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
- -> C_SRT
+ -> C_SRT -- its SRT
+ -> String -- closure description
-> (ClosureInfo, -- info about the closure
[(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-layOutDynClosure name kind_fn things lf_info srt_info
- = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = sm_rep, closureSRT = srt_info },
+layOutClosure is_static id kind_fn things lf_info srt_info descr
+ = (ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = sm_rep,
+ closureSRT = srt_info,
+ closureType = idType id,
+ closureDescr = descr },
things_w_offsets)
where
+ name = idName id
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets kind_fn things
- sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
-\end{code}
+ sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-Wrappers for when used with data constructors:
-\begin{code}
layOutDynConstr, layOutStaticConstr
- :: Name -- Of the closure
- -> DataCon
- -> (a -> PrimRep) -> [a]
- -> (ClosureInfo, [(a,VirtualHeapOffset)])
-
-layOutDynConstr name data_con kind_fn args
- = layOutDynClosure name kind_fn args (mkConLFInfo data_con) NoC_SRT
-
-layOutStaticConstr name data_con kind_fn things
- = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT
+ :: DataCon
+ -> (a -> PrimRep)
+ -> [a]
+ -> (ClosureInfo,
+ [(a,VirtualHeapOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static data_con kind_fn args
+ = (ConInfo { closureSMRep = sm_rep,
+ closureCon = data_con },
+ things_w_offsets)
+ where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets kind_fn args
+ sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
%************************************************************************
%* *
-\subsection[layOutStaticClosure]{Lay out a static closure}
+\subsection[mkStaticClosure]{Make a static closure}
%* *
%************************************************************************
-layOutStaticClosure is only used for laying out static constructors at
-the moment.
-
-Static closures for functions are laid out using
-layOutStaticNoFVClosure.
+Make a static closure, adding on any extra padding needed for CAFs,
+and adding a static link field if necessary.
\begin{code}
-layOutStaticClosure name kind_fn things lf_info srt_info
- = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = rep, closureSRT = srt_info },
- things_w_offsets)
- where
- rep = GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type
-
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets kind_fn things
-
- -- constructors with no pointer fields will definitely be NOCAF things.
- -- this is a compromise until we can generate both kinds of constructor
- -- (a normal static kind and the NOCAF_STATIC kind).
- closure_type = getClosureType is_static tot_wds ptr_wds lf_info
- is_static = True
-
-layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> C_SRT -> ClosureInfo
-layOutStaticNoFVClosure name lf_info srt_info
- = MkClosureInfo { closureName = name, closureLFInfo = lf_info,
- closureSMRep = rep, closureSRT = srt_info }
- where
- rep = GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)
- is_static = True
-
-
--- make a static closure, adding on any extra padding needed for CAFs,
--- and adding a static link field if necessary.
-
-mkStaticClosure closure_info ccs fields cafrefs
+mkStaticClosure lbl cl_info ccs fields cafrefs
| opt_SccProfilingOn =
CStaticClosure
- closure_info
+ lbl
+ cl_info
(mkCCostCentreStack ccs)
all_fields
| otherwise =
CStaticClosure
- closure_info
+ lbl
+ cl_info
(panic "absent cc")
all_fields
where
all_fields = fields ++ padding_wds ++ static_link_field
- upd_reqd = closureUpdReqd closure_info
+ upd_reqd = closureUpdReqd cl_info
+ -- for the purposes of laying out the static closure, we consider all
+ -- thunks to be "updatable", so that the static link field is always
+ -- in the same place.
padding_wds
| not upd_reqd = []
| otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
-- save the closure's info pointer when we're reverting CAFs
-- (see comment in Storage.c)
static_link_field
- | upd_reqd || staticClosureNeedsLink closure_info = [static_link_value]
- | otherwise = []
+ | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
-- for a static constructor which has NoCafRefs, we set the
-- static link field to a non-zero value so the garbage
%************************************************************************
\begin{code}
-chooseDynSMRep
- :: LambdaFormInfo
+chooseSMRep
+ :: Bool -- True <=> static closure
+ -> LambdaFormInfo
-> Int -> Int -- Tot wds, ptr wds
-> SMRep
-chooseDynSMRep lf_info tot_wds ptr_wds
+chooseSMRep is_static lf_info tot_wds ptr_wds
= let
- is_static = False
nonptr_wds = tot_wds - ptr_wds
closure_type = getClosureType is_static tot_wds ptr_wds lf_info
in
getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
getClosureType is_static tot_wds ptr_wds lf_info
= case lf_info of
- LFCon con zero_arity
- | is_static && ptr_wds == 0 -> CONSTR_NOCAF
- | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
- | otherwise -> CONSTR
-
- LFTuple _ zero_arity
- | is_static && ptr_wds == 0 -> CONSTR_NOCAF
- | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
- | otherwise -> CONSTR
-
- LFReEntrant _ _ _ _
- | specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n
- | otherwise -> FUN
-
- LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
-
- LFThunk _ _ _ _ _
- | specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n
- | otherwise -> THUNK
-
+ LFCon con | is_static && ptr_wds == 0 -> CONSTR_NOCAF
+ | otherwise -> CONSTR
+ LFReEntrant _ _ _ _ -> FUN
+ LFThunk _ _ _ (SelectorThunk _) _ -> THUNK_SELECTOR
+ LFThunk _ _ _ _ _ -> THUNK
_ -> panic "getClosureType"
- where
- specialised_rep max_size = not is_static
- && tot_wds > 0
- && tot_wds <= max_size
\end{code}
%************************************************************************
nodeMustPointToIt lf_info
= case lf_info of
- LFReEntrant ty top arity no_fvs -> returnFC (
+ LFReEntrant top _ no_fvs _ -> returnFC (
not no_fvs || -- Certainly if it has fvs we need to point to it
isNotTopLevel top
-- If it is not top level we will point to it
-- the not top case above ensures this is ok.
)
- LFCon _ zero_arity -> returnFC True
- LFTuple _ zero_arity -> returnFC True
+ LFCon _ -> returnFC True
-- Strictly speaking, the above two don't need Node to point
-- to it if the arity = 0. But this is a *really* unlikely
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ _ no_fvs updatable NonStandardThunk
+ LFThunk _ no_fvs updatable NonStandardThunk _
-> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-- 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
+ LFThunk _ no_fvs updatable some_standard_form_thunk _
-> returnFC True
-- Node must point to any standard-form thunk.
- LFArgument -> returnFC True
- LFImported -> returnFC True
+ LFUnknown _ -> returnFC True
LFBlackHole _ -> returnFC True
-- BH entry may require Node to point
(rather than directly) to catch double-entry.
\begin{code}
-data EntryConvention
- = ViaNode -- The "normal" convention
+data CallingConvention
+ = EnterIt -- no args, not a function
- | StdEntry CLabel -- Jump to this code, with args on stack
+ | JumpToIt CLabel -- no args, not a function, but we
+ -- know what its entry code is
+
+ | ReturnIt -- it's a function, but we have
+ -- zero args to apply to it, so just
+ -- return it.
+
+ | SlowCall -- Unknown fun, or known fun with
+ -- too few args.
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
getEntryConvention :: Name -- Function being applied
-> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
- -> FCode EntryConvention
+ -> FCode CallingConvention
getEntryConvention name lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
-- 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.
- if (node_points && opt_Parallel) then ViaNode else
+ if (node_points && opt_Parallel) then EnterIt else
-- Commented out by SDM after futher thoughts:
-- - the only closure type that can be blackholed is a thunk
case lf_info of
- LFReEntrant _ _ arity _ ->
- if arity == 0 || (listLengthCmp arg_kinds arity == LT) then
- StdEntry (mkStdEntryLabel name)
+ LFReEntrant _ arity _ _ ->
+ if null arg_kinds then
+ if arity == 0 then
+ EnterIt -- a non-updatable thunk
+ else
+ ReturnIt -- no args at all
+ else if listLengthCmp arg_kinds arity == LT then
+ SlowCall -- not enough args
else
- DirectEntry (mkFastEntryLabel name arity) arity arg_regs
+ DirectEntry (mkEntryLabel name) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
- live_regs = if node_points then [node] else []
+ (arg_regs, _) = assignRegs [node] (take arity arg_kinds)
+ -- we don't use node to pass args now (SDM)
- LFCon con True{-zero_arity-}
+ LFCon con
+ | isNullaryDataCon con
-- a real constructor. Don't bother entering it, just jump
-- to the constructor entry code directly.
-> --false:ASSERT (null arg_kinds)
-- Should have no args (meaning what?)
- StdEntry (mkStaticConEntryLabel (dataConName con))
-
- LFCon con False{-non-zero_arity-}
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel (dataConName con))
+ JumpToIt (mkStaticConEntryLabel (dataConName con))
- LFTuple tup zero_arity
+ | otherwise {- not nullary -}
-> --false:ASSERT (null arg_kinds)
-- Should have no args (meaning what?)
- StdEntry (mkConEntryLabel (dataConName tup))
+ JumpToIt (mkConEntryLabel (dataConName con))
- LFThunk _ _ _ updatable std_form_info
- -> if updatable || opt_DoTickyProfiling -- to catch double entry
+ LFThunk _ _ updatable std_form_info is_fun
+ -- must always "call" a function-typed thing, cannot just enter it
+ | is_fun -> SlowCall
+ | updatable || opt_DoTickyProfiling -- to catch double entry
|| opt_SMP -- always enter via node on SMP, since the
-- thunk might have been blackholed in the
-- meantime.
- then ViaNode
- else StdEntry (thunkEntryLabel name std_form_info updatable)
+ -> ASSERT(null arg_kinds) EnterIt
+ | otherwise
+ -> ASSERT(null arg_kinds)
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
- 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
+ LFUnknown True -> SlowCall -- might be a function
+ LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function
+
+ LFBlackHole _ -> SlowCall -- Presumably the black hole has by now
+ -- been updated, but we don't know with
+ -- what, so we slow call it
LFLetNoEscape 0
- -> StdEntry (mkReturnPtLabel (nameUnique name))
+ -> JumpToIt (mkReturnPtLabel (nameUnique name))
LFLetNoEscape arity
-> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
-- Single-entry ones have no fvs to plug, and we trust they don't form part
-- of a loop.
-blackHoleOnEntry cl_info
- | isStaticRep (closureSMRep cl_info)
+blackHoleOnEntry ConInfo{} = False
+blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+ | isStaticRep rep
= False -- Never black-hole a static closure
| otherwise
- = case closureLFInfo cl_info of
+ = case lf_info of
LFReEntrant _ _ _ _ -> False
LFLetNoEscape _ -> False
- LFThunk _ _ no_fvs updatable _
+ LFThunk _ no_fvs updatable _ _
-> if updatable
then not opt_OmitBlackHoling
else opt_DoTickyProfiling || not no_fvs
isStandardFormThunk :: LambdaFormInfo -> Bool
-isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
-isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True
+isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
+isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
isStandardFormThunk other_lf_info = False
-maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) })
- = Just offset
-maybeSelectorInfo _ = Nothing
\end{code}
-----------------------------------------------------------------------------
-- b) it's a constructor with one or more pointer fields
-- In case (b), the constructor's fields themselves play the role
-- of the SRT.
-staticClosureNeedsLink (MkClosureInfo { closureName = name,
- closureSRT = srt,
- closureLFInfo = lf_info,
- closureSMRep = sm_rep })
- = needsSRT srt || (constr_with_fields && not_nocaf_constr)
+staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
+ = needsSRT srt
+staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
+ = not (isNullaryDataCon con) && not_nocaf_constr
where
not_nocaf_constr =
case sm_rep of
GenericRep _ _ _ CONSTR_NOCAF -> False
_other -> True
-
- constr_with_fields =
- case lf_info of
- LFThunk _ _ _ _ _ -> False
- LFReEntrant _ _ _ _ -> False
- LFCon _ is_nullary -> not is_nullary
- LFTuple _ is_nullary -> not is_nullary
- _other -> pprPanic "staticClosureNeedsLink" (ppr name)
\end{code}
Avoiding generating entries and info tables
-> LambdaFormInfo
-> Bool
staticClosureRequired binder bndr_info
- (LFReEntrant _ top_level _ _) -- It's a function
+ (LFReEntrant top_level _ _ _) -- It's a function
= ASSERT( isTopLevel top_level )
-- Assumption: it's a top-level, no-free-var binding
not (satCallsOnly bndr_info)
staticClosureRequired binder other_binder_info other_lf_info = True
-
-slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
- :: Name
- -> StgBinderInfo
- -> EntryConvention
- -> Bool
-slowFunEntryCodeRequired binder bndr_info entry_conv
- = not (satCallsOnly bndr_info)
- || (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 -}
-
-funInfoTableRequired
- :: Name
- -> StgBinderInfo
- -> LambdaFormInfo
- -> Bool
-funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _)
- = isNotTopLevel top_level
- || not (satCallsOnly bndr_info)
-
-funInfoTableRequired other_binder_info binder other_lf_info = True
\end{code}
%************************************************************************
isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd
-closureUpdReqd (MkClosureInfo { closureLFInfo = LFBlackHole _ }) = True
+closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd
+closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ }) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
closureSingleEntry other_closure = False
closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant other_closure = False
-\end{code}
-\begin{code}
closureSemiTag :: ClosureInfo -> Maybe Int
-closureSemiTag (MkClosureInfo { closureLFInfo = lf_info })
- = case lf_info of
- LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
- LFTuple _ _ -> Just 0
- _ -> Nothing
+closureSemiTag (ConInfo { closureCon = data_con })
+ = Just (dataConTag data_con - fIRST_TAG)
+closureSemiTag _ = Nothing
+
+closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
+closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc})
+ = Just (arity, arg_desc)
+closureFunInfo _
+ = Nothing
\end{code}
\begin{code}
isToplevClosure :: ClosureInfo -> Bool
-
-isToplevClosure (MkClosureInfo { closureLFInfo = lf_info })
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
- LFReEntrant _ TopLevel _ _ -> True
- LFThunk _ TopLevel _ _ _ -> True
+ LFReEntrant TopLevel _ _ _ -> True
+ LFThunk TopLevel _ _ _ _ -> True
other -> False
+isToplevClosure _ = False
\end{code}
Label generation.
\begin{code}
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ })
- = mkFastEntryLabel name arity
-
-fastLabelFromCI cl_info
- = pprPanic "fastLabelFromCI" (ppr (closureName cl_info))
-
infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
+infoTableLabelFromCI (ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = rep })
= case lf_info of
- LFCon con _ -> mkConInfoPtr con rep
- LFTuple tup _ -> mkConInfoPtr tup rep
-
LFBlackHole info -> info
- LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
+ LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
mkSelectorInfoLabel upd_flag offset
- LFThunk _ _ _ upd_flag (ApThunk arity) ->
+ LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
- other -> {-NO: if isStaticRep rep
- then mkStaticInfoTableLabel id
- else -} mkInfoTableLabel id
+ LFThunk{} -> mkInfoTableLabel name
+
+ LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name
+ LFReEntrant _ _ _ _ -> mkInfoTableLabel name
+
+ other -> panic "infoTableLabelFromCI"
+
+infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
+ = mkConInfoPtr con rep
+
mkConInfoPtr :: DataCon -> SMRep -> CLabel
mkConInfoPtr con rep
| isStaticRep rep = mkStaticConEntryLabel (dataConName con)
| otherwise = mkConEntryLabel (dataConName con)
-closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info)
+closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
+closureLabelFromCI _ = panic "closureLabelFromCI"
entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
+entryLabelFromCI (ClosureInfo { closureName = id,
+ closureLFInfo = lf_info,
+ closureSMRep = rep })
= case lf_info of
- LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
- LFCon con _ -> mkConEntryPtr con rep
- LFTuple tup _ -> mkConEntryPtr tup rep
- other -> mkStdEntryLabel id
+ LFThunk _ _ upd_flag std_form_info _ ->
+ thunkEntryLabel id std_form_info upd_flag
+ other -> mkEntryLabel id
+
+entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
+ = mkConEntryPtr con rep
+
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getEntryConvention.
thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
= mkSelectorEntryLabel upd_flag offset
thunkEntryLabel thunk_id _ is_updatable
- = mkStdEntryLabel thunk_id
+ = mkEntryLabel thunk_id
\end{code}
\begin{code}
allocProfilingMsg :: ClosureInfo -> FastString
-
-allocProfilingMsg cl_info
- = case closureLFInfo cl_info of
+allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON")
+allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info }
+ = case lf_info of
LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN")
- LFCon _ _ -> FSLIT("TICK_ALLOC_CON")
- LFTuple _ _ -> FSLIT("TICK_ALLOC_CON")
- LFThunk _ _ _ True _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable
- LFThunk _ _ _ False _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable
+ LFThunk _ _ True _ _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable
+ LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable
LFBlackHole _ -> FSLIT("TICK_ALLOC_BH")
- LFImported -> panic "TICK_ALLOC_IMP"
+ _ -> panic "allocProfilingMsg"
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
is a black hole and not something else.
\begin{code}
-cafBlackHoleClosureInfo cl_info
- = MkClosureInfo { closureName = closureName cl_info,
- closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT }
-
-seCafBlackHoleClosureInfo cl_info
- = MkClosureInfo { closureName = closureName cl_info,
- closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT }
+cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
+
+seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
\end{code}
%************************************************************************
\begin{code}
closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr cl_info
- = case closureLFInfo cl_info of
- LFThunk ty _ _ _ _ -> getTyDescription ty
- LFReEntrant ty _ _ _ -> getTyDescription ty
- LFCon data_con _ -> occNameUserString (getOccName (dataConTyCon data_con))
- other -> showSDoc (ppr (closureName cl_info))
+closureTypeDescr (ClosureInfo { closureType = ty })
+ = getTyDescription ty
+closureTypeDescr (ConInfo { closureCon = data_con })
+ = occNameUserString (getOccName (dataConTyCon data_con))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Making argument bitmaps}
+%* *
+%************************************************************************
+
+\begin{code}
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/StgFun.h"
+
+data ArgDescr
+ = ArgSpec
+ !Int -- ARG_P, ARG_N, ...
+ | ArgGen
+ CLabel -- label for a slow-entry point
+ Liveness -- the arg bitmap: describes pointedness of arguments
+
+mkArgDescr :: Name -> [Id] -> ArgDescr
+mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args))
+ where nonVoidRep VoidRep = False
+ nonVoidRep _ = True
+
+argDescr nm [PtrRep] = ArgSpec ARG_P
+argDescr nm [FloatRep] = ArgSpec ARG_F
+argDescr nm [DoubleRep] = ArgSpec ARG_D
+argDescr nm [r] | is64BitRep r = ArgSpec ARG_L
+argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N
+
+argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN
+argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP
+argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN
+argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP
+
+argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN
+argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP
+argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN
+argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP
+argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN
+argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP
+argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN
+argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP
+
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP
+
+argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
+ where bitmap = argBits reps
+ lbl = mkBitmapLabel name
+ liveness = Liveness lbl (length bitmap)
+ (map chunkToLiveness (mkChunks bitmap))
+
+argBits [] = []
+argBits (rep : args)
+ | isFollowableRep rep = False : argBits args
+ | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
+
+mkChunks [] = []
+mkChunks stuff = chunk : mkChunks rest
+ where (chunk, rest) = splitAt 32 stuff
+
+chunkToLiveness chunk = mkBS [ n | (True,n) <- zip chunk [0..] ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Generating info tables}
+%* *
+%************************************************************************
+
+Here we make a concrete info table, represented as a list of CAddrMode
+(it can't be simply a list of Word, because the SRT field is
+represented by a label+offset expression).
+
+\begin{code}
+#if SIZEOF_HSWORD == 4
+type StgWord = Word32
+#define HALF_WORD 16
+#elif SIZEOF_HSWORD == 8
+type StgWord = Word64
+#define HALF_WORD 32
+#endif
+
+mkInfoTable :: ClosureInfo -> [CAddrMode]
+mkInfoTable cl_info
+ | opt_Unregisterised = std_info ++ extra_bits
+ | otherwise = extra_bits ++ std_info
+ where
+ std_info = mkStdInfoTable entry_amode
+ ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
+
+ entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep
+
+ closure_descr =
+ case cl_info of
+ ClosureInfo { closureDescr = descr } -> descr
+ ConInfo { closureCon = con } -> occNameUserString (getOccName con)
+
+ ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info)))
+ cl_descr_amode = CLit (MachStr (mkFastString closure_descr))
+
+ cl_type = getSMRepClosureTypeInt (closureSMRep cl_info)
+
+ srt = closureSRT cl_info
+ needs_srt = needsSRT srt
+
+ semi_tag = closureSemiTag cl_info
+ is_con = isJust semi_tag
+
+ (srt_label,srt_len)
+ | Just tag <- semi_tag = (mkIntCLit 0, tag) -- constructor
+ | otherwise =
+ case srt of
+ NoC_SRT -> (mkIntCLit 0, 0)
+ C_SRT lbl off len ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ len)
+
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
+ size = closureNonHdrSize cl_info
+
+ layout_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ layout_info = (fromIntegral ptrs `shiftL` HALF_WORD) .|. fromIntegral nptrs
+#else
+ layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` HALF_WORD)
+#endif
+
+ layout_amode = CLit (MachWord (fromIntegral layout_info))
+
+ extra_bits
+ | is_fun = fun_extra_bits
+ | is_con = []
+ | needs_srt = [srt_label]
+ | otherwise = []
+
+ maybe_fun_stuff = closureFunInfo cl_info
+ is_fun = isJust maybe_fun_stuff
+ (Just (arity, arg_descr)) = maybe_fun_stuff
+
+ fun_extra_bits
+ | opt_Unregisterised = reverse reg_fun_extra_bits
+ | otherwise = reg_fun_extra_bits
+
+ reg_fun_extra_bits
+ | ArgGen slow_lbl liveness <- arg_descr
+ = [
+ CLbl slow_lbl CodePtrRep,
+ livenessToAddrMode liveness,
+ srt_label,
+ mkIntCLit fun_desc
+ ]
+ | needs_srt = [srt_label, mkIntCLit fun_desc]
+ | otherwise = [mkIntCLit fun_desc]
+
+#ifdef WORDS_BIGENDIAN
+ fun_desc = (fromIntegral fun_type `shiftL` HALF_WORD) .|. fromIntegral arity
+#else
+ fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` HALF_WORD)
+#endif
+
+ fun_type = case arg_descr of
+ ArgSpec n -> n
+ ArgGen _ (Liveness _ size _)
+ | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN
+ | otherwise -> ARG_GEN_BIG
+
+-- Return info tables come in two flavours: direct returns and
+-- vectored returns.
+
+mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode]
+mkRetInfoTable entry_lbl srt liveness
+ = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness []
+
+mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode]
+mkVecInfoTable vector srt liveness
+ = mkBitmapInfoTable zero_amode srt liveness vector
+
+mkBitmapInfoTable
+ :: CAddrMode
+ -> C_SRT -> Liveness
+ -> [CAddrMode]
+ -> [CAddrMode]
+mkBitmapInfoTable entry_amode srt liveness vector
+ | opt_Unregisterised = std_info ++ extra_bits
+ | otherwise = extra_bits ++ std_info
+ where
+ std_info = mkStdInfoTable entry_amode zero_amode zero_amode
+ cl_type srt_len liveness_amode
+
+ liveness_amode = livenessToAddrMode liveness
+
+ (srt_label,srt_len) =
+ case srt of
+ NoC_SRT -> (mkIntCLit 0, 0)
+ C_SRT lbl off len ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ len)
+
+ cl_type = case (null vector, isBigLiveness liveness) of
+ (True, True) -> rET_BIG
+ (True, False) -> rET_SMALL
+ (False, True) -> rET_VEC_BIG
+ (False, False) -> rET_VEC_SMALL
+
+ srt_bit | needsSRT srt || not (null vector) = [srt_label]
+ | otherwise = []
+
+ extra_bits | opt_Unregisterised = srt_bit ++ vector
+ | otherwise = reverse vector ++ srt_bit
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+
+mkStdInfoTable
+ :: CAddrMode -- entry label
+ -> CAddrMode -- closure type descr (profiling)
+ -> CAddrMode -- closure descr (profiling)
+ -> Int -- closure type
+ -> Int -- SRT length
+ -> CAddrMode -- layout field
+ -> [CAddrMode]
+mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
+ = std_info
+ where
+ std_info
+ | opt_Unregisterised = entry_lbl : std_info'
+ | otherwise = std_info'
+
+ std_info' =
+ -- par info
+ prof_info ++
+ -- ticky info
+ -- debug info
+ [layout_amode] ++
+ CLit (MachWord (fromIntegral type_info)) :
+ []
+
+ prof_info
+ | opt_SccProfilingOn = [ type_descr, closure_descr ]
+ | otherwise = []
+
+ -- sigh: building up the info table is endian-dependent.
+ -- ToDo: do this using .byte and .word directives.
+ type_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ type_info = (fromIntegral cl_type `shiftL` HALF_WORD) .|.
+ (fromIntegral srt_len)
+#else
+ type_info = (fromIntegral cl_type) .|.
+ (fromIntegral srt_len `shiftL` HALF_WORD)
+#endif
+
+isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+
+livenessToAddrMode :: Liveness -> CAddrMode
+livenessToAddrMode (Liveness lbl size bits)
+ | size <= mAX_SMALL_BITMAP_SIZE = small
+ | otherwise = CLbl lbl DataPtrRep
+ where
+ small = mkIntCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
+ small_bits = case bits of
+ [] -> 0
+ [b] -> intBS b
+ _ -> panic "livenessToAddrMode"
+
+mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
+
+zero_amode = mkIntCLit 0
\end{code}
SMRep(..), ClosureType(..),
isStaticRep,
fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize,
- fixedItblSize, pprSMRep
+ stdItblSize, retItblSize
#ifndef OMIT_NATIVE_CODEGEN
, getSMRepClosureTypeInt
#include "HsVersions.h"
import CmdLineOpts
-import Constants ( sTD_HDR_SIZE, pROF_HDR_SIZE,
- gRAN_HDR_SIZE, tICKY_ITBL_SIZE,
- aRR_WORDS_HDR_SIZE, aRR_PTRS_HDR_SIZE,
- sTD_ITBL_SIZE, pROF_ITBL_SIZE,
- gRAN_ITBL_SIZE )
+import Constants
import Outputable
\end{code}
= GenericRep -- GC routines consult sizes in info tbl
Bool -- True <=> This is a static closure. Affects how
-- we garbage-collect it
- Int -- # ptr words
- Int -- # non-ptr words
+ !Int -- # ptr words
+ !Int -- # non-ptr words
ClosureType -- closure type
| BlackHoleRep
data ClosureType -- Corresponds 1-1 with the varieties of closures
-- implemented by the RTS. Compare with ghc/includes/ClosureTypes.h
= CONSTR
- | CONSTR_p_n -- The p_n variants have more efficient GC, but we
- -- only provide them for dynamically-allocated closures
- -- (We could do them for static ones, but we don't)
| CONSTR_NOCAF
| FUN
- | FUN_p_n
| THUNK
- | THUNK_p_n
| THUNK_SELECTOR
- deriving (Eq,Ord)
\end{code}
Size of a closure header.
Size of an info table.
\begin{code}
-fixedItblSize :: Int{-words-}
-fixedItblSize = sTD_ITBL_SIZE + profItblSize + granItblSize + tickyItblSize
+stdItblSize :: Int{-words-}
+stdItblSize = sTD_ITBL_SIZE + profItblSize + granItblSize + tickyItblSize
+
+retItblSize :: Int{-words-}
+retItblSize = stdItblSize + rET_ITBL_SIZE
profItblSize :: Int{-words-}
profItblSize | opt_SccProfilingOn = pROF_ITBL_SIZE
\end{code}
\begin{code}
-instance Outputable SMRep where
- ppr rep = pprSMRep rep
-
-pprSMRep :: SMRep -> SDoc
-pprSMRep (GenericRep True ptrs nptrs clo_ty) = pprClosureType clo_ty ptrs nptrs <> ptext SLIT("_STATIC")
-pprSMRep (GenericRep False ptrs nptrs clo_ty) = pprClosureType clo_ty ptrs nptrs
-
-pprClosureType CONSTR p n = ptext SLIT("CONSTR")
-pprClosureType CONSTR_p_n p n = ptext SLIT("CONSTR_") <> int p <> char '_' <> int n
-pprClosureType CONSTR_NOCAF p n = ptext SLIT("CONSTR_NOCAF")
-pprClosureType FUN p n = ptext SLIT("FUN")
-pprClosureType FUN_p_n p n = ptext SLIT("FUN_") <> int p <> char '_' <> int n
-pprClosureType THUNK p n = ptext SLIT("THUNK")
-pprClosureType THUNK_p_n p n = ptext SLIT("THUNK_") <> int p <> char '_' <> int n
-pprClosureType THUNK_SELECTOR p n = ptext SLIT("THUNK_SELECTOR")
-
-#ifndef OMIT_NATIVE_CODEGEN
getSMRepClosureTypeInt :: SMRep -> Int
-getSMRepClosureTypeInt (GenericRep False _ _ CONSTR) = cONSTR
-getSMRepClosureTypeInt (GenericRep False 1 0 CONSTR_p_n) = cONSTR_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 CONSTR_p_n) = cONSTR_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 CONSTR_p_n) = cONSTR_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 CONSTR_p_n) = cONSTR_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 CONSTR_p_n) = cONSTR_0_2
-
-getSMRepClosureTypeInt (GenericRep False _ _ FUN) = fUN
-getSMRepClosureTypeInt (GenericRep False 1 0 FUN_p_n) = fUN_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 FUN_p_n) = fUN_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 FUN_p_n) = fUN_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 FUN_p_n) = fUN_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 FUN_p_n) = fUN_0_2
-
-getSMRepClosureTypeInt (GenericRep False _ _ THUNK) = tHUNK
-getSMRepClosureTypeInt (GenericRep False 1 0 THUNK_p_n) = tHUNK_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 THUNK_p_n) = tHUNK_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 THUNK_p_n) = tHUNK_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 THUNK_p_n) = tHUNK_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 THUNK_p_n) = tHUNK_0_2
+getSMRepClosureTypeInt (GenericRep False 1 0 CONSTR) = cONSTR_1_0
+getSMRepClosureTypeInt (GenericRep False 0 1 CONSTR) = cONSTR_0_1
+getSMRepClosureTypeInt (GenericRep False 2 0 CONSTR) = cONSTR_2_0
+getSMRepClosureTypeInt (GenericRep False 1 1 CONSTR) = cONSTR_1_1
+getSMRepClosureTypeInt (GenericRep False 0 2 CONSTR) = cONSTR_0_2
+getSMRepClosureTypeInt (GenericRep False _ _ CONSTR) = cONSTR
+
+getSMRepClosureTypeInt (GenericRep False 1 0 FUN) = fUN_1_0
+getSMRepClosureTypeInt (GenericRep False 0 1 FUN) = fUN_0_1
+getSMRepClosureTypeInt (GenericRep False 2 0 FUN) = fUN_2_0
+getSMRepClosureTypeInt (GenericRep False 1 1 FUN) = fUN_1_1
+getSMRepClosureTypeInt (GenericRep False 0 2 FUN) = fUN_0_2
+getSMRepClosureTypeInt (GenericRep False _ _ FUN) = fUN
+
+getSMRepClosureTypeInt (GenericRep False 1 0 THUNK) = tHUNK_1_0
+getSMRepClosureTypeInt (GenericRep False 0 1 THUNK) = tHUNK_0_1
+getSMRepClosureTypeInt (GenericRep False 2 0 THUNK) = tHUNK_2_0
+getSMRepClosureTypeInt (GenericRep False 1 1 THUNK) = tHUNK_1_1
+getSMRepClosureTypeInt (GenericRep False 0 2 THUNK) = tHUNK_0_2
+getSMRepClosureTypeInt (GenericRep False _ _ THUNK) = tHUNK
getSMRepClosureTypeInt (GenericRep False _ _ THUNK_SELECTOR) = tHUNK_SELECTOR
getSMRepClosureTypeInt BlackHoleRep = bLACKHOLE
-getSMRepClosureTypeInt rep = pprPanic "getSMRepClosureTypeInt:" (pprSMRep rep)
+getSMRepClosureTypeInt rep = panic "getSMRepClosureTypeInt"
-- Just the ones we need:
rET_BIG = (RET_BIG :: Int)
rET_VEC_BIG = (RET_VEC_BIG :: Int)
bLACKHOLE = (BLACKHOLE :: Int)
-
-#endif OMIT_NATIVE_CODEGEN
\end{code}
$tot = 0;
$totcmts = 0;
-printf "\n Code Comments\n"
+printf "\n Code Comments\n";
foreach $m (sort (keys %ModCount)) {
printf "%-20s %6d %6d\n", $m, $ModCount{$m}, $ModComments{$m};
$tot += $ModCount{$m};
%
-% (c) The University of Glasgow 2000
+% (c) The University of Glasgow 2002
%
\section[ByteCodeLink]{Bytecode assembler and linker}
\begin{code}
-
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module ByteCodeAsm (
assembleBCOs, assembleBCO,
CompiledByteCode(..),
- UnlinkedBCO(..), UnlinkedBCOExpr, nameOfUnlinkedBCO, bcosFreeNames,
+ UnlinkedBCO(..), BCOPtr(..), bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH
) where
#include "HsVersions.h"
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
+import ByteCodeInstr
import ByteCodeItbls ( ItblEnv, mkITbls )
import Name ( Name, getName )
import NameSet
import FiniteMap ( addToFM, lookupFM, emptyFM )
-import CoreSyn
import Literal ( Literal(..) )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import PrimRep ( PrimRep(..), isFollowableRep )
+import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep )
import Constants ( wORD_SIZE )
import FastString ( FastString(..), unpackFS )
import FiniteMap
import Outputable
-import Control.Monad ( foldM )
-import Control.Monad.ST ( runST )
+import Control.Monad ( foldM, zipWithM )
+import Control.Monad.ST ( ST, runST )
import GHC.Word ( Word(..) )
-import Data.Array.MArray ( MArray, newArray_, readArray, writeArray )
+import Data.Array.MArray
+import Data.Array.Base ( STUArray, UArray(..), unsafeWrite )
import Data.Array.ST ( castSTUArray )
-import Foreign.Ptr ( nullPtr )
import Foreign ( Word16, free )
import Data.Int ( Int64 )
-#if __GLASGOW_HASKELL__ >= 503
+import GHC.Base ( ByteArray# )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
-#else
-import PrelIOBase ( IO(..) )
-import Ptr ( Ptr(..) )
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
- Unlinked BCOs
-%* *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- Unlinked BCOs
-\begin{code}
-- CompiledByteCode represents the result of byte-code
-- compiling a bunch of functions and data types
data UnlinkedBCO
- = UnlinkedBCO Name
- (SizedSeq Word16) -- insns
- (SizedSeq (Either Word FastString)) -- literals
+ = UnlinkedBCO {
+ unlinkedBCOName :: Name,
+ unlinkedBCOArity :: Int,
+ unlinkedBCOInstrs :: ByteArray#, -- insns
+ unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals
-- Either literal words or a pointer to a asciiz
-- string, denoting a label whose *address* should
-- be determined at link time
- (SizedSeq (Either Name PrimOp)) -- ptrs
- (SizedSeq Name) -- itbl refs
+ unlinkedBCOPtrs :: (SizedSeq BCOPtr), -- ptrs
+ unlinkedBCOItbls :: (SizedSeq Name) -- itbl refs
+ }
-nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
+data BCOPtr
+ = BCOPtrName Name
+ | BCOPtrPrimOp PrimOp
+ | BCOPtrBCO UnlinkedBCO
-bcosFreeNames :: [UnlinkedBCO] -> NameSet
--- Finds external references. Remember to remove the names
+-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
-bcosFreeNames bcos
- = free_names `minusNameSet` defined_names
+bcoFreeNames :: UnlinkedBCO -> NameSet
+bcoFreeNames bco
+ = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
where
- defined_names = mkNameSet (map nameOfUnlinkedBCO bcos)
- free_names = foldr (unionNameSets . bco_refs) emptyNameSet bcos
-
- bco_refs (UnlinkedBCO _ _ _ ptrs itbls)
- = mkNameSet [n | Left n <- ssElts ptrs] `unionNameSets`
- mkNameSet (ssElts itbls)
-
--- When translating expressions, we need to distinguish the root
--- BCO for the expression
-type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
+ bco_refs (UnlinkedBCO _ _ _ _ ptrs itbls)
+ = unionManyNameSets (
+ mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
+ mkNameSet (ssElts itbls) :
+ map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
+ )
instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm insns lits ptrs itbls)
+ ppr (UnlinkedBCO nm arity insns lits ptrs itbls)
= sep [text "BCO", ppr nm, text "with",
- int (sizeSS insns), text "insns",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs",
int (sizeSS itbls), text "itbls"]
-\end{code}
+-- -----------------------------------------------------------------------------
+-- The bytecode assembler
-%************************************************************************
-%* *
-\subsection{The bytecode assembler}
-%* *
-%************************************************************************
+-- The object format for bytecodes is: 16 bits for the opcode, and 16
+-- for each field -- so the code can be considered a sequence of
+-- 16-bit ints. Each field denotes either a stack offset or number of
+-- items on the stack (eg SLIDE), and index into the pointer table (eg
+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
+-- bytecode address in this BCO.
-The object format for bytecodes is: 16 bits for the opcode, and 16 for
-each field -- so the code can be considered a sequence of 16-bit ints.
-Each field denotes either a stack offset or number of items on the
-stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
-index into the literal table (eg PUSH_I/D/L), or a bytecode address in
-this BCO.
-
-\begin{code}
-- Top level assembler fn.
assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs proto_bcos tycons
return (ByteCode bcos itblenv)
assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-
-assembleBCO (ProtoBCO nm instrs origin malloced)
+assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset 1 since offset 0
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
- ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
+ ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
<- mkBits findLabel init_asm_state instrs
- let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
+ let asm_insns = ssElts final_insns
+ n_insns = sizeSS final_insns
+
+ insns_arr
+ | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
+ | otherwise = runST (mkInstrArray arity bitmap
+ bsize n_insns asm_insns)
+ insns_barr = case insns_arr of UArray _lo _hi barr -> barr
+
+ let ul_bco = UnlinkedBCO nm arity insns_barr final_lits
+ final_ptrs final_itbls
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
free ptr
+
+mkInstrArray :: Int -> [StgWord] -> Int -> Int -> [Word16]
+ -> ST s (UArray Int Word16)
+mkInstrArray arity bitmap bsize n_insns asm_insns = do
+ (arr :: STUArray s Int Word16) <- newArray_ (0, n_insns + bco_info_w16s)
+ zipWithM (unsafeWrite arr) [bco_info_w16s ..]
+ (fromIntegral n_insns : asm_insns)
+ (arr' :: STUArray s Int StgWord) <- castSTUArray arr
+ writeArray arr' 0 (fromIntegral arity)
+ writeArray arr' 1 (fromIntegral bsize)
+ zipWithM (writeArray arr') [2..] bitmap
+ arr <- castSTUArray arr'
+ unsafeFreeze arr
+ where
+ -- The BCO info (arity, bitmap) goes at the beginning of
+ -- the instruction stream. See Closures.h for details.
+ bco_info_w16s = (1 {- for the arity -} +
+ 1 {- for the bitmap size -} +
+ length bitmap) * (wORD_SIZE `quot` 2)
+
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16,
SizedSeq (Either Word FastString),
- SizedSeq (Either Name PrimOp),
+ SizedSeq BCOPtr,
SizedSeq Name)
data SizedSeq a = SizedSeq !Int [a]
sizeSS :: SizedSeq a -> Int
sizeSS (SizedSeq n r_xs) = n
+-- Bring in all the bci_ bytecode constants.
+#include "Bytecodes.h"
+
-- This is where all the action is (pass 2 of the assembler)
mkBits :: (Int -> Int) -- label finder
-> AsmState
doInstr :: AsmState -> BCInstr -> IO AsmState
doInstr st i
= case i of
- SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n
- ARGCHECK n -> instr2 st i_ARGCHECK n
- STKCHECK n -> instr2 st i_STKCHECK n
- PUSH_L o1 -> instr2 st i_PUSH_L o1
- PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
- PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
- PUSH_G nm -> do (p, st2) <- ptr st nm
- instr2 st2 i_PUSH_G p
- PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
- (np, st3) <- ctoi_itbl st2 pk
- instr3 st3 i_PUSH_AS p np
+ STKCHECK n -> instr2 st bci_STKCHECK n
+ PUSH_L o1 -> instr2 st bci_PUSH_L o1
+ PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
+ PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
+ PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm)
+ instr2 st2 bci_PUSH_G p
+ PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
+ instr2 st2 bci_PUSH_G p
+ PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 bci_PUSH_G p
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 bci_PUSH_ALTS p
+ PUSH_ALTS_UNLIFTED proto pk -> do
+ ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
-> do (np, st2) <- literal st lit
- instr3 st2 i_PUSH_UBX np nws
+ instr3 st2 bci_PUSH_UBX np nws
PUSH_UBX (Right aa) nws
-> do (np, st2) <- addr st aa
- instr3 st2 i_PUSH_UBX np nws
-
- PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
- SLIDE n by -> instr3 st i_SLIDE n by
- ALLOC n -> instr2 st i_ALLOC n
- MKAP off sz -> instr3 st i_MKAP off sz
- UNPACK n -> instr2 st i_UNPACK n
- UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
+ instr3 st2 bci_PUSH_UBX np nws
+
+ PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N
+ PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V
+ PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F
+ PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D
+ PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L
+ PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P
+ PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP
+ PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP
+ PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP
+ PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP
+ PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP
+ PUSH_APPLY_PPPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPPP
+
+ SLIDE n by -> instr3 st bci_SLIDE n by
+ ALLOC_AP n -> instr2 st bci_ALLOC_AP n
+ ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n
+ MKAP off sz -> instr3 st bci_MKAP off sz
+ UNPACK n -> instr2 st bci_UNPACK n
PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
- instr3 st2 i_PACK itbl_no sz
+ instr3 st2 bci_PACK itbl_no sz
LABEL lab -> return st
TESTLT_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTLT_I np (findLabel l)
+ instr3 st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTEQ_I np (findLabel l)
+ instr3 st2 bci_TESTEQ_I np (findLabel l)
TESTLT_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTLT_F np (findLabel l)
+ instr3 st2 bci_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTEQ_F np (findLabel l)
+ instr3 st2 bci_TESTEQ_F np (findLabel l)
TESTLT_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTLT_D np (findLabel l)
+ instr3 st2 bci_TESTLT_D np (findLabel l)
TESTEQ_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTEQ_D np (findLabel l)
- TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
- TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
- CASEFAIL -> instr1 st i_CASEFAIL
- JMP l -> instr2 st i_JMP (findLabel l)
- ENTER -> instr1 st i_ENTER
- RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
- instr2 st2 i_RETURN itbl_no
- CCALL m_addr -> do (np, st2) <- addr st m_addr
- instr2 st2 i_CCALL np
+ instr3 st2 bci_TESTEQ_D np (findLabel l)
+ TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l)
+ TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l)
+ CASEFAIL -> instr1 st bci_CASEFAIL
+ SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
+ JMP l -> instr2 st bci_JMP (findLabel l)
+ ENTER -> instr1 st bci_ENTER
+ RETURN -> instr1 st bci_RETURN
+ RETURN_UBX rep -> instr1 st (return_ubx rep)
+ CCALL off m_addr -> do (np, st2) <- addr st m_addr
+ instr3 st2 bci_CCALL off np
i2s :: Int -> Word16
i2s = fromIntegral
instr1 (st_i0,st_l0,st_p0,st_I0) i1
- = do st_i1 <- addToSS st_i0 (i2s i1)
+ = do st_i1 <- addToSS st_i0 i1
return (st_i1,st_l0,st_p0,st_I0)
instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
literal st (MachWord64 ii) = int64 st (fromIntegral ii)
literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
- ctoi_itbl st pk
- = addr st ret_itbl_addr
- where
- ret_itbl_addr
- = case pk of
- WordRep -> stg_ctoi_ret_R1n_info
- IntRep -> stg_ctoi_ret_R1n_info
- AddrRep -> stg_ctoi_ret_R1n_info
- CharRep -> stg_ctoi_ret_R1n_info
- FloatRep -> stg_ctoi_ret_F1_info
- DoubleRep -> stg_ctoi_ret_D1_info
- VoidRep -> stg_ctoi_ret_V_info
- other | isFollowableRep pk -> stg_ctoi_ret_R1p_info
- -- Includes ArrayRep, ByteArrayRep, as well as
- -- the obvious PtrRep
- | otherwise
- -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk)
-
- itoc_itbl st pk
- = addr st ret_itbl_addr
- where
- ret_itbl_addr
- = case pk of
- CharRep -> stg_gc_unbx_r1_info
- IntRep -> stg_gc_unbx_r1_info
- WordRep -> stg_gc_unbx_r1_info
- AddrRep -> stg_gc_unbx_r1_info
- FloatRep -> stg_gc_f1_info
- DoubleRep -> stg_gc_d1_info
- VoidRep -> nullPtr -- Interpreter.c spots this special case
- other | isFollowableRep pk -> stg_gc_unpt_r1_info
- | otherwise
- -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
-
-foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr ()
-foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr ()
-foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr ()
-foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr ()
-foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr ()
-
-foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr ()
-foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_r1_info :: Ptr ()
-foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr ()
-foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr ()
+
+push_alts WordRep = bci_PUSH_ALTS_N
+push_alts IntRep = bci_PUSH_ALTS_N
+push_alts AddrRep = bci_PUSH_ALTS_N
+push_alts CharRep = bci_PUSH_ALTS_N
+push_alts FloatRep = bci_PUSH_ALTS_F
+push_alts DoubleRep = bci_PUSH_ALTS_D
+push_alts VoidRep = bci_PUSH_ALTS_V
+push_alts pk
+ | is64BitRep pk = bci_PUSH_ALTS_L
+ | isFollowableRep pk = bci_PUSH_ALTS_P
+
+return_ubx WordRep = bci_RETURN_N
+return_ubx IntRep = bci_RETURN_N
+return_ubx AddrRep = bci_RETURN_N
+return_ubx CharRep = bci_RETURN_N
+return_ubx FloatRep = bci_RETURN_F
+return_ubx DoubleRep = bci_RETURN_D
+return_ubx VoidRep = bci_RETURN_V
+return_ubx pk
+ | is64BitRep pk = bci_RETURN_L
+ | isFollowableRep pk = bci_RETURN_P
+
-- The size in 16-bit entities of an instruction.
instrSize16s :: BCInstr -> Int
instrSize16s instr
= case instr of
- STKCHECK _ -> 2
- ARGCHECK _ -> 2
- PUSH_L _ -> 2
- PUSH_LL _ _ -> 3
- PUSH_LLL _ _ _ -> 4
- PUSH_G _ -> 2
- PUSH_AS _ _ -> 3
- PUSH_UBX _ _ -> 3
- PUSH_TAG _ -> 2
- SLIDE _ _ -> 3
- ALLOC _ -> 2
- MKAP _ _ -> 3
- UNPACK _ -> 2
- UPK_TAG _ _ _ -> 4
- PACK _ _ -> 3
- LABEL _ -> 0 -- !!
- TESTLT_I _ _ -> 3
- TESTEQ_I _ _ -> 3
- TESTLT_F _ _ -> 3
- TESTEQ_F _ _ -> 3
- TESTLT_D _ _ -> 3
- TESTEQ_D _ _ -> 3
- TESTLT_P _ _ -> 3
- TESTEQ_P _ _ -> 3
- JMP _ -> 2
- CASEFAIL -> 1
- ENTER -> 1
- RETURN _ -> 2
-
+ STKCHECK{} -> 2
+ PUSH_L{} -> 2
+ PUSH_LL{} -> 3
+ PUSH_LLL{} -> 4
+ PUSH_G{} -> 2
+ PUSH_PRIMOP{} -> 2
+ PUSH_BCO{} -> 2
+ PUSH_ALTS{} -> 2
+ PUSH_ALTS_UNLIFTED{} -> 2
+ PUSH_UBX{} -> 3
+ PUSH_APPLY_N{} -> 1
+ PUSH_APPLY_V{} -> 1
+ PUSH_APPLY_F{} -> 1
+ PUSH_APPLY_D{} -> 1
+ PUSH_APPLY_L{} -> 1
+ PUSH_APPLY_P{} -> 1
+ PUSH_APPLY_PP{} -> 1
+ PUSH_APPLY_PPP{} -> 1
+ PUSH_APPLY_PPPP{} -> 1
+ PUSH_APPLY_PPPPP{} -> 1
+ PUSH_APPLY_PPPPPP{} -> 1
+ PUSH_APPLY_PPPPPPP{} -> 1
+ SLIDE{} -> 3
+ ALLOC_AP{} -> 2
+ ALLOC_PAP{} -> 3
+ MKAP{} -> 3
+ UNPACK{} -> 2
+ PACK{} -> 3
+ LABEL{} -> 0 -- !!
+ TESTLT_I{} -> 3
+ TESTEQ_I{} -> 3
+ TESTLT_F{} -> 3
+ TESTEQ_F{} -> 3
+ TESTLT_D{} -> 3
+ TESTEQ_D{} -> 3
+ TESTLT_P{} -> 3
+ TESTEQ_P{} -> 3
+ JMP{} -> 2
+ CASEFAIL{} -> 1
+ ENTER{} -> 1
+ RETURN{} -> 1
+ RETURN_UBX{} -> 1
+ CCALL{} -> 3
+ SWIZZLE{} -> 3
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
w0 <- readArray a_arr 0
return [w0 :: Word]
)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Connect to actual values for bytecode opcodes}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#include "Bytecodes.h"
-
-i_ARGCHECK = (bci_ARGCHECK :: Int)
-i_PUSH_L = (bci_PUSH_L :: Int)
-i_PUSH_LL = (bci_PUSH_LL :: Int)
-i_PUSH_LLL = (bci_PUSH_LLL :: Int)
-i_PUSH_G = (bci_PUSH_G :: Int)
-i_PUSH_AS = (bci_PUSH_AS :: Int)
-i_PUSH_UBX = (bci_PUSH_UBX :: Int)
-i_PUSH_TAG = (bci_PUSH_TAG :: Int)
-i_SLIDE = (bci_SLIDE :: Int)
-i_ALLOC = (bci_ALLOC :: Int)
-i_MKAP = (bci_MKAP :: Int)
-i_UNPACK = (bci_UNPACK :: Int)
-i_UPK_TAG = (bci_UPK_TAG :: Int)
-i_PACK = (bci_PACK :: Int)
-i_TESTLT_I = (bci_TESTLT_I :: Int)
-i_TESTEQ_I = (bci_TESTEQ_I :: Int)
-i_TESTLT_F = (bci_TESTLT_F :: Int)
-i_TESTEQ_F = (bci_TESTEQ_F :: Int)
-i_TESTLT_D = (bci_TESTLT_D :: Int)
-i_TESTEQ_D = (bci_TESTEQ_D :: Int)
-i_TESTLT_P = (bci_TESTLT_P :: Int)
-i_TESTEQ_P = (bci_TESTEQ_P :: Int)
-i_CASEFAIL = (bci_CASEFAIL :: Int)
-i_ENTER = (bci_ENTER :: Int)
-i_RETURN = (bci_RETURN :: Int)
-i_STKCHECK = (bci_STKCHECK :: Int)
-i_JMP = (bci_JMP :: Int)
-#ifdef bci_CCALL
-i_CCALL = (bci_CCALL :: Int)
-i_SWIZZLE = (bci_SWIZZLE :: Int)
-#else
-i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL."
-i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE."
-#endif
iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
\end{code}
-
\section[ByteCodeGen]{Generate machine-code sequences for foreign import}
\begin{code}
-module ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) where
+module ByteCodeFFI ( mkMarshalCode, moan64 ) where
#include "HsVersions.h"
import Outputable
-import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep )
+import PrimRep ( PrimRep(..), getPrimRepSize )
import ForeignCall ( CCallConv(..) )
-- DON'T remove apparently unused imports here ..
%************************************************************************
%* *
-\subsection{The sizes of things. These are platform-independent.}
-%* *
-%************************************************************************
-
-\begin{code}
-
--- When I push one of these on the H stack, how much does Sp move by?
-taggedSizeW :: PrimRep -> Int
-taggedSizeW pr
- | isFollowableRep pr = 1 {-it's a pointer, Jim-}
- | otherwise = 1 {-the tag-} + getPrimRepSize pr
-
--- The plain size of something, without tag.
-untaggedSizeW :: PrimRep -> Int
-untaggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = getPrimRepSize pr
-
--- How big is this thing's tag?
-sizeOfTagW :: PrimRep -> Int
-sizeOfTagW pr
- | isFollowableRep pr = 0
- | otherwise = 1
-\end{code}
-
-%************************************************************************
-%* *
\subsection{The platform-dependent marshall-code-generator.}
%* *
%************************************************************************
= let -- Don't change this without first consulting Intel Corp :-)
bytes_per_word = 4
- -- addr and result bits offsetsW
- offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
- offset_of_res_bitsW = r_offW + sizeOfTagW r_rep
-
offsets_to_pushW
= concat
- [ let -- where this arg's bits start
- a_bits_offW = a_offW + sizeOfTagW a_rep
- in
- -- reversed because x86 is little-endian
- reverse
- [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
+ [ -- reversed because x86 is little-endian
+ reverse [a_offW .. a_offW + getPrimRepSize a_rep - 1]
-- reversed because args are pushed L -> R onto C stack
| (a_offW, a_rep) <- reverse arg_offs_n_reps
-}
++ movl_offespmem_esi 32
- {- For each arg in args_offs_n_reps, examine the associated PrimRep
- to determine how many payload (non-tag) words there are, and
- whether or not there is a tag. This gives a bunch of offsets on
- the H stack to copy to the C stack:
+ {- For each arg in args_offs_n_reps, examine the associated
+ PrimRep to determine how many words there are. This gives a
+ bunch of offsets on the H stack to copy to the C stack:
movl off1(%esi), %ecx
pushl %ecx
movl 4*(1 /*tag*/ +addr_offW)(%esi), %ecx
call * %ecx
-}
- ++ movl_offesimem_ecx (bytes_per_word * offset_of_addr_bitsW)
+ ++ movl_offesimem_ecx (bytes_per_word * addr_offW)
++ call_star_ecx
{- Nuke the args just pushed and re-establish %esi at the
or
fstps 4(%esi)
-}
- ++ let i32 = movl_eax_offesimem 4
- i64 = movl_eax_offesimem 4 ++ movl_edx_offesimem 8
- f32 = fstps_offesimem 4
- f64 = fstpl_offesimem 4
+ ++ let i32 = movl_eax_offesimem 0
+ i64 = movl_eax_offesimem 0 ++ movl_edx_offesimem 4
+ f32 = fstps_offesimem 0
+ f64 = fstpl_offesimem 0
in
case r_rep of
CharRep -> i32
fromIntegral (0xFF .&. (w `shiftR` 8)),
fromIntegral (0xFF .&. w)]
- -- addr and result bits offsetsW
- offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
- offset_of_res_bitsW = r_offW + sizeOfTagW r_rep
-
offsets_to_pushW
= concat
- [ let -- where this arg's bits start
- a_bits_offW = a_offW + sizeOfTagW a_rep
- in
- [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
+ [ [a_offW .. a_offW + getPrimRepSize a_rep - 1]
| (a_offW, a_rep) <- arg_offs_n_reps
]
-}
[mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp]
- {- For each arg in args_offs_n_reps, examine the associated PrimRep
- to determine how many payload (non-tag) words there are, and
- whether or not there is a tag. This gives a bunch of offsets on
- the H stack. Move the first 6 words into %o0 .. %o5 and the
- rest on the stack, starting at [%sp+92]. Use %g1 as a temp.
+ {- For each arg in args_offs_n_reps, examine the associated
+ PrimRep to determine how many words there are. This gives a
+ bunch of offsets on the H stack. Move the first 6 words into
+ %o0 .. %o5 and the rest on the stack, starting at [%sp+92].
+ Use %g1 as a temp.
-}
++ let doArgW (offW, wordNo)
| wordNo < 6
ld [4*(1 /*tag*/ +addr_offW) + %i0], %g1
call %g1
-}
- ++ [mkLD i0 (bytes_per_word * offset_of_addr_bitsW) g1,
+ ++ [mkLD i0 (bytes_per_word * addr_offW) g1,
mkCALL g1,
mkNOP]
st %f1, [%i0 + 8] -- or the other way round?
-}
- ++ let i32 = [mkST o0 i0 4]
- i64 = [mkST o0 i0 4, mkST o1 i0 8]
- f32 = [mkSTF f0 i0 4]
- f64 = [mkSTF f0 i0 4, mkSTF f1 i0 8]
+ ++ let i32 = [mkST o0 i0 0]
+ i64 = [mkST o0 i0 0, mkST o1 i0 4]
+ f32 = [mkSTF f0 i0 0]
+ f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4]
in
case r_rep of
CharRep -> i32
fromIntegral (0xFF .&. w)]
-- addr and result bits offsetsW
- a_off = (addr_offW + sizeOfTagW AddrRep) * bytes_per_word
- result_off = (r_offW + sizeOfTagW r_rep) * bytes_per_word
+ a_off = addr_offW * bytes_per_word
+ result_off = r_offW * bytes_per_word
linkageArea = 24
- parameterArea = sum [ untaggedSizeW a_rep * bytes_per_word
+ parameterArea = sum [ getPrimRepSize a_rep * bytes_per_word
| (_, a_rep) <- arg_offs_n_reps ]
savedRegisterArea = 4
frameSize = padTo16 (linkageArea + min parameterArea 32 + savedRegisterArea)
pass_parameters [] _ _ = []
pass_parameters ((a_offW, a_rep):args) nextFPR offsetW =
let
- haskellArgOffset = (a_offW + sizeOfTagW a_rep)
- * bytes_per_word
- offsetW' = offsetW + untaggedSizeW a_rep
+ haskellArgOffset = a_offW * bytes_per_word
+ offsetW' = offsetW + getPrimRepSize a_rep
pass_word w
| w < 8 =
.|. (fromIntegral nextFPR `shiftL` 21))
: pass_parameters args (nextFPR+1) offsetW'
_ ->
- concatMap pass_word [0 .. untaggedSizeW a_rep - 1]
+ concatMap pass_word [0 .. getPrimRepSize a_rep - 1]
++ pass_parameters args nextFPR offsetW'
gather_result = case r_rep of
DoubleRep ->
[0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
-- stfs f1, result_off(r31)
- _ | untaggedSizeW r_rep == 2 ->
+ _ | getPrimRepSize r_rep == 2 ->
[0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF),
0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)]
-- stw r3, result_off(r31)
-- stw r4, result_off+4(r31)
- _ | untaggedSizeW r_rep == 1 ->
+ _ | getPrimRepSize r_rep == 1 ->
[0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
-- stw r3, result_off(r31)
in
%
-% (c) The University of Glasgow 2000
+% (c) The University of Glasgow 2002
%
\section[ByteCodeGen]{Generate bytecode from Core}
\begin{code}
-module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr,
- byteCodeGen, coreExprToBCOs
- ) where
+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
-import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
-import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr,
+import ByteCodeInstr
+import ByteCodeFFI ( mkMarshalCode, moan64 )
+import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO,
assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
import ByteCodeLink ( lookupStaticPtr )
import Outputable
import Name ( Name, getName, mkSystemName )
-import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
- idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId )
+import Id
+import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
- nilOL, toOL, concatOL, fromOL )
-import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM,
- addToFM, lookupFM, fmToList )
import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
-import PrimRep ( PrimRep(..) )
+import PrimRep
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy )
-import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
+import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe,
+ isTyVarTy )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Type ( Type, repType, splitFunTys, dropForAlls )
-import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
- isSingleton, lengthIs, notNull )
+import Util
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
import Panic ( GhcException(..) )
import PprType ( pprType )
import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
+import OrdList
import Constants ( wORD_SIZE )
-import List ( intersperse, sortBy, zip4 )
+import Data.List ( intersperse, sortBy, zip4, zip5, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
import GHC.Exts ( Int(..), ByteArray# )
-import Monad ( when )
-import Maybe ( isJust )
-import Char ( ord )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Functions visible from outside this module.}
-%* *
-%************************************************************************
+import Control.Monad ( when, mapAndUnzipM )
+import Data.Char ( ord )
+import Data.Bits
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> ModGuts
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
- (BcM_State proto_bcos final_ctr mallocd, ())
- <- runBc (BcM_State [] 0 [])
- (mapBc (schemeR True []) flatBinds `thenBc_` returnBc ())
- -- ^^
+ (BcM_State final_ctr mallocd, proto_bcos)
+ <- runBc (BcM_State 0 []) (mapM (schemeR True []) flatBinds)
+ -- ^^
-- better be no free vars in these top-level bindings
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
- "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+ "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
assembleBCOs proto_bcos tycs
+-- -----------------------------------------------------------------------------
+-- Generating byte code for an expression
-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
-> CoreExpr
- -> IO UnlinkedBCOExpr
+ -> IO UnlinkedBCO
coreExprToBCOs dflags expr
= do showPass dflags "ByteCodeGen"
annexpr = freeVars expr
fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
- (BcM_State all_proto_bcos final_ctr mallocd, ())
- <- runBc (BcM_State [] 0 [])
+ (BcM_State final_ctr mallocd, proto_bco)
+ <- runBc (BcM_State 0 [])
(schemeR True fvs (invented_id, annexpr))
when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
- dumpIfSet_dyn dflags Opt_D_dump_BCOs
- "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
+ dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
- let root_proto_bco
- = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
- [root_bco] -> root_bco
- auxiliary_proto_bcos
- = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos
-
- auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
- root_bco <- assembleBCO root_proto_bco
-
- return (root_bco, auxiliary_bcos)
-\end{code}
+ assembleBCO proto_bco
-%************************************************************************
-%* *
-\subsection{Compilation schema for the bytecode generator.}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Compilation schema for the bytecode generator
type BCInstrList = OrdList BCInstr
$$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
$$ text "end-env"
where
- pp_one (var, offset) = int offset <> colon <+> ppr var
+ pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var)
cmp_snd x y = compare (snd x) (snd y)
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
-mkProtoBCO nm instrs_ordlist origin mallocd_blocks
- = ProtoBCO nm maybe_with_stack_check origin mallocd_blocks
+mkProtoBCO
+ :: name
+ -> BCInstrList
+ -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
+ -> Int
+ -> Int
+ -> [StgWord]
+ -> [Ptr ()]
+ -> ProtoBCO name
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks
+ = ProtoBCO {
+ protoBCOName = nm,
+ protoBCOInstrs = maybe_with_stack_check,
+ protoBCOBitmap = bitmap,
+ protoBCOBitmapSize = bitmap_size,
+ protoBCOArity = arity,
+ protoBCOExpr = origin,
+ protoBCOPtrs = mallocd_blocks
+ }
where
-- Overestimate the stack usage (in words) of this BCO,
-- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
stack_overest = sum (map bciStackUse peep_d)
+ 10 {- just to be really really sure -}
-
-- Merge local pushes
peep_d = peep (fromOL instrs_ordlist)
peep []
= []
+argBits :: [PrimRep] -> [Bool]
+argBits [] = []
+argBits (rep : args)
+ | isFollowableRep rep = False : argBits args
+ | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
+
+mkBitmap :: [Bool] -> [StgWord]
+mkBitmap [] = []
+mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest
+ where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
+
+chunkToLiveness :: [Bool] -> StgWord
+chunkToLiveness chunk =
+ foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
+
+-- make a bitmap where the slots specified are the *zeros* in the bitmap.
+-- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
+-- just to make the bitmap easier to read).
+intsToBitmap :: Int -> [Int] -> [StgWord]
+intsToBitmap size slots{- must be sorted -}
+ | size <= 0 = []
+ | otherwise =
+ (foldr xor init (map (1 `shiftL`) these)) :
+ intsToBitmap (size - wORD_SIZE_IN_BITS)
+ (map (\x -> x - wORD_SIZE_IN_BITS) rest)
+ where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
+ init
+ | size >= wORD_SIZE_IN_BITS = complement 0
+ | otherwise = (1 `shiftL` size) - 1
+
+wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
+
+-- -----------------------------------------------------------------------------
+-- schemeR
-- Compile code for the right hand side of a let binding.
-- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the
-- resulting BCO a name. Bool indicates top-levelness.
-schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM ()
+schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
schemeR is_top fvs (nm, rhs)
{-
| trace (showSDoc (
schemeR_wrk is_top fvs original_body nm (args, body)
| Just dcon <- maybe_toplevel_null_con_rhs
- = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
+ = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) $
+ ASSERT(null fvs)
emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
- (Right original_body))
- --)
+ (Right original_body) 0 0 [{-no bitmap-}])
| otherwise
- = let all_args = reverse args ++ fvs
- szsw_args = map taggedIdSizeW all_args
+ = let
+ all_args = reverse args ++ fvs
+ arity = length all_args
+ -- these are the args in reverse order. We're compiling a function
+ -- \fv1..fvn x1..xn -> e
+ -- i.e. the fvs come first
+
+ szsw_args = map idSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
- argcheck = unitOL (ARGCHECK szw_args)
+
+ -- make the arg bitmap
+ bits = argBits (reverse (map idPrimRep all_args))
+ bitmap_size = length bits
+ bitmap = mkBitmap bits
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
- emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code)
- (Right original_body))
+ emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
+ arity bitmap_size bitmap)
where
maybe_toplevel_null_con_rhs
nukeTyArgs other = other
--- Let szsw be the sizes in words of some items pushed onto the stack,
--- which has initial depth d'. Return the values which the stack environment
--- should map these items to.
-mkStackOffsets :: Int -> [Int] -> [Int]
-mkStackOffsets original_depth szsw
- = map (subtract 1) (tail (scanl (+) original_depth szsw))
+-- -----------------------------------------------------------------------------
+-- schemeE
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
| otherwise
= -- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
- pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) ->
+ pushAtom d p (AnnVar v) `thenBc` \ (push, szw) ->
returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN v_rep) -- go
+ `snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
v_rep = typePrimRep v_type
schemeE d s p (fvs, AnnLit literal)
- = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) ->
+ = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) ->
let l_rep = literalPrimRep literal
in returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN l_rep) -- go
+ `snocOL` RETURN_UBX l_rep) -- go
+#if 0
{-
+ Disabled for now --SDM (TODO: reinstate later, but do it better)
+
Deal specially with the cases
let x = fn atom1 .. atomn in B
and
-- Shove the args on the stack, including the fn in the non-dcon case
tag_when_push = not is_con
- mkPushes :: Int{-curr depth-} -> [AnnExpr Id VarSet]
- -> BcM (Int{-final depth-}, BCInstrList)
- mkPushes dd []
- | is_con
- = returnBc (dd, nilOL)
- | otherwise
- = pushAtom False dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) ->
- returnBc (dd+fn_szw, fn_push_code)
- mkPushes dd (atom:atoms)
- = pushAtom tag_when_push dd p' (snd atom)
- `thenBc` \ (push1_code, push1_szw) ->
- mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) ->
- returnBc (dd_final, push1_code `appOL` push_rest)
-
+#endif
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
schemeE d s p (fvs, AnnLet binds b)
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
- n = length xs
+ n_binds = length xs
is_local id = not (isTyVar id) && elemFM id p'
fvss = map (filter is_local . varSetElems . fst) rhss
- -- Sizes of tagged free vars, + 1 for the fn
- sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
+ -- Sizes of free vars, + 1 for the fn
+ sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
+
+ -- the arity of each rhs
+ arities = map (length . fst . collect []) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
- p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
- d' = d + n
-
- infos = zipE4 fvss sizes xs [n, n-1 .. 1]
+ p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n_binds 1)))
+ d' = d + n_binds
zipE = zipEqual "schemeE"
- zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
-- ToDo: don't build thunks for things with no free variables
- buildThunk dd ([], size, id, off)
- = returnBc (PUSH_G (Left (getName id))
+ build_thunk dd [] size bco off
+ = returnBc (PUSH_BCO bco
`consOL` unitOL (MKAP (off+size-1) size))
- buildThunk dd ((fv:fvs), size, id, off)
- = pushAtom True dd p' (AnnVar fv)
- `thenBc` \ (push_code, pushed_szw) ->
- buildThunk (dd+pushed_szw) (fvs, size, id, off)
- `thenBc` \ more_push_code ->
+ build_thunk dd (fv:fvs) size bco off = do
+ (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
+ more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off
returnBc (push_code `appOL` more_push_code)
- genThunkCode = mapBc (buildThunk d') infos `thenBc` \ tcodes ->
- returnBc (concatOL tcodes)
+ alloc_code = toOL (zipWith mkAlloc sizes arities)
+ where mkAlloc sz 0 = ALLOC_AP sz
+ mkAlloc sz arity = ALLOC_PAP arity sz
- allocCode = toOL (map ALLOC sizes)
+ compile_bind d' fvs x rhs size off = do
+ bco <- schemeR False fvs (x,rhs)
+ build_thunk d' fvs size bco off
- schemeRs [] _ _ = returnBc ()
- schemeRs (fvs:fvss) (x:xs) (rhs:rhss) =
- schemeR False fvs (x,rhs) `thenBc_` schemeRs fvss xs rhss
- in
- schemeE d' s p' b `thenBc` \ bodyCode ->
- schemeRs fvss xs rhss `thenBc_`
- genThunkCode `thenBc` \ thunkCode ->
- returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
-
-
-
-
-
-schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
- [(DEFAULT, [], (fvs_rhs, rhs))])
-
- | let isFunType var_type
- = case splitTyConApp_maybe var_type of
- Just (tycon,_) | isFunTyCon tycon -> True
- _ -> False
- ty_bndr = repType (idType bndr)
- in isFunType ty_bndr || isTyVarTy ty_bndr
-
- -- Nasty hack; treat
- -- case scrut::suspect of bndr { DEFAULT -> rhs }
- -- as
- -- let bndr = scrut in rhs
- -- when suspect is polymorphic or arrowtyped
- -- So the required strictness properties are not observed.
- -- At some point, must fix this properly.
- = let new_expr
- = (fvs_case,
- AnnLet
- (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
- )
-
- in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
- " Possibly due to strict polymorphic/functional constructor args.\n" ++
- " Your program may leak space unexpectedly.\n")
- (schemeE d s p new_expr)
+ compile_binds =
+ [ compile_bind d' fvs x rhs size n
+ | (fvs, x, rhs, size, n) <-
+ zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1]
+ ]
+ in do
+ body_code <- schemeE d' s p' b
+ thunk_codes <- sequence compile_binds
+ returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
-- Note that it does not matter losing the void-rep thing from the
-- envt (it won't be bound now) because we never look such things up.
- = --trace "automagic mashing of case alts (# VoidRep, a #)" (
- schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [], rhs)])
- -- Note:
- --)
+ = --trace "automagic mashing of case alts (# VoidRep, a #)" $
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+
+ | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2)
+ = --trace "automagic mashing of case alts (# a, VoidRep #)" $
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
-- case .... of x { (# a #) -> ... }
-- to
-- case .... of a { DEFAULT -> ... }
- = --trace "automagic mashing of case alts (# a #)" (
- schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)])
- --)
+ = --trace "automagic mashing of case alts (# a #)" $
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (fvs, AnnCase scrut bndr alts)
- = let
- -- Top of stack is the return itbl, as usual.
- -- underneath it is the pointer to the alt_code BCO.
- -- When an alt is entered, it assumes the returned value is
- -- on top of the itbl.
- ret_frame_sizeW = 2
-
- -- Env and depth in which to compile the alts, not including
- -- any vars bound by the alts themselves
- d' = d + ret_frame_sizeW + taggedIdSizeW bndr
- p' = addToFM p bndr (d' - 1)
-
- scrut_primrep = typePrimRep (idType bndr)
- isAlgCase
- | scrut_primrep == PtrRep
- = True
- | otherwise
- = WARN( scrut_primrep `elem` bad_reps,
- text "Dire warning: strange rep in primitive case:" <+> ppr bndr )
- -- We don't expect to see any of these
- False
- where
- bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep]
-
- -- given an alt, return a discr and code for it.
- codeAlt alt@(discr, binds_f, rhs)
- | isAlgCase
- = let (unpack_code, d_after_unpack, p_after_unpack)
- = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
- in schemeE d_after_unpack s p_after_unpack rhs
- `thenBc` \ rhs_code ->
- returnBc (my_discr alt, unpack_code `appOL` rhs_code)
- | otherwise
- = ASSERT(null binds_f)
- schemeE d' s p' rhs `thenBc` \ rhs_code ->
- returnBc (my_discr alt, rhs_code)
-
- my_discr (DEFAULT, binds, rhs) = NoDiscr
- my_discr (DataAlt dc, binds, rhs)
- | isUnboxedTupleCon dc
- = unboxedTupleException
- | otherwise
- = DiscrP (dataConTag dc - fIRST_TAG)
- my_discr (LitAlt l, binds, rhs)
- = case l of MachInt i -> DiscrI (fromInteger i)
- MachFloat r -> DiscrF (fromRational r)
- MachDouble r -> DiscrD (fromRational r)
- MachChar i -> DiscrI i
- _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
-
- maybe_ncons
- | not isAlgCase = Nothing
- | otherwise
- = case [dc | (DataAlt dc, _, _) <- alts] of
- [] -> Nothing
- (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
-
- in
- mapBc codeAlt alts `thenBc` \ alt_stuff ->
- mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final ->
- let
- alt_final_ac = ARGCHECK (taggedIdSizeW bndr) `consOL` alt_final
- alt_bco_name = getName bndr
- alt_bco = mkProtoBCO alt_bco_name alt_final_ac (Left alts)
- in
- schemeE (d + ret_frame_sizeW)
- (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
-
- emitBc alt_bco `thenBc_`
- returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
-
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE d s p (fvs, AnnNote note body)
= schemeE d s p body
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
- = pushAtom True d p arg `thenBc` \ (push, arg_words) ->
+ = pushAtom d p arg `thenBc` \ (push, arg_words) ->
implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
returnBc (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
-- Case 1
- | is_con_call && null args_r_to_l
+ | Just con <- maybe_dcon, null args_r_to_l
= returnBc (
- (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
+ (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
)
- -- Case 2
- | is_con_call,
- isUnboxedTupleCon con, -- (# ... #)
- [(_,arg1),(_,arg2)] <- args_r_to_l, -- Exactly two args
- let
- isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
- isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
- isVoidRepAtom _ = False
- in
- isVoidRepAtom arg2 -- The first arg is void
- = --trace (if isSingleton args_r_to_l
- -- then "schemeT: unboxed singleton"
- -- else "schemeT: unboxed pair with Void first component") (
- pushAtom True d p arg1 `thenBc` \ (push, szw) ->
- returnBc (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN (atomRep arg1)) -- go
- -- We used to use "schemeT d s p arg1", but that is wrong.
- -- We must use RETURN (because it's an unboxed tuple)
- -- I think that this still does not work: SLPJ Oct 02
-
-- Case 3
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s p ccall_spec fn args_r_to_l
- -- Cases 4 and 5
+ -- Case 4: Constructor application
+ | Just con <- maybe_dcon
+ = if isUnboxedTupleCon con
+ then case args_r_to_l of
+ [arg1,arg2] | isVoidRepAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidRepAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
+ else doConstructorApp d s p con args_r_to_l
+
+ -- Case 5: Tail call of function
| otherwise
- = if is_con_call && isUnboxedTupleCon con
- then unboxedTupleException
- else do_pushery d (map snd args_final_r_to_l)
+ = doTailCall d s p fn args_r_to_l
where
-- Detect and extract relevant info for the tagToEnum kludge.
chomp expr
= case snd expr of
AnnVar v -> ([], v)
- AnnApp f a
- | isTypeAtom (snd a) -> chomp f
- | otherwise -> case chomp f of (az, f) -> (a:az, f)
+ AnnApp f (_,a)
+ | isTypeAtom a -> chomp f
+ | otherwise -> case chomp f of (az, f) -> (a:az, f)
AnnNote n e -> chomp e
other -> pprPanic "schemeT"
(ppr (deAnnotate (panic "schemeT.chomp", other)))
n_args = length args_r_to_l
- isTypeAtom (AnnType _) = True
- isTypeAtom _ = False
-
- -- decide if this is a constructor application, because we need
- -- to rearrange the arguments on the stack if so. For building
- -- a constructor, we put pointers before non-pointers and omit
- -- the tags.
- --
- -- Also if the constructor is not saturated, we just arrange to
- -- call the curried worker instead.
-
+ -- only consider this to be a constructor application iff it is
+ -- saturated. Otherwise, we'll call the constructor wrapper.
maybe_dcon = case isDataConId_maybe fn of
Just con | dataConRepArity con == n_args -> Just con
_ -> Nothing
- is_con_call = isJust maybe_dcon
- (Just con) = maybe_dcon
- args_final_r_to_l
- | not is_con_call
- = args_r_to_l
- | otherwise
- = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
- where isPtr = isFollowableRep . atomRep
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application and enter/return it.
+
+doConstructorApp
+ :: Int -> Sequel -> BCEnv
+ -> DataCon -> [AnnExpr' Id VarSet] -- args, in *reverse* order
+ -> BcM BCInstrList
+doConstructorApp d s p con args = do_pushery d con_args
+ where
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
+ con_args = nptrs ++ ptrs
+ where (ptrs, nptrs) = partition isPtr args
+ isPtr = isFollowableRep . atomRep
- -- make code to push the args and then do the SLIDE-ENTER thing
- tag_when_push = not is_con_call
- narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
- get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
+ narg_words = sum (map (getPrimRepSize.atomRep) con_args)
do_pushery d (arg:args)
- = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) ->
+ = pushAtom d p arg `thenBc` \ (push, arg_words) ->
do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
returnBc (push `appOL` more_push_code)
do_pushery d []
- | Just (CCall ccall_spec) <- isFCallId_maybe fn
- = panic "schemeT.do_pushery: unexpected ccall"
- | otherwise
- = case maybe_dcon of
- Just con -> returnBc (
- (PACK con narg_words `consOL`
- mkSLIDE 1 (d - narg_words - s)) `snocOL`
- ENTER
- )
- Nothing
- -> pushAtom True d p (AnnVar fn)
- `thenBc` \ (push, arg_words) ->
- returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
- (d - s - narg_words)
- `snocOL` ENTER)
-
-
-{- Deal with a CCall. Taggedly push the args onto the stack R->L,
- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
- payloads in Ptr/Byte arrays). Then, generate the marshalling
- (machine) code for the ccall, and create bytecodes to call that and
- then return in the right way.
--}
+ = returnBc ( (PACK con narg_words `consOL`
+ mkSLIDE 1 (d - narg_words - s)) `snocOL`
+ ENTER
+ )
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type. We always just return.
+
+unboxedTupleReturn
+ :: Int -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = do
+ (push, sz) <- pushAtom d p arg
+ returnBc (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+ :: Int -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
+doTailCall init_d s p fn args
+ = do_pushes init_d args (map (primRepToArgRep.atomRep) args)
+ where
+ do_pushes d [] reps = do
+ ASSERTM( null reps )
+ (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ ASSERTM( sz == 1 )
+ returnBc (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
+ do_pushes d args reps = do
+ let (push_apply, n, rest_of_reps) = findPushSeq reps
+ (these_args, rest_of_args) = splitAt n args
+ (next_d, push_code) <- push_seq d these_args
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
+ returnBc (push_code `appOL` (push_apply `consOL` instrs))
+
+ push_seq d [] = return (d, nilOL)
+ push_seq d (arg:args) = do
+ (push_code, sz) <- pushAtom d p arg
+ (final_d, more_push_code) <- push_seq (d+sz) args
+ return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPPPP, 7, rest)
+findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (RepP: RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (RepP: RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (RepP: RepP: RepP: rest)
+ = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (RepP: RepP: rest)
+ = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (RepP: rest)
+ = (PUSH_APPLY_P, 1, rest)
+findPushSeq (RepV: rest)
+ = (PUSH_APPLY_V, 1, rest)
+findPushSeq (RepN: rest)
+ = (PUSH_APPLY_N, 1, rest)
+findPushSeq (RepF: rest)
+ = (PUSH_APPLY_F, 1, rest)
+findPushSeq (RepD: rest)
+ = (PUSH_APPLY_D, 1, rest)
+findPushSeq (RepL: rest)
+ = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+ = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase :: Int -> Sequel -> BCEnv
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p scrut bndr alts is_unboxed_tuple
+ = let
+ -- Top of stack is the return itbl, as usual.
+ -- underneath it is the pointer to the alt_code BCO.
+ -- When an alt is entered, it assumes the returned value is
+ -- on top of the itbl.
+ ret_frame_sizeW = 2
+
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
+
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + idSizeW bndr
+
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
+ d_alts = d_bndr + unlifted_itbl_sizeW
+
+ -- Env in which to compile the alts, not including
+ -- any vars bound by the alts themselves
+ p_alts = addToFM p bndr (d_bndr - 1)
+
+ bndr_ty = idType bndr
+ isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
+
+ -- given an alt, return a discr and code for it.
+ codeALt alt@(DEFAULT, _, rhs)
+ = schemeE d_alts s p_alts rhs `thenBc` \ rhs_code ->
+ returnBc (NoDiscr, rhs_code)
+ codeAlt alt@(discr, bndrs, rhs)
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
+ returnBc (my_discr alt, rhs_code)
+ -- algebraic alt with some binders
+ | ASSERT(isAlgCase) otherwise =
+ let
+ (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs
+ ptr_sizes = map idSizeW ptrs
+ nptrs_sizes = map idSizeW nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = addListToFM p_alts
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ in do
+ rhs_code <- schemeE (d_alts+size) s p' rhs
+ return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
+ where
+ real_bndrs = filter (not.isTyVar) bndrs
+
+
+ my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
+ my_discr (DataAlt dc, binds, rhs)
+ | isUnboxedTupleCon dc
+ = unboxedTupleException
+ | otherwise
+ = DiscrP (dataConTag dc - fIRST_TAG)
+ my_discr (LitAlt l, binds, rhs)
+ = case l of MachInt i -> DiscrI (fromInteger i)
+ MachFloat r -> DiscrF (fromRational r)
+ MachDouble r -> DiscrD (fromRational r)
+ MachChar i -> DiscrI i
+ _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+ maybe_ncons
+ | not isAlgCase = Nothing
+ | otherwise
+ = case [dc | (DataAlt dc, _, _) <- alts] of
+ [] -> Nothing
+ (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
+ bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots)
+ where
+ binds = fmToList p
+ rel_slots = concat (map spread binds)
+ spread (id, offset)
+ | isFollowableRep (idPrimRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
+
+ in do
+ alt_stuff <- mapM codeAlt alts
+ alt_final <- mkMultiBranch maybe_ncons alt_stuff
+ let
+ alt_bco_name = getName bndr
+ alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
+ 0{-no arity-} d{-bitmap size-} bitmap
+ -- in
+-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+-- "\n bitmap = " ++ show bitmap) $ do
+ scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
+ alt_bco' <- emitBc alt_bco
+ let push_alts
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty)
+ returnBc (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
+-- payloads in Ptr/Byte arrays). Then, generate the marshalling
+-- (machine) code for the ccall, and create bytecodes to call that and
+-- then return in the right way.
+
generateCCall :: Int -> Sequel -- stack and sequel depths
-> BCEnv
-> CCallSpec -- where to call
-> Id -- of target, for type info
- -> [AnnExpr Id VarSet] -- args (atoms)
+ -> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
= let
-- useful constants
- addr_usizeW = untaggedSizeW AddrRep
- addr_tsizeW = taggedSizeW AddrRep
+ addr_sizeW = getPrimRepSize AddrRep
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
-- PrimRep of what was actually pushed.
pargs d [] = returnBc []
- pargs d ((_,a):az)
+ pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
in case splitTyConApp_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
Just (t, _)
- | t == foreignObjPrimTyCon
- -> pushAtom False{-irrelevant-} d p a
- `thenBc` \ (push_fo, _) ->
- let foro_szW = taggedSizeW PtrRep
- d_now = d + addr_tsizeW
- code = push_fo `appOL` toOL [
- UPK_TAG addr_usizeW 0 0,
- SLIDE addr_tsizeW foro_szW
- ]
- in pargs d_now az `thenBc` \ rest ->
- returnBc ((code, AddrRep) : rest)
-
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
- -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrPtrsHdrSize d p a
`thenBc` \ code ->
returnBc ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
- -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrWordsHdrSize d p a
`thenBc` \ code ->
returnBc ((code,AddrRep):rest)
-- Default case: push taggedly, but otherwise intact.
other
- -> pushAtom True d p a `thenBc` \ (code_a, sz_a) ->
+ -> pushAtom d p a `thenBc` \ (code_a, sz_a) ->
pargs (d+sz_a) az `thenBc` \ rest ->
returnBc ((code_a, atomRep a) : rest)
-- the stack but then advance it over the headers, so as to
-- point to the payload.
parg_ArrayishRep hdrSizeW d p a
- = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) ->
+ = pushAtom d p a `thenBc` \ (push_fo, _) ->
-- The ptr points at the header. Advance it over the
- -- header and then pretend this is an Addr# (push a tag).
+ -- header and then pretend this is an Addr#.
returnBc (push_fo `snocOL`
- SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep
- * wORD_SIZE)
- `snocOL`
- PUSH_TAG addr_usizeW)
+ SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep
+ * wORD_SIZE))
in
- pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
+ pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
push_args = concatOL pushs_arg
- d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
+ d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l)
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
= panic "ByteCodeGen.generateCCall: missing or invalid World token?"
{-
Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
- are on the stack. Now push an unboxed, tagged Addr# indicating
+ are on the stack. Now push an unboxed Addr# indicating
the C function to call. Then push a dummy placeholder for the
result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
-- push the Addr#
(push_Addr, d_after_Addr)
| is_static
- = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
- PUSH_TAG addr_usizeW],
- d_after_args + addr_tsizeW)
+ = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
+ d_after_args + addr_sizeW)
| otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
-- this is a VoidRep (tag).
- r_usizeW = untaggedSizeW r_rep
- r_tsizeW = taggedSizeW r_rep
- d_after_r = d_after_Addr + r_tsizeW
+ r_sizeW = getPrimRepSize r_rep
+ d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
then nilOL
- else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
- `appOL`
- unitOL (PUSH_TAG r_usizeW)
+ else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
-- generate the marshalling code we're going to call
r_offW = 0
- addr_offW = r_tsizeW
- arg1_offW = r_tsizeW + addr_tsizeW
+ addr_offW = r_sizeW
+ arg1_offW = r_sizeW + addr_sizeW
args_offW = map (arg1_offW +)
- (init (scanl (+) 0 (map taggedSizeW a_reps)))
+ (init (scanl (+) 0 (map getPrimRepSize a_reps)))
in
ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
recordMallocBc addr_of_marshaller `thenBc_`
let
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction will temporarily shift the stack pointer up by
+ -- this much during the call, and shift it down again afterwards.
+ -- This is so that we don't have to worry about constructing
+ -- a bitmap to describe the stack layout of the call: the
+ -- contents of this part of the stack are irrelevant anyway,
+ -- it is only used to communicate the arguments to the
+ -- marshalling code.
+ stk_offset = d_after_r - s
+
-- do the call
- do_call = unitOL (CCALL (castPtr addr_of_marshaller))
+ do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
-- slide and return
- wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
- `snocOL` RETURN r_rep
+ wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
+ `snocOL` RETURN_UBX r_rep
in
- --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
+ --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $
returnBc (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
- --)
-- Make a dummy literal, to be used as a placeholder for FFI return
WordRep -> MachWord 0
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
- AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
+ AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0
_ -> moan64 "mkDummyLiteral" (ppr pr)
blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
in
- --trace (showSDoc (ppr (a_reps, r_reps))) (
+ --trace (showSDoc (ppr (a_reps, r_reps))) $
if ok then maybe_r_rep_to_go else blargh
- --)
-
-atomRep (AnnVar v) = typePrimRep (idType v)
-atomRep (AnnLit l) = literalPrimRep l
-atomRep (AnnNote n b) = atomRep (snd b)
-atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
-atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
-atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
-- Compile code which expects an unboxed Int on the top of stack,
-- (call it i), and pushes the i'th closure in the supplied list
mkStep l_exit (my_label, next_label, n, name_for_n)
= toOL [LABEL my_label,
TESTEQ_I n next_label,
- PUSH_G (Left name_for_n),
+ PUSH_G name_for_n,
JMP l_exit]
--- Make code to unpack the top-of-stack constructor onto the stack,
--- adding tags for the unboxed bits. Takes the PrimReps of the
--- constructor's arguments. off_h and off_s are travelling offsets
--- along the constructor and the stack.
---
--- Supposing a constructor in the heap has layout
---
--- Itbl p_1 ... p_i np_1 ... np_j
---
--- then we add to the stack, shown growing down, the following:
---
--- (previous stack)
--- p_i
--- ...
--- p_1
--- np_j
--- tag_for(np_j)
--- ..
--- np_1
--- tag_for(np_1)
---
--- so that in the common case (ptrs only) a single UNPACK instr can
--- copy all the payload of the constr onto the stack with no further ado.
-
-mkUnpackCode :: [Id] -- constr args
- -> Int -- depth before unpack
- -> BCEnv -- env before unpack
- -> (BCInstrList, Int, BCEnv)
-mkUnpackCode vars d p
- = --trace ("mkUnpackCode: " ++ showSDocDebug (ppr vars)
- -- ++ " --> " ++ show d' ++ "\n" ++ showSDocDebug (ppBCEnv p')
- -- ++ "\n") (
- (code_p `appOL` code_np, d', p')
- --)
- where
- -- vars with reps
- vreps = [(var, typePrimRep (idType var)) | var <- vars]
-
- -- ptrs and nonptrs, forward
- vreps_p = filter (isFollowableRep.snd) vreps
- vreps_np = filter (not.isFollowableRep.snd) vreps
-
- -- the order in which we will augment the environment
- vreps_env = reverse vreps_p ++ reverse vreps_np
-
- -- new env and depth
- vreps_env_tszsw = map (taggedSizeW.snd) vreps_env
- p' = addListToFM p (zip (map fst vreps_env)
- (mkStackOffsets d vreps_env_tszsw))
- d' = d + sum vreps_env_tszsw
-
- -- code to unpack the ptrs
- ptrs_szw = sum (map (untaggedSizeW.snd) vreps_p)
- code_p | null vreps_p = nilOL
- | otherwise = unitOL (UNPACK ptrs_szw)
-
- -- code to unpack the nonptrs
- vreps_env_uszw = sum (map (untaggedSizeW.snd) vreps_env)
- code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
- do_nptrs off_h off_s [] = nilOL
- do_nptrs off_h off_s (npr:nprs)
- | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep,
- CharRep, AddrRep, StablePtrRep]
- = approved
- | otherwise
- = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr)
- where
- approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest
- theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
- usizeW = untaggedSizeW npr
- tsizeW = taggedSizeW npr
-
+-- -----------------------------------------------------------------------------
+-- pushAtom
-- Push an atom onto the stack, returning suitable code & number of
--- stack words used. Pushes it either tagged or untagged, since
--- pushAtom is used to set up the stack prior to copying into the
--- heap for both APs (requiring tags) and constructors (which don't).
---
--- NB this means NO GC between pushing atoms for a constructor and
--- copying them into the heap. It probably also means that
--- tail calls MUST be of the form atom{atom ... atom} since if the
--- expression head was allowed to be arbitrary, there could be GC
--- in between pushing the arg atoms and completing the head.
--- (not sure; perhaps the allocate/doYouWantToGC interface means this
--- isn't a problem; but only if arbitrary graph construction for the
--- head doesn't leave this BCO, since GC might happen at the start of
--- each BCO (we consult doYouWantToGC there).
+-- stack words used.
--
--- Blargh. JRS 001206
---
--- NB (further) that the env p must map each variable to the highest-
--- numbered stack slot for it. For example, if the stack has depth 4
--- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
--- the tag in stack[5], the stack will have depth 6, and p must map v to
--- 5 and not to 4. Stack locations are numbered from zero, so a depth
--- 6 stack has valid words 0 .. 5.
+-- The env p must map each variable to the highest- numbered stack
+-- slot for it. For example, if the stack has depth 4 and we
+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
+-- the tag in stack[5], the stack will have depth 6, and p must map v
+-- to 5 and not to 4. Stack locations are numbered from zero, so a
+-- depth 6 stack has valid words 0 .. 5.
+
+pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
+
+pushAtom d p (AnnApp f (_, AnnType _))
+ = pushAtom d p (snd f)
+
+pushAtom d p (AnnNote note e)
+ = pushAtom d p (snd e)
+
+pushAtom d p (AnnLam x e)
+ | isTyVar x
+ = pushAtom d p (snd e)
-pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
-pushAtom tagged d p (AnnVar v)
+pushAtom d p (AnnVar v)
| idPrimRep v == VoidRep
- = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
- else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
+ = returnBc (nilOL, 0)
| isFCallId v
= pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
| Just primop <- isPrimOpId_maybe v
- = returnBc (unitOL (PUSH_G (Right primop)), 1)
+ = returnBc (unitOL (PUSH_PRIMOP primop), 1)
| otherwise
- = let {-
- str = "\npushAtom " ++ showSDocDebug (ppr v)
- ++ " :: " ++ showSDocDebug (pprType (idType v))
- ++ ", depth = " ++ show d
- ++ ", tagged = " ++ show tagged ++ ", env =\n" ++
- showSDocDebug (ppBCEnv p)
- ++ " --> words: " ++ show (snd result) ++ "\n" ++
- showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
- ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
- -}
-
+ = let
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
+ --
result
= case lookupBCEnv_maybe p v of
- Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
- Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
+ Just d_v -> (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
+ Nothing -> ASSERT(sz == 1) (unitOL (PUSH_G nm), sz)
nm = case isDataConId_maybe v of
Just c -> getName c
Nothing -> getName v
- sz_t = taggedIdSizeW v
- sz_u = untaggedIdSizeW v
- nwords = if tagged then sz_t else sz_u
+ sz = idSizeW v
in
returnBc result
-pushAtom True d p (AnnLit lit)
- = pushAtom False d p (AnnLit lit) `thenBc` \ (ubx_code, ubx_size) ->
- returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
-pushAtom False d p (AnnLit lit)
+pushAtom d p (AnnLit lit)
= case lit of
MachLabel fs -> code CodePtrRep
MachWord w -> code WordRep
MachStr s -> pushStr s
where
code rep
- = let size_host_words = untaggedSizeW rep
+ = let size_host_words = getPrimRepSize rep
in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
-- sigh, a string in the heap is no good to us.
-- We need a static C pointer, since the type of
-- a string literal is Addr#. So, copy the string
- -- into C land and introduce a memory leak
- -- at the same time.
+ -- into C land and remember the pointer so we can
+ -- free it later.
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
-- Get the addr on the stack, untaggedly
returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
-
-
-
-
-pushAtom tagged d p (AnnApp f (_, AnnType _))
- = pushAtom tagged d p (snd f)
-
-pushAtom tagged d p (AnnNote note e)
- = pushAtom tagged d p (snd e)
-
-pushAtom tagged d p (AnnLam x e)
- | isTyVar x
- = pushAtom tagged d p (snd e)
-
-pushAtom tagged d p other
+pushAtom d p other
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
-foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+foreign import ccall unsafe "memcpy"
+ memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+-- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
+
mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
-- a hint; generates better code
-- Nothing is always safe
in
mkTree notd_ways init_lo init_hi
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Supporting junk for the compilation schemes}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Supporting junk for the compilation schemes
-- Describes case alts
data Discr
ppr NoDiscr = text "DEF"
--- Find things in the BCEnv (the what's-on-the-stack-env)
--- See comment preceding pushAtom for precise meaning of env contents
---lookupBCEnv :: BCEnv -> Id -> Int
---lookupBCEnv env nm
--- = case lookupFM env nm of
--- Nothing -> pprPanic "lookupBCEnv"
--- (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
--- Just xx -> xx
-
lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
lookupBCEnv_maybe = lookupFM
-
-taggedIdSizeW, untaggedIdSizeW :: Id -> Int
-taggedIdSizeW = taggedSizeW . typePrimRep . idType
-untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
+idSizeW :: Id -> Int
+idSizeW id = getPrimRepSize (typePrimRep (idType id))
unboxedTupleException :: a
unboxedTupleException
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
bind x f = f x
-\end{code}
+isTypeAtom :: AnnExpr' id ann -> Bool
+isTypeAtom (AnnType _) = True
+isTypeAtom _ = False
-%************************************************************************
-%* *
-\subsection{The bytecode generator's monad}
-%* *
-%************************************************************************
+isVoidRepAtom :: AnnExpr' id ann -> Bool
+isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
+isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
+isVoidRepAtom _ = False
+
+atomRep :: AnnExpr' Id ann -> PrimRep
+atomRep (AnnVar v) = typePrimRep (idType v)
+atomRep (AnnLit l) = literalPrimRep l
+atomRep (AnnNote n b) = atomRep (snd b)
+atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
+atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
+atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
+
+-- Let szsw be the sizes in words of some items pushed onto the stack,
+-- which has initial depth d'. Return the values which the stack environment
+-- should map these items to.
+mkStackOffsets :: Int -> [Int] -> [Int]
+mkStackOffsets original_depth szsw
+ = map (subtract 1) (tail (scanl (+) original_depth szsw))
+
+-- -----------------------------------------------------------------------------
+-- The bytecode generator's monad
-\begin{code}
data BcM_State
- = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
- nextlabel :: Int, -- for generating local labels
- malloced :: [Ptr ()] } -- ptrs malloced for current BCO
- -- Should be free()d when it is GCd
-type BcM r = BcM_State -> IO (BcM_State, r)
+ = BcM_State {
+ nextlabel :: Int, -- for generating local labels
+ malloced :: [Ptr ()] } -- ptrs malloced for current BCO
+ -- Should be free()d when it is GCd
+
+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
ioToBc :: IO a -> BcM a
-ioToBc io st = do x <- io
- return (st, x)
+ioToBc io = BcM $ \st -> do
+ x <- io
+ return (st, x)
runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
-runBc st0 m = do (st1, res) <- m st0
- return (st1, res)
+runBc st0 (BcM m) = do
+ (st1, res) <- m st0
+ return (st1, res)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
-thenBc expr cont st0
- = do (st1, q) <- expr st0
- (st2, r) <- cont q st1
- return (st2, r)
+thenBc (BcM expr) cont = BcM $ \st0 -> do
+ (st1, q) <- expr st0
+ let BcM k = cont q
+ (st2, r) <- k st1
+ return (st2, r)
thenBc_ :: BcM a -> BcM b -> BcM b
-thenBc_ expr cont st0
- = do (st1, q) <- expr st0
- (st2, r) <- cont st1
- return (st2, r)
+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
+ (st1, q) <- expr st0
+ (st2, r) <- cont st1
+ return (st2, r)
returnBc :: a -> BcM a
-returnBc result st = return (st, result)
-
+returnBc result = BcM $ \st -> (return (st, result))
-mapBc :: (a -> BcM b) -> [a] -> BcM [b]
-mapBc f [] = returnBc []
-mapBc f (x:xs)
- = f x `thenBc` \ r ->
- mapBc f xs `thenBc` \ rs ->
- returnBc (r:rs)
+instance Monad BcM where
+ (>>=) = thenBc
+ (>>) = thenBc_
+ return = returnBc
-emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
-emitBc bco st
- = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
-
-newbcoBc :: BcM ()
-newbcoBc st
- | notNull (malloced st)
- = panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
- | otherwise
- = return (st, ())
+emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+ = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
recordMallocBc :: Ptr a -> BcM ()
-recordMallocBc a st
- = return (st{malloced = castPtr a : malloced st}, ())
+recordMallocBc a
+ = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
getLabelBc :: BcM Int
-getLabelBc st
- = return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
+getLabelBc
+ = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
getLabelsBc :: Int -> BcM [Int]
-getLabelsBc n st
- = let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
-
+getLabelsBc n
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
\end{code}
\section[ByteCodeInstrs]{Bytecode instruction definitions}
\begin{code}
-module ByteCodeInstr ( BCInstr(..), ProtoBCO(..),
- nameOfProtoBCO, bciStackUse ) where
+module ByteCodeInstr (
+ BCInstr(..), ProtoBCO(..), StgWord, bciStackUse
+ ) where
#include "HsVersions.h"
+#include "MachDeps.h"
import Outputable
import Name ( Name )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
import GHC.Ptr
-\end{code}
-%************************************************************************
-%* *
-\subsection{Bytecodes, and Outputery.}
-%* *
-%************************************************************************
+import Data.Word
-\begin{code}
+-- ----------------------------------------------------------------------------
+-- Bytecode instructions
-data ProtoBCO a
- = ProtoBCO a -- name, in some sense
- [BCInstr] -- instrs
- -- what the BCO came from
- (Either [AnnAlt Id VarSet]
- (AnnExpr Id VarSet))
- [Ptr ()] -- malloc'd; free when BCO is GCd
+-- The appropriate StgWord type for this platform (needed for bitmaps)
+#if SIZEOF_HSWORD == 4
+type StgWord = Word32
+#else
+type StgWord = Word64
+#endif
-nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm
+data ProtoBCO a
+ = ProtoBCO {
+ protoBCOName :: a, -- name, in some sense
+ protoBCOInstrs :: [BCInstr], -- instrs
+ -- arity and GC info
+ protoBCOBitmap :: [StgWord],
+ protoBCOBitmapSize :: Int,
+ protoBCOArity :: Int,
+ -- what the BCO came from
+ protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
+ -- malloc'd pointers
+ protoBCOPtrs :: [Ptr ()]
+ }
type LocalLabel = Int
data BCInstr
-- Messing with the stack
- = ARGCHECK Int
- | STKCHECK Int
+ = STKCHECK Int
+
-- Push locals (existing bits of the stack)
| PUSH_L Int{-offset-}
| PUSH_LL Int Int{-2 offsets-}
| PUSH_LLL Int Int Int{-3 offsets-}
- -- Push a ptr
- | PUSH_G (Either Name PrimOp)
+
+ -- Push a ptr (these all map to PUSH_G really)
+ | PUSH_G Name
+ | PUSH_PRIMOP PrimOp
+ | PUSH_BCO (ProtoBCO Name)
+
-- Push an alt continuation
- | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
- -- PrimRep so we know which itbl
+ | PUSH_ALTS (ProtoBCO Name)
+ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) PrimRep
+
-- Pushing literals
- | PUSH_UBX (Either Literal (Ptr ()))
- Int -- push this int/float/double/addr, NO TAG, on the stack
- -- Int is # of words to copy from literal pool
- -- Eitherness reflects the difficulty of dealing with
- -- MachAddr here, mostly due to the excessive
- -- (and unnecessary) restrictions imposed by the designers
- -- of the new Foreign library. In particular it is quite
- -- impossible to convert an Addr to any other integral type,
- -- and it appears impossible to get hold of the bits of an
- -- addr, even though we need to to assemble BCOs.
-
- | PUSH_TAG Int -- push this tag on the stack
+ | PUSH_UBX (Either Literal (Ptr ())) Int
+ -- push this int/float/double/addr, on the stack. Int
+ -- is # of words to copy from literal pool. Eitherness reflects
+ -- the difficulty of dealing with MachAddr here, mostly due to
+ -- the excessive (and unnecessary) restrictions imposed by the
+ -- designers of the new Foreign library. In particular it is
+ -- quite impossible to convert an Addr to any other integral
+ -- type, and it appears impossible to get hold of the bits of
+ -- an addr, even though we need to to assemble BCOs.
+
+ -- various kinds of application
+ | PUSH_APPLY_N
+ | PUSH_APPLY_V
+ | PUSH_APPLY_F
+ | PUSH_APPLY_D
+ | PUSH_APPLY_L
+ | PUSH_APPLY_P
+ | PUSH_APPLY_PP
+ | PUSH_APPLY_PPP
+ | PUSH_APPLY_PPPP
+ | PUSH_APPLY_PPPPP
+ | PUSH_APPLY_PPPPPP
+ | PUSH_APPLY_PPPPPPP
| SLIDE Int{-this many-} Int{-down by this much-}
+
-- To do with the heap
- | ALLOC Int -- make an AP_UPD with this many payload words, zeroed
- | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
- | UNPACK Int -- unpack N ptr words from t.o.s Constr
- | UPK_TAG Int Int Int
- -- unpack N non-ptr words from offset M in constructor
- -- K words down the stack
+ | ALLOC_AP Int -- make an AP with this many payload words
+ | ALLOC_PAP Int Int -- make a PAP with this arity / payload words
+ | MKAP Int{-ptr to AP/PAP is this far down stack-} Int{-# words-}
+ | UNPACK Int -- unpack N words from t.o.s Constr
| PACK DataCon Int
-- after assembly, the DataCon is an index into the
-- itbl array
| JMP LocalLabel
-- For doing calls to C (via glue code generated by ByteCodeFFI)
- | CCALL (Ptr ()) -- of the glue code
- | SWIZZLE Int Int -- to the ptr N words down the stack,
- -- add M (interpreted as a signed 16-bit entity)
+ | CCALL Int -- stack frame size
+ (Ptr ()) -- addr of the glue code
+
+ -- For doing magic ByteArray passing to foreign calls
+ | SWIZZLE Int -- to the ptr N words down the stack,
+ Int -- add M (interpreted as a signed 16-bit entity)
-- To Infinity And Beyond
| ENTER
- | RETURN PrimRep
- -- unboxed value on TOS. Use tag to find underlying ret itbl
- -- and return as per that.
+ | RETURN -- return a lifted value
+ | RETURN_UBX PrimRep -- return an unlifted value, here's its rep
+-- -----------------------------------------------------------------------------
+-- Printing bytecode instructions
instance Outputable a => Outputable (ProtoBCO a) where
- ppr (ProtoBCO name instrs origin malloced)
- = (text "ProtoBCO" <+> ppr name <+> text (show malloced) <> colon)
+ ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
+ = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
+ <+> text (show malloced) <> colon)
+ $$ nest 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap))
$$ nest 6 (vcat (map ppr instrs))
$$ case origin of
Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
instance Outputable BCInstr where
ppr (STKCHECK n) = text "STKCHECK" <+> int n
- ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
- ppr (PUSH_G (Left nm)) = text "PUSH_G " <+> ppr nm
- ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
+ ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
+ ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
- ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
+ ppr (PUSH_BCO bco) = text "PUSH_BCO" <+> nest 3 (ppr bco)
+ ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco
+ ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa)
+ ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
+ ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
+ ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
+ ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
+ ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
+ ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
+ ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
+ ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
+ ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
+ ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
+ ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
+ ppr PUSH_APPLY_PPPPPPP = text "PUSH_APPLY_PPPPPPP"
- ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
- ppr (ALLOC sz) = text "ALLOC " <+> int sz
+ ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
+ ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
<+> int offset <+> text "stkoff"
ppr (UNPACK sz) = text "UNPACK " <+> int sz
- ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words"
- <+> int m <> text "conoff"
- <+> int k <> text "stkoff"
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
ppr (LABEL lab) = text "__" <> int lab <> colon
ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
ppr (JMP lab) = text "JMP" <+> int lab
ppr CASEFAIL = text "CASEFAIL"
ppr ENTER = text "ENTER"
- ppr (RETURN pk) = text "RETURN " <+> ppr pk
- ppr (CCALL marshall_addr) = text "CCALL " <+> text "marshall code at"
+ ppr RETURN = text "RETURN"
+ ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
+ ppr (CCALL off marshall_addr) = text "CCALL " <+> int off
+ <+> text "marshall code at"
<+> text (show marshall_addr)
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
<+> text "by" <+> int n
+-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
-- correct, or overestimates of reality, to be safe.
+
bciStackUse :: BCInstr -> Int
-bciStackUse (STKCHECK n) = 0
-bciStackUse (ARGCHECK n) = 0
-bciStackUse (PUSH_L offset) = 1
-bciStackUse (PUSH_LL o1 o2) = 2
-bciStackUse (PUSH_LLL o1 o2 o3) = 3
-bciStackUse (PUSH_G globalish) = 1
-bciStackUse (PUSH_AS nm pk) = 2
-bciStackUse (PUSH_UBX lit nw) = nw
-bciStackUse (PUSH_TAG n) = 1
-bciStackUse (ALLOC sz) = 1
+bciStackUse STKCHECK{} = 0
+bciStackUse PUSH_L{} = 1
+bciStackUse PUSH_LL{} = 2
+bciStackUse PUSH_LLL{} = 3
+bciStackUse PUSH_G{} = 1
+bciStackUse PUSH_PRIMOP{} = 1
+bciStackUse PUSH_BCO{} = 1
+bciStackUse PUSH_ALTS{} = 2
+bciStackUse PUSH_ALTS_UNLIFTED{} = 2
+bciStackUse (PUSH_UBX _ nw) = nw
+bciStackUse PUSH_APPLY_N{} = 1
+bciStackUse PUSH_APPLY_V{} = 1
+bciStackUse PUSH_APPLY_F{} = 1
+bciStackUse PUSH_APPLY_D{} = 1
+bciStackUse PUSH_APPLY_L{} = 1
+bciStackUse PUSH_APPLY_P{} = 1
+bciStackUse PUSH_APPLY_PP{} = 1
+bciStackUse PUSH_APPLY_PPP{} = 1
+bciStackUse PUSH_APPLY_PPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPPPP{} = 1
+bciStackUse ALLOC_AP{} = 1
+bciStackUse ALLOC_PAP{} = 1
bciStackUse (UNPACK sz) = sz
-bciStackUse (UPK_TAG n m k) = n + 1{-tag-}
-bciStackUse (LABEL lab) = 0
-bciStackUse (TESTLT_I i lab) = 0
-bciStackUse (TESTEQ_I i lab) = 0
-bciStackUse (TESTLT_F f lab) = 0
-bciStackUse (TESTEQ_F f lab) = 0
-bciStackUse (TESTLT_D d lab) = 0
-bciStackUse (TESTEQ_D d lab) = 0
-bciStackUse (TESTLT_P i lab) = 0
-bciStackUse (TESTEQ_P i lab) = 0
-bciStackUse CASEFAIL = 0
-bciStackUse (JMP lab) = 0
-bciStackUse ENTER = 0
-bciStackUse (RETURN pk) = 0
-bciStackUse (CCALL marshall_addr) = 0
-bciStackUse (SWIZZLE stkoff n) = 0
+bciStackUse LABEL{} = 0
+bciStackUse TESTLT_I{} = 0
+bciStackUse TESTEQ_I{} = 0
+bciStackUse TESTLT_F{} = 0
+bciStackUse TESTEQ_F{} = 0
+bciStackUse TESTLT_D{} = 0
+bciStackUse TESTEQ_D{} = 0
+bciStackUse TESTLT_P{} = 0
+bciStackUse TESTEQ_P{} = 0
+bciStackUse CASEFAIL{} = 0
+bciStackUse JMP{} = 0
+bciStackUse ENTER{} = 0
+bciStackUse RETURN{} = 0
+bciStackUse RETURN_UBX{} = 1
+bciStackUse CCALL{} = 0
+bciStackUse SWIZZLE{} = 0
-- These insns actually reduce stack use, but we need the high-tide level,
-- so can't use this info. Not that it matters much.
-bciStackUse (SLIDE n d) = 0
-bciStackUse (MKAP offset sz) = 0
-bciStackUse (PACK dcon sz) = 1 -- worst case is PACK 0 words
-
+bciStackUse SLIDE{} = 0
+bciStackUse MKAP{} = 0
+bciStackUse PACK{} = 1 -- worst case is PACK 0 words
\end{code}
#include "HsVersions.h"
import ByteCodeItbls ( ItblEnv, ItblPtr )
-import ByteCodeAsm ( UnlinkedBCO(..), sizeSS, ssElts )
+import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
import ObjLink ( lookupSymbol )
import Name ( Name, nameModule, nameOccName, isExternalName )
-- Standard libraries
import GHC.Word ( Word(..) )
-import Data.Array.IArray ( array )
-import Data.Array.Base ( UArray(..) )
-import Foreign ( Word16 )
+import Data.Array.IArray ( listArray )
+import Data.Array.Base
+import GHC.Arr ( STArray(..) )
import Control.Exception ( throwDyn )
+import Control.Monad ( zipWithM )
+import Control.Monad.ST ( stToIO )
import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
+import GHC.Base ( writeArray#, RealWorld, Int(..) )
\end{code}
\begin{code}
type ClosureEnv = NameEnv (Name, HValue)
-data HValue = HValue -- dummy type, actually a pointer to some Real Code.
+newtype HValue = HValue (forall a . a)
emptyClosureEnv = emptyNameEnv
-}
linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
-linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
--- Raises an IO exception on failure
- = do let insns = ssElts insnsSS
- literals = ssElts literalsSS
+linkBCO ie ce ul_bco
+ = do BCO bco# <- linkBCO' ie ce ul_bco
+ -- SDM: Why do we need mkApUpd0 here? I *think* it's because
+ -- otherwise top-level interpreted CAFs don't get updated
+ -- after evaluation. A top-level BCO will evaluate itself and
+ -- return its value when entered, but it won't update itself.
+ -- Wrapping the BCO in an AP_UPD thunk will take care of the
+ -- update for us.
+ --
+ -- Update: the above is true, but now we also have extra invariants:
+ -- (a) An AP thunk *must* point directly to a BCO
+ -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
+ -- (c) An AP is always fully saturated, so we *can't* wrap
+ -- non-zero arity BCOs in an AP thunk.
+ --
+ if (unlinkedBCOArity ul_bco > 0)
+ then return (unsafeCoerce# bco#)
+ else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
+
+
+linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS)
+ -- Raises an IO exception on failure
+ = do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
itbls = ssElts itblsSS
- linked_ptrs <- mapM (lookupCE ce) ptrs
linked_itbls <- mapM (lookupIE ie) itbls
linked_literals <- mapM lookupLiteral literals
- let n_insns = sizeSS insnsSS
- n_literals = sizeSS literalsSS
+ let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS
n_itbls = sizeSS itblsSS
- let ptrs_arr = array (0, n_ptrs-1) (indexify linked_ptrs)
- :: Array Int HValue
+ ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+
+ let
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
- itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
+ itbls_arr = listArray (0, n_itbls-1) linked_itbls
:: UArray Int ItblPtr
itbls_barr = case itbls_arr of UArray lo hi barr -> barr
- insns_arr | n_insns > 65535
- = panic "linkBCO: >= 64k insns in BCO"
- | otherwise
- = array (0, n_insns)
- (indexify (fromIntegral n_insns:insns))
- :: UArray Int Word16
- insns_barr = case insns_arr of UArray lo hi barr -> barr
-
- literals_arr = array (0, n_literals-1) (indexify linked_literals)
+ literals_arr = listArray (0, n_literals-1) linked_literals
:: UArray Int Word
literals_barr = case literals_arr of UArray lo hi barr -> barr
- indexify :: [a] -> [(Int, a)]
- indexify xs = zip [0..] xs
-
- BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
-
- -- WAS: return (unsafeCoerce# bco#)
- case mkApUpd0# (unsafeCoerce# bco#) of
- (# final_bco #) -> return final_bco
-
+ newBCO insns_barr literals_barr ptrs_parr itbls_barr
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
+mkPtrsArray ie ce n_ptrs ptrs = do
+ marr <- newArray_ (0, n_ptrs-1)
+ let
+ fill (BCOPtrName n) i = do
+ ptr <- lookupName ce n
+ unsafeWrite marr i ptr
+ fill (BCOPtrPrimOp op) i = do
+ ptr <- lookupPrimOp op
+ unsafeWrite marr i ptr
+ fill (BCOPtrBCO ul_bco) i = do
+ BCO bco# <- linkBCO' ie ce ul_bco
+ writeArrayBCO marr i bco#
+ zipWithM fill ptrs [0..]
+ unsafeFreeze marr
+
+newtype IOArray i e = IOArray (STArray RealWorld i e)
+
+instance HasBounds IOArray where
+ bounds (IOArray marr) = bounds marr
+
+instance MArray IOArray e IO where
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOArray marr)
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOArray marr)
+ unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
+ unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
+writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
+writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
+ case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+ (# s#, () #) }
data BCO = BCO BCO#
Nothing -> linkFail "ByteCodeLink: can't find label"
label_to_find
-lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
-lookupCE ce (Right primop)
+lookupPrimOp :: PrimOp -> IO HValue
+lookupPrimOp primop
= do let sym_to_find = primopToCLabel primop "closure"
m <- lookupSymbol sym_to_find
case m of
(# hval #) -> return hval
Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
-lookupCE ce (Left nm)
+lookupName :: ClosureEnv -> Name -> IO HValue
+lookupName ce nm
= case lookupNameEnv ce nm of
Just (_,aa) -> return aa
Nothing
import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initLinker )
import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO )
import ByteCodeItbls ( ItblEnv )
-import ByteCodeAsm ( CompiledByteCode(..), bcosFreeNames,
- UnlinkedBCO, UnlinkedBCOExpr, nameOfUnlinkedBCO )
+import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
-import Packages ( PackageConfig(..), PackageName, PackageConfigMap, lookupPkg,
- packageDependents, packageNameString )
-import DriverState ( v_Library_paths, v_Cmdline_libraries, getPackageConfigMap )
+import Packages
+import DriverState ( v_Library_paths, v_Cmdline_libraries,
+ getPackageConfigMap )
import Finder ( findModule, findLinkable )
-import HscTypes ( Linkable(..), isObjectLinkable, nameOfObject, byteCodeOfObject,
- Unlinked(..), isInterpretable, isObject, Dependencies(..),
- HscEnv(..), PersistentCompilerState(..), ExternalPackageState(..),
- HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..),
- lookupIface )
+import HscTypes
import Name ( Name, nameModule, isExternalName )
import NameEnv
import NameSet ( nameSetToList )
-import Module ( ModLocation(..), Module, ModuleName, isHomeModule, moduleName, lookupModuleEnvByName )
+import Module
import FastString ( FastString(..), unpackFS )
import ListSetOps ( minusList )
import CmdLineOpts ( DynFlags(verbosity) )
import Outputable
import Panic ( GhcException(..) )
import Util ( zipLazy, global )
-import ErrUtils ( Message )
-- Standard libraries
import Control.Monad ( when, filterM, foldM )
import Data.List ( partition, nub )
import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
-import System.Directory ( doesFileExist, getModificationTime )
+import System.Directory ( doesFileExist )
import Control.Exception ( block, throwDyn )
\begin{code}
linkExpr :: HscEnv -> PersistentCompilerState
- -> UnlinkedBCOExpr -> IO HValue -- IO BCO# really
+ -> UnlinkedBCO -> IO HValue
-- Link a single expression, *including* first linking packages and
-- modules that this expression depends on.
-- Raises an IO exception if it can't find a compiled version of the
-- dependents to link.
-linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos)
+linkExpr hsc_env pcs root_ul_bco
= do {
-- Find what packages and linkables are required
(lnks, pkgs) <- getLinkDeps hpt pit needed_mods ;
ce = closure_env pls
-- Link the necessary packages and linkables
- ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce all_bcos
+ ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
; return root_hval
}}
where
pit = eps_PIT (pcs_EPS pcs)
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
- all_bcos = root_ul_bco : aux_ul_bcos
- free_names = nameSetToList (bcosFreeNames all_bcos)
-
+ free_names = nameSetToList (bcoFreeNames root_ul_bco)
+
needed_mods :: [Module]
needed_mods = [ nameModule n | n <- free_names, isExternalName n ]
linkSomeBCOs toplevs_only ie ce_in ul_bcos
- = do let nms = map nameOfUnlinkedBCO ul_bcos
+ = do let nms = map unlinkedBCOName ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
in mapM (linkBCO ie ce_out) ul_bcos )
rESERVED_STACK_WORDS,
sTD_ITBL_SIZE,
+ rET_ITBL_SIZE,
pROF_ITBL_SIZE,
gRAN_ITBL_SIZE,
tICKY_ITBL_SIZE,
pROF_UF_SIZE,
gRAN_UF_SIZE, -- HWL
uF_RET,
- uF_SU,
uF_UPDATEE,
- sEQ_FRAME_SIZE,
- pROF_SEQ_FRAME_SIZE,
- gRAN_SEQ_FRAME_SIZE, -- HWL
-
mAX_Vanilla_REG,
mAX_Float_REG,
mAX_Double_REG,
wORD_SIZE,
bLOCK_SIZE,
- bLOCK_SIZE_W
+ bLOCK_SIZE_W,
+ bITMAP_BITS_SHIFT,
) where
-- This magical #include brings in all the everybody-knows-these magic
-- Offsets in an update frame. They don't change with profiling!
uF_RET = (UF_RET::Int)
-uF_SU = (UF_SU::Int)
uF_UPDATEE = (UF_UPDATEE::Int)
\end{code}
-Seq frame sizes.
-
-\begin{code}
-sEQ_FRAME_SIZE = (STD_SEQ_FRAME_SIZE::Int)
-pROF_SEQ_FRAME_SIZE = (PROF_SEQ_FRAME_SIZE::Int)
-gRAN_SEQ_FRAME_SIZE = (GRAN_SEQ_FRAME_SIZE::Int)
-\end{code}
-
\begin{code}
mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int)
mAX_Float_REG = (MAX_FLOAT_REG :: Int)
\begin{code}
sTD_ITBL_SIZE = (STD_ITBL_SIZE :: Int)
+rET_ITBL_SIZE = (RET_ITBL_SIZE :: Int)
pROF_ITBL_SIZE = (PROF_ITBL_SIZE :: Int)
gRAN_ITBL_SIZE = (GRAN_ITBL_SIZE :: Int)
tICKY_ITBL_SIZE = (TICKY_ITBL_SIZE :: Int)
bLOCK_SIZE = (BLOCK_SIZE :: Int)
bLOCK_SIZE_W = (bLOCK_SIZE `div` wORD_SIZE :: Int)
\end{code}
+
+Number of bits to shift a bitfield left by in an info table.
+
+\begin{code}
+bITMAP_BITS_SHIFT = (BITMAP_BITS_SHIFT :: Int)
+\end{code}
nonemptyAbsC, mkAbsCStmts
)
import PprAbsC ( dumpRealC )
-import SMRep ( fixedItblSize,
- rET_SMALL, rET_BIG,
- rET_VEC_SMALL, rET_VEC_BIG
- )
-import Constants ( mIN_UPD_SIZE, wORD_SIZE )
+import SMRep ( retItblSize )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
- closureLabelFromCI, fastLabelFromCI
- )
+import ClosureInfo
import Literal ( Literal(..), word2IntLit )
-import Maybes ( maybeToBool )
import StgSyn ( StgOp(..) )
import MachOp ( MachOp(..), resultRepOfMachOp )
import PrimRep ( isFloatingRep, is64BitRep,
PrimRep(..), getPrimRepSizeInBytes )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
- livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import Util ( naturalMergeSortLe )
import Panic ( panic )
import TyCon ( tyConDataCons )
+import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT )
import DataCon ( dataConWrapId )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
+import BitSet ( BitSet, intBS )
-- DEBUGGING ONLY
--import TRACE ( trace )
--import Outputable ( showSDoc )
--import MachOp ( pprMachOp )
+#include "nativeGen/NCG.h"
\end{code}
For each independent chunk of AbstractC code, we generate a list of
= gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure closure_info _ _)
+ gentopcode stmt@(CStaticClosure lbl closure_info _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (
if opt_Static
: StData PtrRep [StInt 0] -- DLLised world, need extra zero word
: StLabel lbl : code []
)
- where
- lbl = closureLabelFromCI closure_info
- gentopcode stmt@(CRetVector lbl _ _ _)
- = genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment
- : code [StLabel lbl, vtbl_post_label_word])
- where
- -- We put a dummy word after the vtbl label so as to ensure the label
- -- is in the same (Text) section as the vtbl it labels. This is critical
- -- for ensuring the GC works correctly, although GC crashes due to
- -- misclassification are much more likely to show up in the interactive
- -- system than in compile code. For details see comment near line 1164
- -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix
- -- for the mangled via-C route.
- vtbl_post_label_word = StData PtrRep [StInt 0]
+ gentopcode stmt@(CRetVector lbl amodes srt liveness)
+ = returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel lbl
+ : []
+ )
+ where
+ table = map amodeToStix (mkVecInfoTable amodes srt liveness)
gentopcode stmt@(CRetDirect uniq absC srt liveness)
= gencode absC `thenUs` \ code ->
- genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
- returnUs (StSegment TextSegment :
- itbl (StLabel lbl_info : StLabel lbl_ret : code []))
+ returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel info_lbl
+ : StLabel ret_lbl
+ : code [])
where
- lbl_info = mkReturnInfoLabel uniq
- lbl_ret = mkReturnPtLabel uniq
- closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
-
- | slow_is_empty
- = genCodeInfoTable stmt `thenUs` \ itbl ->
- returnUs (StSegment TextSegment : itbl [])
-
- | otherwise
- = genCodeInfoTable stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
- returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code [StFunEnd slow_lbl]))
- where
- slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
- slow_lbl = entryLabelFromCI cl_info
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
- -- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
- gencode fast `thenUs` \ fast_code ->
- returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
- fast_code [StFunEnd fast_lbl])))
+ info_lbl = mkReturnInfoLabel uniq
+ ret_lbl = mkReturnPtLabel uniq
+ table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
+
+ gentopcode stmt@(CClosureInfoAndCode cl_info entry)
+ = gencode entry `thenUs` \ slow_code ->
+ returnUs ( StSegment TextSegment
+ : StData PtrRep table
+ : StLabel info_lbl
+ : StFunBegin entry_lbl
+ : slow_code [StFunEnd entry_lbl])
where
- slow_lbl = entryLabelFromCI cl_info
- fast_lbl = fastLabelFromCI cl_info
+ entry_lbl = entryLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
+ table = map amodeToStix (mkInfoTable cl_info)
gentopcode stmt@(CSRT lbl closures)
= returnUs [ StSegment TextSegment
| otherwise
= StCLbl label
- gentopcode stmt@(CBitmap lbl mask)
- = returnUs $ case bitmapToIntegers mask of
- mask'@(_:_:_) ->
- [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (map StInt (toInteger (length mask') : mask'))
- ]
- _ -> []
+ gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
+ | isBigLiveness l
+ = returnUs
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask))
+ ]
+ | otherwise
+ = returnUs []
+ where
+ -- ToDo: translate out bitmaps earlier, like info tables
+ isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+ mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
\begin{code}
{-
- genCodeVecTbl
- :: AbstractC
- -> UniqSM StixTreeList
- -}
- genCodeVecTbl (CRetVector lbl amodes srt liveness)
- = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
- returnUs (\xs -> vectbl : itbl xs)
- where
- vectbl = StData PtrRep (reverse (map a2stix amodes))
- closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
-
-\end{code}
-
-\begin{code}
- {-
genCodeStaticClosure
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeStaticClosure (CStaticClosure cl_info cost_centre amodes)
+ genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
= returnUs (\xs -> table ++ xs)
where
table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
- (StInt (toInteger (-n-fixedItblSize-1))))
+ (StInt (toInteger (-n-retItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
- StInt (toInteger (fixedItblSize+1))]
+ StInt (toInteger (retItblSize+1))]
\end{code}
%---------------------------------------------------------------------------
+\begin{code}
+bitmapToIntegers :: [BitSet] -> [Integer]
+bitmapToIntegers = bundle . map (toInteger . intBS)
+ where
+#if BYTES_PER_WORD == 4
+ bundle = id
+#else
+ bundle [] = []
+ bundle is = case splitAt (BYTES_PER_WORD/4) is of
+ (these, those) ->
+ ( foldr1 (\x y -> x + 4294967296 * y)
+ [x `mod` 4294967296 | x <- these]
+ : bundle those
+ )
+#endif
+\end{code}
+
+%---------------------------------------------------------------------------
+
This answers the question: Can the code fall through to the next
line(s) of code? This errs towards saying True if it can't choose,
because it is used for eliminating needless jumps. In other words, if
This module (@AsmCodeGen@) is the top-level machine-independent
module. It uses @AbsCStixGen.genCodeAbstractC@ to produce @StixTree@s
-(defined in module @Stix@), using support code from @StixInfo@ (info
-tables), @StixPrim@ (primitive operations), @StixMacro@ (Abstract C
-macros), and @StixInteger@ (GMP arbitrary-precision operations).
+(defined in module @Stix@), using support code from @StixPrim@
+(primitive operations), @StixMacro@ (Abstract C macros), and
+@StixInteger@ (GMP arbitrary-precision operations).
Before entering machine-dependent land, we do some machine-independent
@genericOpt@imisations (defined below) on the @StixTree@s.
volatileSaves = volatileSavesOrRestores True
volatileRestores = volatileSavesOrRestores False
-save_cands = [BaseReg,Sp,Su,SpLim,Hp,HpLim]
+save_cands = [BaseReg,Sp,SpLim,Hp,HpLim]
restore_cands = save_cands
volatileSavesOrRestores do_saves vols
baseRegOffset (DoubleReg 1#) = OFFSET_D1
baseRegOffset (DoubleReg 2#) = OFFSET_D2
baseRegOffset Sp = OFFSET_Sp
-baseRegOffset Su = OFFSET_Su
baseRegOffset SpLim = OFFSET_SpLim
#ifdef OFFSET_L1
baseRegOffset (LongReg _ 1#) = OFFSET_L1
#ifdef CALLER_SAVES_Sp
callerSaves Sp = True
#endif
-#ifdef CALLER_SAVES_Su
-callerSaves Su = True
-#endif
#ifdef CALLER_SAVES_SpLim
callerSaves SpLim = True
#endif
#ifdef REG_Lng2
magicIdRegMaybe (LongReg _ ILIT(2)) = Just (RealReg REG_Lng2)
#endif
-#ifdef REG_Su
-magicIdRegMaybe Su = Just (RealReg REG_Su)
-#endif
#ifdef REG_SpLim
magicIdRegMaybe SpLim = Just (RealReg REG_SpLim)
#endif
liftStrings, repOfStixExpr,
DestInfo(..), hasDestInfo,
- stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
+ stgBaseReg, stgNode, stgSp, stgSpLim,
stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
stgCurrentTSO, stgCurrentNursery,
ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
int (iBox n), char ')']
ppMId Sp = text "Sp"
-ppMId Su = text "Su"
ppMId SpLim = text "SpLim"
ppMId Hp = text "Hp"
ppMId HpLim = text "HpLim"
Stix Trees for STG registers:
\begin{code}
-stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
- :: StixReg
+stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim :: StixReg
stgBaseReg = StixMagicId BaseReg
stgNode = StixMagicId node
stgTagReg = StixMagicId tagreg
stgSp = StixMagicId Sp
-stgSu = StixMagicId Su
stgSpLim = StixMagicId SpLim
stgHp = StixMagicId Hp
stgHpLim = StixMagicId HpLim
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module StixInfo (
-
- genCodeInfoTable, genBitmapInfoTable,
-
- bitmapToIntegers, bitmapIsSmall, livenessIsSmall
-
- ) where
-
-#include "HsVersions.h"
-#include "../includes/config.h"
-#include "NCG.h"
-
-import AbsCSyn ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT )
-import ClosureInfo ( closurePtrsSize,
- closureNonHdrSize, closureSMRep,
- infoTableLabelFromCI,
- closureSRT, closureSemiTag
- )
-import PrimRep ( PrimRep(..) )
-import SMRep ( getSMRepClosureTypeInt )
-import Stix -- all of it
-import UniqSupply ( returnUs, UniqSM )
-import BitSet ( BitSet, intBS )
-import Maybes ( maybeToBool )
-
-import DATA_BITS
-import DATA_WORD
-\end{code}
-
-Generating code for info tables (arrays of data).
-
-\begin{code}
-genCodeInfoTable
- :: AbstractC
- -> UniqSM StixStmtList
-
-genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
- = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
-
- where
- info_lbl = infoTableLabelFromCI cl_info
-
- table | needs_srt = srt_label : rest_of_table
- | otherwise = rest_of_table
-
- rest_of_table =
- [
- {- par, prof, debug -}
- StInt (toInteger layout_info)
- , StInt (toInteger type_info)
- ]
-
- -- sigh: building up the info table is endian-dependent.
- -- ToDo: do this using .byte and .word directives.
- type_info :: Word32
-#ifdef WORDS_BIGENDIAN
- type_info = (fromIntegral closure_type `shiftL` 16) .|.
- (fromIntegral srt_len)
-#else
- type_info = (fromIntegral closure_type) .|.
- (fromIntegral srt_len `shiftL` 16)
-#endif
- srt = closureSRT cl_info
- needs_srt = needsSRT srt
-
- (srt_label,srt_len)
- | is_constr
- = (StInt 0, tag)
- | otherwise
- = case srt of
- NoC_SRT -> (StInt 0, 0)
- C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
-
- maybe_tag = closureSemiTag cl_info
- is_constr = maybeToBool maybe_tag
- (Just tag) = maybe_tag
-
- layout_info :: Word32
-#ifdef WORDS_BIGENDIAN
- layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs
-#else
- layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16)
-#endif
-
- ptrs = closurePtrsSize cl_info
- nptrs = size - ptrs
-
- size = closureNonHdrSize cl_info
-
- closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
-
-
-
-genBitmapInfoTable
- :: Liveness
- -> C_SRT
- -> Int
- -> Bool -- must include SRT field (i.e. it's a vector)
- -> UniqSM StixStmtList
-
-genBitmapInfoTable liveness srt closure_type include_srt
- = returnUs (\xs -> StData PtrRep table : xs)
-
- where
- table = if srt_len == 0 && not include_srt then
- rest_of_table
- else
- srt_label : rest_of_table
-
- rest_of_table =
- [
- {- par, prof, debug -}
- layout_info
- , StInt (toInteger type_info)
- ]
-
- layout_info = case liveness of
- Liveness lbl mask ->
- case bitmapToIntegers mask of
- [ ] -> StInt 0
- [i] -> StInt i
- _ -> StCLbl lbl
-
- type_info :: Word32
-#ifdef WORDS_BIGENDIAN
- type_info = (fromIntegral closure_type `shiftL` 16) .|.
- (fromIntegral srt_len)
-#else
- type_info = (fromIntegral closure_type) .|.
- (fromIntegral srt_len `shiftL` 16)
-#endif
-
- (srt_label,srt_len) =
- case srt of
- NoC_SRT -> (StInt 0, 0)
- C_SRT lbl off len ->
- (StIndex DataPtrRep (StCLbl lbl)
- (StInt (toInteger off)), len)
-
-bitmapToIntegers :: [BitSet] -> [Integer]
-bitmapToIntegers = bundle . map (toInteger . intBS)
- where
-#if BYTES_PER_WORD == 4
- bundle = id
-#else
- bundle [] = []
- bundle is = case splitAt (BYTES_PER_WORD/4) is of
- (these, those) ->
- ( foldr1 (\x y -> x + 4294967296 * y)
- [x `mod` 4294967296 | x <- these]
- : bundle those
- )
-#endif
-
-bitmapIsSmall :: [BitSet] -> Bool
-bitmapIsSmall bitmap
- = case bitmapToIntegers bitmap of
- _:_:_ -> False
- _ -> True
-
-livenessIsSmall :: Liveness -> Bool
-livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
-\end{code}
import MachRegs
import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
-import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
+import Constants ( uF_RET, uF_UPDATEE, uF_SIZE )
import ForeignCall ( CCallConv(..) )
import MachOp ( MachOp(..) )
import PrimRep ( PrimRep(..) )
import Panic ( panic )
import UniqSupply ( returnUs, thenUs, UniqSM )
import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
- mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
- mkRtsGCEntryLabel )
+ mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
\end{code}
-----------------------------------------------------------------------------
-Argument satisfaction checks.
-
-\begin{code}
-macroCode ARGS_CHK_LOAD_NODE args
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- [words, lbl] = map amodeToStix args
- temp = StIndex PtrRep (StReg stgSp) words
- test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
- cjmp = StCondJump ulbl test
- assign = StAssignReg PtrRep stgNode lbl
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
-
-macroCode ARGS_CHK [words]
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep (StReg stgSp) (amodeToStix words)
- test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
- cjmp = StCondJump ulbl test
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-\end{code}
-
------------------------------------------------------------------------------
Updating a CAF
@UPD_CAF@ involves changing the info pointer of the closure, and
-----------------------------------------------------------------------------
Update frames
-Push a four word update frame on the stack and slide the Su registers
-to the current Sp location.
+Push an update frame on the stack.
\begin{code}
macroCode PUSH_UPD_FRAME args
-- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
- a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu)
a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
-
- updSu = StAssignReg
- PtrRep
- stgSu
- (StIndex PtrRep (StReg stgSp) (StInt (toInteger (-uF_SIZE))))
in
- returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
-
-
-macroCode PUSH_SEQ_FRAME args
- = let [arg_frame] = map amodeToStix args
- frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
- a1 = StAssignMem PtrRep (frame 0) seq_frame_info
- a2 = StAssignMem PtrRep (frame 1) (StReg stgSu)
- updSu = StAssignReg PtrRep stgSu arg_frame
- in
- returnUs (\xs -> a1 : a2 : updSu : xs)
-
-
-macroCode UPDATE_SU_FROM_UPD_FRAME args
- = let [arg_frame] = map amodeToStix args
- frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
- updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU))
- in
- returnUs (\xs -> updSu : xs)
+ returnUs (\xs -> a1 : a4 : xs)
\end{code}
-----------------------------------------------------------------------------
ind_static_info = StCLbl mkIndStaticInfoLabel
ind_info = StCLbl mkIndInfoLabel
upd_frame_info = StCLbl mkUpdInfoLabel
-seq_frame_info = StCLbl mkSeqInfoLabel
-- Some common call trees
-
-updatePAP :: StixStmt
-updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP
-
\end{code}
-----------------------------------------------------------------------------
returnUs (
case macro of
HP_CHK_NP ->
- let [words,ptrs] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_enter ptrs : join : xs))
-
- HP_CHK_SEQ_NP ->
- let [words,ptrs] = args_stix
+ let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_seq ptrs : join : xs))
+ assts (hp_alloc words : gc_enter : join : xs))
STK_CHK_NP ->
- let [words,ptrs] = args_stix
+ let [words] = args_stix
in (\xs -> cjmp_sp_pass words :
- assts (gc_enter ptrs : join : xs))
+ assts (gc_enter : join : xs))
HP_STK_CHK_NP ->
- let [sp_words,hp_words,ptrs] = args_stix
+ let [sp_words,hp_words] = args_stix
in (\xs -> cjmp_sp_fail sp_words :
assign_hp hp_words : cjmp_hp :
fail :
- assts (hp_alloc hp_words : gc_enter ptrs
+ assts (hp_alloc hp_words : gc_enter
: join : xs))
- HP_CHK ->
- let [words,ret,r,ptrs] = args_stix
+ HP_CHK_FUN ->
+ let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : assign_ret r ret
- : gc_chk ptrs : join : xs))
+ assts (hp_alloc words : gc_fun : join : xs))
- STK_CHK ->
- let [words,ret,r,ptrs] = args_stix
+ STK_CHK_FUN ->
+ let [words] = args_stix
in (\xs -> cjmp_sp_pass words :
- assts (assign_ret r ret : gc_chk ptrs : join : xs))
+ assts (gc_fun : join : xs))
- HP_STK_CHK ->
- let [sp_words,hp_words,ret,r,ptrs] = args_stix
+ HP_STK_CHK_FUN ->
+ let [sp_words,hp_words] = args_stix
in (\xs -> cjmp_sp_fail sp_words :
assign_hp hp_words : cjmp_hp :
fail :
- assts (hp_alloc hp_words : assign_ret r ret
- : gc_chk ptrs : join : xs))
+ assts (hp_alloc hp_words
+ : gc_fun : join : xs))
HP_CHK_NOREGS ->
let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
assts (hp_alloc words : gc_l1 : join : xs))
- HP_CHK_UT_ALT ->
- let [words,ptrs,nonptrs,r,ret] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : assign_ret r ret
- : gc_ut ptrs nonptrs
- : join : xs))
-
- HP_CHK_GEN ->
- let [words,liveness,reentry] = args_stix
+ HP_CHK_UNBX_TUPLE ->
+ let [words,liveness] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
assts (hp_alloc words : assign_liveness liveness :
- assign_reentry reentry :
- gc_gen : join : xs))
+ gc_ut : join : xs))
)
-- Various canned heap-check routines
-- | otherwise
-- do something plausible for cross-DLL jump
-gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0
-gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1
-gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n)
-
-gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
-gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n)
+gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
+gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun
-gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n)
gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1"
-gc_gen = mkStJump_to_GCentry_name "stg_gen_chk"
-gc_ut (StInt p) (StInt np)
- = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np)
+gc_ut = mkStJump_to_GCentry_name "stg_gc_ut"
\end{code}
(StMachOp MO_Nat_Add
[StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
(StReg stgSp)
- : StAssignMem PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
- (StReg stgSu)
: StAssignMem PtrRep
(StMachOp MO_Nat_Add
[StReg stgCurrentNursery,
(StMachOp MO_Nat_Add
[StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
: StAssignReg PtrRep
- stgSu
- (StInd PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
- : StAssignReg PtrRep
stgSpLim
(StMachOp MO_Nat_Add
[StReg tso,
in instead of the defaults.
*/
+#include <string.h>
+
#if __GLASGOW_HASKELL__ >= 400
-#include "Rts.h"
+#include "../rts/Rts.h"
#else
#include "rtsdefs.h"
#endif
-#if __GLASGOW_HASKELL__ >= 408
+#if __GLASGOW_HASKELL__ >= 505
+#include "../rts/Rts.h"
#include "../includes/RtsFlags.h"
+#else
+#include "Rts.h"
+#include "RtsFlags.h"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 502
+#include "RtsFlags.h"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 408
#include "HsFFI.h"
#endif
#include <unistd.h>
#endif
+#if __GLASGOW_HASKELL__ >= 504
+
+char *ghc_rts_opts = "-H8m -K8m";
+
+#else
+
void
defaultsHook (void)
{
RtsFlags.GcFlags.statsFile = stderr;
#endif
}
+#endif
void
enableTimingStats( void ) /* called from the driver */
{
-#if __GLASGOW_HASKELL__ >= 411
+#if __GLASGOW_HASKELL__ >= 505
RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS;
#endif
/* ignored when bootstrapping with an older GHC */
#endif
}
-#if __GLASGOW_HASKELL__ >= 400
void
OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
/* both in bytes */
fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
}
-#else /* GHC < 4.00 */
-
-void
-OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */
-{
- fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
- request_size,
- heap_size);
-}
-
-void
-StackOverflowHook (I_ stack_size) /* in bytes */
-{
- fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
-}
-
-#endif
-
HsInt
ghc_strlen( HsAddr a )
{
types.
\begin{code}
-module PrimRep
- ( PrimRep(..)
- , separateByPtrFollowness
- , isFollowableRep
- , isFloatingRep
- , is64BitRep
- , getPrimRepSize
- , getPrimRepSizeInBytes
- , retPrimRepSize
- ) where
+module PrimRep (
+ PrimRep(..),
+ separateByPtrFollowness,
+ isFollowableRep,
+ isFloatingRep,
+ isNonPtrRep,
+ is64BitRep,
+ getPrimRepSize,
+ getPrimRepSizeInBytes,
+ retPrimRepSize,
+
+ ArgRep(..), primRepToArgRep,
+ ) where
#include "HsVersions.h"
isFloatingRep _ = False
\end{code}
+Identify anything which is one word large and not a pointer.
+
+\begin{code}
+isNonPtrRep :: PrimRep -> Bool
+isNonPtrRep PtrRep = False
+isNonPtrRep VoidRep = False
+isNonPtrRep r = not (isFloatingRep r)
+\end{code}
+
\begin{code}
is64BitRep :: PrimRep -> Bool
is64BitRep Int64Rep = True
%************************************************************************
%* *
+\subsection{ArgReps}
+%* *
+%************************************************************************
+
+An ArgRep is similar to a PrimRep, except that it is slightly
+narrower. It corresponds to the distinctions we make between
+different type of function arguments for the purposes of a function's
+calling convention. These reps are used to decide which of the RTS's
+generic apply functions to call when applying an unknown function.
+
+All 64-bit PrimReps map to the same ArgRep, because they're passed in
+the same register, but a PtrRep is still different from an IntRep
+(RepP vs. RepN respectively) because the function's entry convention
+has to take into account the pointer-hood of arguments for the
+purposes of describing the stack on entry to the garbage collector.
+
+\begin{code}
+data ArgRep = RepV | RepP | RepN | RepF | RepD | RepL
+
+primRepToArgRep VoidRep = RepV
+primRepToArgRep FloatRep = RepF
+primRepToArgRep DoubleRep = RepD
+primRepToArgRep r
+ | isFollowableRep r = RepP
+ | is64BitRep r = RepL
+ | otherwise = ASSERT(getPrimRepSize r == 1) RepN
+\end{code}
+
+%************************************************************************
+%* *
\subsection[PrimRep-instances]{Boring instance decls for @PrimRep@}
%* *
%************************************************************************
showPrimRep StablePtrRep = "StgStablePtr"
showPrimRep VoidRep = "!!VOID_KIND!!"
\end{code}
+
+
-----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.22 2002/10/18 09:51:04 simonmar Exp $
+-- $Id: primops.txt.pp,v 1.23 2002/12/11 15:36:35 simonmar Exp $
--
-- Primitive Operations
--
{Convert an Addr\# to a followable type.}
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
- a -> (# a #)
+ BCO# -> (# a #)
with
out_of_line = True
(getFVs rhs_fvs)
upd_flag [] rhs
where
+ upd_flag = Updatable
+ {-
+ SDM: disabled. Eval/Apply can't handle functions with arity zero very
+ well; and making these into simple non-updatable thunks breaks other
+ assumptions (namely that they will be entered only once).
+
upd_flag | isPAP env rhs = ReEntrant
| otherwise = Updatable
+ -}
+
{- ToDo:
upd = if isOnceDem dem
then (if isNotTop toplev
idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool
idAppIsNonUpd p id n_val_args args
| Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
- | otherwise = n_val_args < stgArity id (lookupBinding p id)
+ | otherwise = False -- SDM: disbled. See comment with isPAP above.
+ -- n_val_args < stgArity id (lookupBinding p id)
stgArity :: Id -> HowBound -> Arity
stgArity f (LetBound _ arity) = arity
$T_HDR_srt = "\.text\n\t\.align 3\n";
$T_HDR_info = "\.text\n\t\.align 3\n";
$T_HDR_entry = "\.text\n\t\.align 3\n";
- $T_HDR_fast = "\.text\n\t\.align 3\n";
$T_HDR_vector = "\.text\n\t\.align 3\n";
$T_HDR_direct = "\.text\n\t\.align 3\n";
$T_create_word = "\t.quad";
$T_HDR_srt = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
$T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
- $T_HDR_fast = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_direct = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_create_word = "\t.word";
$T_HDR_data = "\.data\n\t\.align 2\n";
$T_HDR_consist = "\.text\n";
$T_HDR_closure = "\.data\n\t\.align 2\n";
- $T_HDR_closure = "\.data\n\t\.align 2\n\t.long 0\n" if ( $TargetPlatform =~ /.*-mingw32$/ );
$T_HDR_srt = "\.text\n\t\.align 2\n";
$T_HDR_info = "\.text\n\t\.align 2\n"; # NB: requires padding
$T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
- $T_HDR_fast = "\.text\n\t\.align 2,0x90\n";
$T_HDR_vector = "\.text\n\t\.align 2\n"; # NB: requires padding
$T_HDR_direct = "\.text\n\t\.align 2,0x90\n";
$T_create_word = "\t.word";
$T_HDR_srt = "\.text\n\t\.align 4\n"; # ToDo: change align?
$T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding
$T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
- $T_HDR_fast = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding
$T_HDR_direct = "\.text\n\t\.align 4\n";
$T_create_word = "\t.word";
$T_HDR_srt = "\.text\n\t\.align 8\n";
$T_HDR_info = "\.text\n\t\.align 8\n";
$T_HDR_entry = "\.text\n\t\.align 16\n";
- $T_HDR_fast = "\.text\n\t\.align 16\n";
$T_HDR_vector = "\.text\n\t\.align 8\n";
$T_HDR_direct = "\.text\n\t\.align 8\n";
$T_create_word = "\t.word";
$T_HDR_srt = "\.text\n\t\.even\n";
$T_HDR_info = "\.text\n\t\.even\n";
$T_HDR_entry = "\.text\n\t\.even\n";
- $T_HDR_fast = "\.text\n\t\.even\n";
$T_HDR_vector = "\.text\n\t\.even\n";
$T_HDR_direct = "\.text\n\t\.even\n";
$T_create_word = "\t.long";
$T_HDR_srt = "\t\.text\n\t\.align 2\n";
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_fast = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
$T_HDR_direct = "\t\.text\n\t\.align 2\n";
$T_create_word = "\t.word";
$T_HDR_srt = "\t\.text\n\t\.align 2\n";
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_fast = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
$T_HDR_direct = "\t\.text\n\t\.align 2\n";
$T_create_word = "\t.long";
$T_HDR_srt = "\.data\n\t\.align 4\n";
$T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n\t\.align 4\n";
- $T_HDR_fast = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n";
$T_HDR_direct = "\.text\n\t\.align 4\n";
$T_create_word = "\t.word";
$T_HDR_srt = "\.data\n\t\.align 4\n";
$T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n\t\.align 4\n";
- $T_HDR_fast = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n";
$T_HDR_direct = "\.text\n\t\.align 4\n";
$T_create_word = "\t.word";
print STDERR "T_HDR_closure: $T_HDR_closure\n";
print STDERR "T_HDR_info: $T_HDR_info\n";
print STDERR "T_HDR_entry: $T_HDR_entry\n";
-print STDERR "T_HDR_fast: $T_HDR_fast\n";
print STDERR "T_HDR_vector: $T_HDR_vector\n";
print STDERR "T_HDR_direct: $T_HDR_direct\n";
}
$numchks = 0; # number of them
@chkcat = (); # what category of thing in each chunk
@chksymb = (); # what symbol(base) is defined in this chunk
- %slowchk = (); # ditto, its regular "slow" entry code
- %fastchk = (); # ditto, fast entry code
+ %entrychk = (); # ditto, its entry code
%closurechk = (); # ditto, the (static) closure
%srtchk = (); # ditto, its SRT (for top-level things)
%infochk = (); # given a symbol base, say what chunk its info tbl is in
} elsif ( /^${T_US}([A-Za-z0-9_]+)_(entry|ret)${T_POST_LBL}$/o ) {
$chk[++$i] = $_;
- $chkcat[$i] = 'slow';
+ $chkcat[$i] = 'entry';
$chksymb[$i] = $1;
- $slowchk{$1} = $i;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d*${T_POST_LBL}$/o ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'fast';
- $chksymb[$i] = $1;
-
- $fastchk{$1} = $i;
+ $entrychk{$1} = $i;
} elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) {
$chk[++$i] = $_;
$chkcat[$i] = 'data';
$chksymb[$i] = '';
- } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'consist';
-
} elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
; # toss it
/^${T_US}stg_.*${T_POST_LBL}$/o # RTS internals
|| /^${T_US}__stg_.*${T_POST_LBL}$/o # more RTS internals
|| /^${T_US}__fexp_.*${T_POST_LBL}$/o # foreign export
+ || /^${T_US}.*_slow${T_POST_LBL}$/o # slow entry
|| /^${T_US}__stginit.*${T_POST_LBL}$/o # __stginit<module>
|| /^${T_US}.*_btm${T_POST_LBL}$/o # large bitmaps
+ || /^${T_US}.*_fast${T_POST_LBL}$/o # primops
|| /^${T_US}.*_closure_tbl${T_POST_LBL}$/o # closure tables
|| /^_uname:/o; # x86/Solaris2
$chk[++$i] = $_;
} elsif ( $chkcat[$i] eq 'closure'
|| $chkcat[$i] eq 'srt'
|| $chkcat[$i] eq 'infotbl'
- || $chkcat[$i] eq 'slow'
- || $chkcat[$i] eq 'fast' ) { # do them in that order
+ || $chkcat[$i] eq 'entry') { # do them in that order
$symb = $chksymb[$i];
# CLOSURE
}
# STD ENTRY POINT
- if ( defined($slowchk{$symb}) ) {
-
- # teach it to drop through to the fast entry point:
- $c = $chk[$slowchk{$symb}];
-
- if ( defined($fastchk{$symb}) ) {
- if ( $TargetPlatform =~ /^alpha-/ ) {
- $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
- } elsif ( $TargetPlatform =~ /^hppa/ ) {
- $c =~ s/^\s+ldil.*\n\s+ldo.*\n\s+bv.*\n(.*\n)?\s+\.EXIT/$1\t.EXIT/;
- } elsif ( $TargetPlatform =~ /^i386-/ ) {
- # Reg alloc depending, gcc generated code may jump to the fast entry point via
- # a number of registers.
- $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%edx\n\tjmp\s+\*\%edx\n//;
- $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%ecx\n\tjmp\s+\*\%ecx\n//;
- $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%eax\n\tjmp\s+\*\%eax\n//;
- # The next two only apply if we're not stealing %esi or %edi.
- $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%esi\n\tjmp\s+\*\%esi\n// if ($StolenX86Regs < 3);
- $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%edi\n\tjmp\s+\*\%edi\n// if ($StolenX86Regs < 4);
- } elsif ( $TargetPlatform =~ /^ia64-/ ) {
- #$c =~ s/^\tbr\.few ${symb}_fast\d*#\n\t;;\n(\t;;\n\t\.endp ${symb}_entry#\n)/$1/;
- $c =~ s/^\tbr\.few ${symb}_fast\d*#\n(\t;;\n\t\.endp ${symb}_entry#\n)/$1/;
- } elsif ( $TargetPlatform =~ /^mips-/ ) {
- $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
- } elsif ( $TargetPlatform =~ /^m68k-/ ) {
- $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n\tnop\n//;
- $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n//;
- } elsif ( $TargetPlatform =~ /^powerpc-apple-.*/ ) {
- if ( $c =~ s/^\taddis r9,r31,ha16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\n\tlwz r9,lo16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\(r9\)\n\tmtctr r9\n\tbctr$// ) {
- # for Position-Independent Code, GCC 2:
- # addis r9,r31,ha16(L_XXXX_fast3$non_lazy_ptr-Lxxx$pb)
- # lwz r9,lo16(L_XXXX_fast3$non_lazy_ptr-Lxxx$pb)(r9)
- # mtctr r9
- # bctr
-
- } elsif ( $c =~ s/^\taddis r9,r31,ha16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\n\tlwz r29,lo16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\(r9\)\nL(\d+):\n\tmtctr r29\n\tbctr$// ) {
- # for Position-Independent Code, GCC 3:
- # addis r9,r31,ha16(L_XXXX_fast3$non_lazy_ptr-Lxxx$pb)
- # lwz r29,lo16(L_XXXX_fast3$non_lazy_ptr-Lxxx$pb)(r9)
- # Lyyy:
- # mtctr r29
- # bctr
- $label = $1;
- $c =~ s/^\tb L${label}\n/\tmtctr r29\n\tbctr\n/g;
- } elsif ( $c =~ s/^\tlis r9,ha16\(L_${symb}_fast\d*\$non_lazy_ptr\)\n\tlwz r31,lo16\(L_${symb}_fast\d*\$non_lazy_ptr\)\(r9\)\nL(\d+):\n\tmtctr r31\n\tbctr$// ) {
- # for -mdynamic-no-pic Code, GCC 3:
- # lis r9,ha16(L_XXXX_fast3$non_lazy_ptr)
- # lwz r31,lo16(L_XXXX_fast3$non_lazy_ptr-Lxxx$pb)(r9)
- # Lyyy:
- # mtctr r31
- # bctr
- $label = $1;
- $c =~ s/^\tb L${label}\n/\tmtctr r31\n\tbctr\n/g;
- } else {
-
- print STDERR "slow-fast dropthrough not mangled\n";
- print STDERR $c;
- print STDERR "\n\n";
- }
- } elsif ( $TargetPlatform =~ /^sparc-/ ) {
- $c =~ s/^\tcall\s+${T_US}${symb}_fast\d+,.*\n\t\s*nop\n//;
- $c =~ s/^\tcall\s+${T_US}${symb}_fast\d+,.*\n(\t\s*[a-z].*\n)/$1/;
- } else {
- print STDERR "$Pgm: mystery slow-fast dropthrough: $TargetPlatform\n";
- }
- }
+ if ( defined($entrychk{$symb}) ) {
- if ( $TargetPlatform !~ /^(alpha-|hppa|mips-|powerpc-apple-)/) {
- # On alphas, hppa: no very good way to look for "dangling"
- # references to fast-entry point.
- # (questionable re hppa and mips...)
- print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /\b${T_US}${symb}_fast/;
- }
+ $c = $chk[$entrychk{$symb}];
print OUTASM $T_HDR_entry;
&print_doctored($c, 1); # NB: the 1!!!
- $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
+ $chkcat[$entrychk{$symb}] = 'DONE ALREADY';
}
- # FAST ENTRY POINT
- if ( defined($fastchk{$symb}) ) {
- $c = $chk[$fastchk{$symb}];
- if ( ! defined($slowchk{$symb})
- # ToDo: the || clause can go once we're no longer
- # concerned about producing exactly the same output as before
-#OLD: || $TargetPlatform =~ /^(m68k|sparc|i386)-/
- ) {
- print OUTASM $T_HDR_fast;
- }
-
- &print_doctored($c, 0);
- $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
- }
-
} elsif ( $chkcat[$i] eq 'vector'
|| $chkcat[$i] eq 'direct' ) { # do them in that order
$symb = $chksymb[$i];
# VECTOR TABLE
if ( defined($vectorchk{$symb}) ) {
print OUTASM $T_HDR_vector;
-
print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
- # DO NOT DELETE THE NEXT LINE. It fixes a rather subtle GC bug
- # which showed up as a segfault reported by Ryszard Kubiak.
- # Problem is with vector tables. They wind up as follows:
- # .word some-word
- # .word some-other-word
- # fooble_vtbl:
- # Problem is that we want the label fooble_vtbl to be considered
- # in the same section as the vtbl itself, but the label actually
- # lives at the next word along. If a data segment should happen
- # to immediately follow the vtbl, as it can in GHCi, the label will
- # be malclassified as in the data rather than text segment (during
- # GC), and so we will regard references to it as static closure
- # pointers rather than as code pointers, which is an error which
- # usually crashes the garbage collectors.
- # To fix this, we place a dummy word after the label, so as to
- # ensure that the label is in the same segment as the vtbl proper.
- # The native code generator has an analogous fix; see
- # ghc/compiler/nativeGen/AbsCStixGen.lhs line 107.
- print OUTASM "${T_create_word} 0\n";
# direct return code will be put here!
$chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
# Offsets into register table - you'd better update these magic
# numbers should you change its contents!
# local($OFFSET_R1)=0; No offset for R1 in new RTS.
- local($OFFSET_Hp)=92;
+ local($OFFSET_Hp)=88;
# Note funky ".=" stuff; we're *adding* to these _patch guys
if ( $StolenX86Regs <= 2
}
}
- # now throw away the first word (SRT) iff it is empty.
+ # Now throw away any initial zero word from the table. This is a hack
+ # that lets us reduce the size of info tables when the SRT field is not
+ # needed: see comments StgFunInfoTable in InfoTables.h.
+ #
# The .zero business is for Linux/ELF.
# The .skip business is for Sparc/Solaris/ELF.
# The .blockz business is for HPPA.
- if ($discard1 && $words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) {
- shift(@words)
- }
+# if ($discard1) {
+# if ($words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) {
+# shift(@words);
+# }
+# }
for (; $i <= $#lines; $i++) {
$after .= $lines[$i] . "\n";
/* -----------------------------------------------------------------------------
- * $Id: Block.h,v 1.10 2001/10/03 13:57:42 simonmar Exp $
+ * $Id: Block.h,v 1.11 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
* includes/Constants.h, all constants here are derived from these.
*/
-/* Block related constants (4k blocks) */
+/* Block related constants (BLOCK_SHIFT is defined in Constants.h) */
#define BLOCK_SIZE (1<<BLOCK_SHIFT)
#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))
#define BLOCK_ROUND_UP(p) ((void *) (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK))
#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))
-/* Megablock related constants (1M megablocks) */
+/* Megablock related constants (MBLOCK_SHIFT is defined in Constants.h) */
#define MBLOCK_SIZE (1<<MBLOCK_SHIFT)
#define MBLOCK_SIZE_W (MBLOCK_SIZE/sizeof(W_))
-
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.8 2001/08/09 11:19:16 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.9 2002/12/11 15:36:37 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2002
*
* Bytecode definitions.
*
I hope that's clear :-)
*/
-#define bci_ARGCHECK 1
-#define bci_PUSH_L 2
-#define bci_PUSH_LL 3
-#define bci_PUSH_LLL 4
-#define bci_PUSH_G 5
-#define bci_PUSH_AS 6
-#define bci_PUSH_UBX 7
-#define bci_PUSH_TAG 8
-#define bci_SLIDE 9
-#define bci_ALLOC 10
-#define bci_MKAP 11
-#define bci_UNPACK 12
-#define bci_UPK_TAG 13
-#define bci_PACK 14
-#define bci_TESTLT_I 15
-#define bci_TESTEQ_I 16
-#define bci_TESTLT_F 17
-#define bci_TESTEQ_F 18
-#define bci_TESTLT_D 19
-#define bci_TESTEQ_D 20
-#define bci_TESTLT_P 21
-#define bci_TESTEQ_P 22
-#define bci_CASEFAIL 23
-#define bci_ENTER 24
-#define bci_RETURN 25
-#define bci_STKCHECK 26
-#define bci_JMP 27
-#define bci_CCALL 28
-#define bci_SWIZZLE 29
+#define bci_STKCHECK 1
+#define bci_PUSH_L 2
+#define bci_PUSH_LL 3
+#define bci_PUSH_LLL 4
+#define bci_PUSH_G 5
+#define bci_PUSH_ALTS 6
+#define bci_PUSH_ALTS_P 7
+#define bci_PUSH_ALTS_N 8
+#define bci_PUSH_ALTS_F 9
+#define bci_PUSH_ALTS_D 10
+#define bci_PUSH_ALTS_L 11
+#define bci_PUSH_ALTS_V 12
+#define bci_PUSH_UBX 13
+#define bci_PUSH_APPLY_N 14
+#define bci_PUSH_APPLY_F 15
+#define bci_PUSH_APPLY_D 16
+#define bci_PUSH_APPLY_L 17
+#define bci_PUSH_APPLY_V 18
+#define bci_PUSH_APPLY_P 19
+#define bci_PUSH_APPLY_PP 20
+#define bci_PUSH_APPLY_PPP 21
+#define bci_PUSH_APPLY_PPPP 22
+#define bci_PUSH_APPLY_PPPPP 23
+#define bci_PUSH_APPLY_PPPPPP 24
+#define bci_PUSH_APPLY_PPPPPPP 25
+#define bci_SLIDE 26
+#define bci_ALLOC_AP 27
+#define bci_ALLOC_PAP 28
+#define bci_MKAP 29
+#define bci_UNPACK 30
+#define bci_PACK 31
+#define bci_TESTLT_I 32
+#define bci_TESTEQ_I 33
+#define bci_TESTLT_F 34
+#define bci_TESTEQ_F 35
+#define bci_TESTLT_D 36
+#define bci_TESTEQ_D 37
+#define bci_TESTLT_P 38
+#define bci_TESTEQ_P 39
+#define bci_CASEFAIL 40
+#define bci_JMP 41
+#define bci_CCALL 42
+#define bci_SWIZZLE 43
+#define bci_ENTER 44
+#define bci_RETURN 45
+#define bci_RETURN_P 46
+#define bci_RETURN_N 47
+#define bci_RETURN_F 48
+#define bci_RETURN_D 49
+#define bci_RETURN_L 50
+#define bci_RETURN_V 51
/* If a BCO definitely requires less than this many words of stack,
don't include an explicit STKCHECK insn in it. The interpreter
/* ----------------------------------------------------------------------------
- * $Id: ClosureMacros.h,v 1.34 2002/09/25 20:44:23 wolfgang Exp $
+ * $Id: ClosureMacros.h,v 1.35 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
-------------------------------------------------------------------------- */
-#define INIT_INFO(i) info : &(i)
+#define INIT_INFO(i) info : (StgInfoTable *)&(i)
#define SET_INFO(c,i) ((c)->header.info = (i))
#define GET_INFO(c) ((c)->header.info)
#define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c)))
+
#define get_itbl(c) (INFO_PTR_TO_STRUCT((c)->header.info))
+#define get_ret_itbl(c) (RET_INFO_PTR_TO_STRUCT((c)->header.info))
+#define get_fun_itbl(c) (FUN_INFO_PTR_TO_STRUCT((c)->header.info))
+#define get_thunk_itbl(c) (THUNK_INFO_PTR_TO_STRUCT((c)->header.info))
+
#ifdef TABLES_NEXT_TO_CODE
#define INIT_ENTRY(e)
#define ENTRY_CODE(info) (info)
#define INFO_PTR_TO_STRUCT(info) ((StgInfoTable *)(info) - 1)
+#define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)(info) - 1)
+#define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)(info) - 1)
+#define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)(info) - 1)
static __inline__ StgFunPtr get_entry(const StgInfoTable *itbl) {
return (StgFunPtr)(itbl+1);
}
+#define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
+#define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
+#define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
#else
#define INIT_ENTRY(e) entry : (F_)(e)
#define ENTRY_CODE(info) (((StgInfoTable *)info)->entry)
#define INFO_PTR_TO_STRUCT(info) ((StgInfoTable *)info)
+#define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)info)
+#define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)info)
+#define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)info)
static __inline__ StgFunPtr get_entry(const StgInfoTable *itbl) {
return itbl->entry;
}
+#define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(i))
+#define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(i))
+#define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(i))
#endif
/* -----------------------------------------------------------------------------
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.17 2002/03/26 11:09:34 simonmar Exp $
+ * $Id: ClosureTypes.h,v 1.18 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define THUNK_STATIC 24
#define THUNK_SELECTOR 25
#define BCO 26
-#define AP_UPD 27
+#define AP 27
#define PAP 28
-#define IND 29
-#define IND_OLDGEN 30
-#define IND_PERM 31
-#define IND_OLDGEN_PERM 32
-#define IND_STATIC 33
-#define RET_BCO 34
-#define RET_SMALL 35
-#define RET_VEC_SMALL 36
-#define RET_BIG 37
-#define RET_VEC_BIG 38
-#define RET_DYN 39
-#define UPDATE_FRAME 40
-#define CATCH_FRAME 41
-#define STOP_FRAME 42
-#define SEQ_FRAME 43
-#define CAF_BLACKHOLE 44
-#define BLACKHOLE 45
-#define BLACKHOLE_BQ 46
-#define SE_BLACKHOLE 47
-#define SE_CAF_BLACKHOLE 48
-#define MVAR 49
-#define ARR_WORDS 50
-#define MUT_ARR_PTRS 51
-#define MUT_ARR_PTRS_FROZEN 52
-#define MUT_VAR 53
-#define MUT_CONS 54
-#define WEAK 55
-#define FOREIGN 56
-#define STABLE_NAME 57
-#define TSO 58
-#define BLOCKED_FETCH 59
-#define FETCH_ME 60
-#define FETCH_ME_BQ 61
-#define RBH 62
-#define EVACUATED 63
-#define REMOTE_REF 64
-#define N_CLOSURE_TYPES 65
-
+#define AP_STACK 29
+#define IND 30
+#define IND_OLDGEN 31
+#define IND_PERM 32
+#define IND_OLDGEN_PERM 33
+#define IND_STATIC 34
+#define RET_BCO 35
+#define RET_SMALL 36
+#define RET_VEC_SMALL 37
+#define RET_BIG 38
+#define RET_VEC_BIG 39
+#define RET_DYN 40
+#define RET_FUN 41
+#define UPDATE_FRAME 42
+#define CATCH_FRAME 43
+#define STOP_FRAME 44
+#define CAF_BLACKHOLE 45
+#define BLACKHOLE 46
+#define BLACKHOLE_BQ 47
+#define SE_BLACKHOLE 48
+#define SE_CAF_BLACKHOLE 49
+#define MVAR 50
+#define ARR_WORDS 51
+#define MUT_ARR_PTRS 52
+#define MUT_ARR_PTRS_FROZEN 53
+#define MUT_VAR 54
+#define MUT_CONS 55
+#define WEAK 56
+#define FOREIGN 57
+#define STABLE_NAME 58
+#define TSO 59
+#define BLOCKED_FETCH 60
+#define FETCH_ME 61
+#define FETCH_ME_BQ 62
+#define RBH 63
+#define EVACUATED 64
+#define REMOTE_REF 65
+#define N_CLOSURE_TYPES 66
+
#endif /* CLOSURETYPES_H */
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.31 2002/01/29 16:52:46 simonmar Exp $
+ * $Id: Closures.h,v 1.32 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
typedef struct {
StgHeader header;
- StgWord n_args;
- StgClosure *fun;
+ StgHalfWord arity; /* zero if it is an AP */
+ StgHalfWord n_args;
+ StgClosure *fun; /* really points to a fun */
StgClosure *payload[FLEXIBLE_ARRAY];
} StgPAP;
+// AP closures have the same layout, for convenience
+typedef StgPAP StgAP;
+
typedef struct {
StgHeader header;
- StgWord n_args;
+ StgWord size; // number of words in payload
StgClosure *fun;
- StgClosure *payload[FLEXIBLE_ARRAY];
-} StgAP_UPD;
+ StgClosure *payload[FLEXIBLE_ARRAY]; // contains a chunk of *stack*
+} StgAP_STACK;
typedef struct {
StgHeader header;
StgMutClosure *mut_link;
} StgMutVar;
-typedef struct {
- StgHeader header;
- StgArrWords *instrs; /* a pointer to an ArrWords */
- StgArrWords *literals; /* a pointer to an ArrWords */
- StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */
- StgArrWords *itbls; /* a pointer to an ArrWords */
-} StgBCO;
-
-/*
- A collective typedef for all linkable stack frames i.e.
- StgUpdateFrame, StgSeqFrame, StgCatchFrame
-*/
-typedef struct _StgFrame {
- StgHeader header;
- struct _StgFrame *link;
-} StgFrame;
-
typedef struct _StgUpdateFrame {
StgHeader header;
- struct _StgUpdateFrame *link;
StgClosure *updatee;
} StgUpdateFrame;
typedef struct {
StgHeader header;
- struct _StgUpdateFrame *link;
-} StgSeqFrame;
-
-typedef struct {
- StgHeader header;
- struct _StgUpdateFrame *link;
StgInt exceptions_blocked;
StgClosure *handler;
} StgCatchFrame;
struct _StgWeak *link;
} StgDeadWeak;
+/* Byte code objects. These are fixed size objects with pointers to
+ * four arrays, designed so that a BCO can be easily "re-linked" to
+ * other BCOs, to facilitate GHC's intelligent recompilation. The
+ * array of instructions is static and not re-generated when the BCO
+ * is re-linked, but the other 3 arrays will be regenerated.
+ *
+ * A BCO represents either a function or a stack frame. In each case,
+ * it needs a bitmap to describe to the garbage collector the
+ * pointerhood of its arguments/free variables respectively, and in
+ * the case of a function it also needs an arity. These pieces of
+ * information are stored at the beginning of the instruction array.
+ */
+
+typedef struct {
+ StgHeader header;
+ StgArrWords *instrs; /* a pointer to an ArrWords */
+ StgArrWords *literals; /* a pointer to an ArrWords */
+ StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */
+ StgArrWords *itbls; /* a pointer to an ArrWords */
+} StgBCO;
+
+typedef struct {
+ StgWord arity;
+ StgWord bitmap[FLEXIBLE_ARRAY]; // really an StgLargeBitmap
+} StgBCOInfo;
+
+#define BCO_INFO(bco) ((StgBCOInfo *)(((StgBCO *)(bco))->instrs->payload))
+#define BCO_ARITY(bco) (BCO_INFO(bco)->arity)
+#define BCO_BITMAP(bco) ((StgLargeBitmap *)BCO_INFO(bco)->bitmap)
+#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)
+#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)
+#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
+ / BITS_IN(StgWord))
+#define BCO_INSTRS(bco) ((StgWord16 *)(BCO_BITMAP_BITS(bco) + \
+ BCO_BITMAP_SIZEW(bco)))
+
/* Dynamic stack frames - these have a liveness mask in the object
* itself, rather than in the info table. Useful for generic heap
- * check code.
+ * check code. See StgMacros.h, HEAP_CHK_GEN().
*/
typedef struct {
- const struct _StgInfoTable* info;
- StgWord liveness;
- StgWord ret_addr;
- StgWord payload[FLEXIBLE_ARRAY];
+ const struct _StgInfoTable* info;
+ StgWord liveness;
+ StgWord ret_addr;
+ StgClosure * payload[FLEXIBLE_ARRAY];
} StgRetDyn;
+/* A function return stack frame: used when saving the state for a
+ * garbage collection at a function entry point. The function
+ * arguments are on the stack, and we also save the function (its
+ * info table describes the pointerhood of the arguments).
+ *
+ * The stack frame size is also cached in the frame for convenience.
+ */
+typedef struct {
+ const struct _StgInfoTable* info;
+ StgWord size;
+ StgClosure * fun;
+ StgClosure * payload[FLEXIBLE_ARRAY];
+} StgRetFun;
+
/* Concurrent communication objects */
typedef struct {
/* ----------------------------------------------------------------------------
- * $Id: Constants.h,v 1.21 2002/09/23 14:33:50 simonmar Exp $
+ * $Id: Constants.h,v 1.22 2002/12/11 15:36:37 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Constants
*
*/
#define MAX_SPEC_AP_SIZE 8
+/* ToDo: make it 8 again */
/* Specialised FUN/THUNK/CONSTR closure types */
*/
#define LARGE_OBJECT_THRESHOLD ((nat)(BLOCK_SIZE * 8 / 10))
-#endif /* CONSTANTS_H */
+/* -----------------------------------------------------------------------------
+ Bitmap/size fields (used in info tables)
+ -------------------------------------------------------------------------- */
+/* In a 32-bit bitmap field, we use 5 bits for the size, and 27 bits
+ * for the bitmap. If the bitmap requires more than 27 bits, then we
+ * store it in a separate array, and leave a pointer in the bitmap
+ * field. On a 64-bit machine, the sizes are extended accordingly.
+ */
+#if SIZEOF_VOID_P == 4
+#define BITMAP_SIZE_MASK 0x1f
+#define BITMAP_BITS_SHIFT 5
+#elif SIZEOF_VOID_P == 8
+#define BITMAP_SIZE_MASK 0x3f
+#define BITMAP_BITS_SHIFT 6
+#else
+#error unknown SIZEOF_VOID_P
+#endif
+
+#endif /* CONSTANTS_H */
/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.20 2002/09/25 20:43:34 wolfgang Exp $
+ * $Id: InfoMacros.h,v 1.21 2002/12/11 15:36:37 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Macros for building and deconstructing info tables.
*
#ifndef INFOMACROS_H
#define INFOMACROS_H
-#define STD_INFO(type_) \
- srt : 0, \
- srt_len : 0, \
+#define STD_INFO(srt_len_, type_) \
+ srt_len : srt_len_, \
type : type_
-#define SRT_INFO(type_,srt_,srt_off_,srt_len_) \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
- srt_len : srt_len_, \
- type : type_
+#define THUNK_INFO(srt_, srt_off_) \
+ srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
-#define CONSTR_INFO(type_,tag_) \
- srt : 0, \
- srt_len : tag_, \
- type : type_
+#define FUN_GEN_INFO(srt_, srt_off_, fun_type_, arity_, bitmap_, slow_apply_) \
+
+#define RET_INFO(srt_, srt_off_) \
+ srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
#ifdef PROFILING
#define PROF_INFO(type_str, desc_str) \
#if defined(GRAN) || defined(PAR)
#define \
-INFO_TABLE_SRT(info, /* info-table label */ \
+INFO_TABLE_THUNK(info, /* info-table label */ \
entry, /* entry code label */ \
ptrs, nptrs, /* closure layout info */\
srt_, srt_off_, srt_len_, /* SRT info */ \
entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
+ info_class const StgInfoTable stg_RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
JMP_(stg_RBH_entry); \
FE_ \
} ; \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry) \
}
#else
#define \
-INFO_TABLE_SRT(info, /* info-table label */ \
+INFO_TABLE_THUNK(info, /* info-table label */ \
entry, /* entry code label */ \
ptrs, nptrs, /* closure layout info */\
srt_, srt_off_, srt_len_, /* SRT info */ \
- type, /* closure type */ \
+ type_, /* closure type */ \
info_class, entry_class, /* C storage classes */ \
prof_descr, prof_type) /* profiling info */ \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(entry) \
+ info_class const StgThunkInfoTable info = { \
+ i : { \
+ layout : { payload : {ptrs,nptrs} }, \
+ PROF_INFO(prof_type, prof_descr) \
+ STD_INFO(srt_len_, type_), \
+ INIT_ENTRY(entry) \
+ }, \
+ THUNK_INFO(srt_,srt_off_), \
}
#endif
#if defined(GRAN) || defined(PAR)
#define \
-INFO_TABLE_SRT_BITMAP(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
+INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
type, info_class, entry_class, \
prof_descr, prof_type) \
entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
+ info_class const StgInfoTable stg_RBH_##info = { \
layout : { bitmap : (StgWord)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
JMP_(stg_RBH_entry); \
FE_ \
} ; \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { bitmap : (StgWord)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(type,srt_,srt_off_,srt_len_), \
#else
#define \
-INFO_TABLE_SRT_BITMAP(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
- type, info_class, entry_class, \
+INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
+ type_, info_class, entry_class, \
prof_descr, prof_type) \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info = { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(entry) \
+ info_class const StgRetInfoTable info = { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ PROF_INFO(prof_type, prof_descr) \
+ STD_INFO(srt_len_,type_), \
+ INIT_ENTRY(entry) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}
#endif
entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
+ info_class const StgInfoTable stg_RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(RBH), \
INCLUDE_RBH_INFO(info), \
INIT_ENTRY(stg_RBH_##entry) \
} ; \
- StgFunPtr stg_RBH_##entry (void) { \
+ StgFunPtr stg_RBH_##entry (void) { \
FB_ \
- JMP_(stg_RBH_entry); \
+ JMP_(stg_RBH_entry); \
FE_ \
} ; \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(type), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry) \
}
INFO_TABLE(info, entry, ptrs, nptrs, type, info_class, \
entry_class, prof_descr, prof_type) \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- STD_INFO(type), \
+ STD_INFO(0, type), \
INIT_ENTRY(entry) \
}
entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
+ info_class const StgInfoTable stg_RBH_##info = { \
layout : { selector_offset : offset }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(RBH), \
JMP_(stg_RBH_entry); \
FE_ \
} ; \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { selector_offset : offset }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(THUNK_SELECTOR), \
INFO_TABLE_SELECTOR(info, entry, offset, info_class, \
entry_class, prof_descr, prof_type) \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { selector_offset : offset }, \
PROF_INFO(prof_type, prof_descr) \
- STD_INFO(THUNK_SELECTOR), \
+ STD_INFO(0,THUNK_SELECTOR), \
INIT_ENTRY(entry) \
}
INFO_TABLE_CONSTR(info, entry, ptrs, nptrs, tag_,type_,info_class, \
entry_class, prof_descr, prof_type) \
entry_class(entry); \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ info_class const StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
- CONSTR_INFO(type_,tag_), \
+ STD_INFO(tag_, type_), \
INIT_ENTRY(entry) \
}
#define constrTag(con) (get_itbl(con)->srt_len)
+/* function info table -----------------------------------------------------*/
+
+#define \
+INFO_TABLE_FUN_GEN(info, /* info-table label */ \
+ entry, /* entry code label */ \
+ ptrs, nptrs, /* closure layout info */\
+ srt_, srt_off_, srt_len_, /* SRT info */ \
+ fun_type_, arity_, bitmap_, slow_apply_, \
+ /* Function info */ \
+ type_, /* closure type */ \
+ info_class, entry_class, /* C storage classes */ \
+ prof_descr, prof_type) /* profiling info */ \
+ entry_class(entry); \
+ info_class const StgFunInfoTable info = { \
+ i : { \
+ layout : { payload : {ptrs,nptrs} }, \
+ PROF_INFO(prof_type, prof_descr) \
+ STD_INFO(srt_len_,type_), \
+ INIT_ENTRY(entry) \
+ }, \
+ srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
+ arity : arity_, \
+ fun_type : fun_type_, \
+ bitmap : (W_)bitmap_, \
+ slow_apply : slow_apply_ \
+ }
+
/* return-vectors ----------------------------------------------------------*/
/* vectored-return info tables have the vector slammed up against the
typedef struct {
StgFunPtr vec[2];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_2;
typedef struct {
StgFunPtr vec[3];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_3;
typedef struct {
StgFunPtr vec[4];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_4;
typedef struct {
StgFunPtr vec[5];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_5;
typedef struct {
StgFunPtr vec[6];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_6;
typedef struct {
StgFunPtr vec[7];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_7;
typedef struct {
StgFunPtr vec[8];
- StgInfoTable i;
+ StgRetInfoTable i;
} vec_info_8;
#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2) \
- info_class INFO_TBL_CONST vec_info_2 info = { \
+ info_class const vec_info_2 info = { \
{ alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3 \
) \
- info_class INFO_TBL_CONST vec_info_3 info = { \
+ info_class const vec_info_3 info = { \
{ alt_3, alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4 \
) \
- info_class INFO_TBL_CONST vec_info_4 info = { \
+ info_class const vec_info_4 info = { \
{ alt_4, alt_3, alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5 \
) \
- info_class INFO_TBL_CONST vec_info_5 info = { \
+ info_class const vec_info_5 info = { \
{ alt_5, alt_4, alt_3, alt_2, \
alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6 \
) \
- info_class INFO_TBL_CONST vec_info_6 info = { \
+ info_class const vec_info_6 info = { \
{ alt_6, alt_5, alt_4, alt_3, \
alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7 \
) \
- info_class INFO_TBL_CONST vec_info_7 info = { \
+ info_class const vec_info_7 info = { \
{ alt_7, alt_6, alt_5, alt_4, \
alt_3, alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7, alt_8 \
) \
- info_class INFO_TBL_CONST vec_info_8 info = { \
+ info_class const vec_info_8 info = { \
{ alt_8, alt_7, alt_6, alt_5, \
alt_4, alt_3, alt_2, alt_1 }, \
i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_) \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
*/
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[2];
} vec_info_2;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[3];
} vec_info_3;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[4];
} vec_info_4;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[5];
} vec_info_5;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[6];
} vec_info_6;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[7];
} vec_info_7;
typedef struct {
- StgInfoTable i;
+ StgRetInfoTable i;
StgFunPtr vec[8];
} vec_info_8;
#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2) \
- info_class INFO_TBL_CONST vec_info_2 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
- }, \
- vec : { alt_1, alt_2 } \
+ info_class const vec_info_2 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
+ } \
}
#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3 \
) \
- info_class INFO_TBL_CONST vec_info_3 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_3 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3 } \
}
#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4 \
) \
- info_class INFO_TBL_CONST vec_info_4 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_4 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4 } \
}
#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5 \
) \
- info_class INFO_TBL_CONST vec_info_5 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_5 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4, \
alt_5 } \
}
#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6 \
) \
- info_class INFO_TBL_CONST vec_info_6 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_6 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6 } \
}
#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7 \
) \
- info_class INFO_TBL_CONST vec_info_7 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_7 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7 } \
}
#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_len_, \
- type, info_class, \
+ type_, info_class, \
alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7, alt_8 \
) \
- info_class INFO_TBL_CONST vec_info_8 info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(NULL) \
+ info_class const vec_info_8 info = { \
+ i : { \
+ i : { \
+ layout : { bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_,type_) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { alt_1, alt_2, alt_3, alt_4, \
alt_5, alt_6, alt_7, alt_8 } \
#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
srt_, srt_off_, srt_len_, \
- type, info_class, entry_class \
+ type_, info_class, entry_class \
) \
- info_class INFO_TBL_CONST vec_info_8 nm##_info = { \
- i : { layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(nm##_entry) \
+ info_class const vec_info_8 nm##_info = { \
+ i : { \
+ i : { \
+ layout : { \
+ bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_, type_), \
+ INIT_ENTRY(nm##_ret) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
}, \
vec : { \
- (F_) nm##_0_entry, \
- (F_) nm##_1_entry, \
- (F_) nm##_2_entry, \
- (F_) nm##_3_entry, \
- (F_) nm##_4_entry, \
- (F_) nm##_5_entry, \
- (F_) nm##_6_entry, \
- (F_) nm##_7_entry \
+ (F_) nm##_0_ret, \
+ (F_) nm##_1_ret, \
+ (F_) nm##_2_ret, \
+ (F_) nm##_3_ret, \
+ (F_) nm##_4_ret, \
+ (F_) nm##_5_ret, \
+ (F_) nm##_6_ret, \
+ (F_) nm##_7_ret \
} \
}
#else
-#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
+#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
srt_, srt_off_, srt_len_, \
- type, info_class, entry_class \
+ type_, info_class, entry_class \
) \
- info_class INFO_TBL_CONST vec_info_8 nm##_info = { \
+ info_class const vec_info_8 nm##_info = { \
{ \
- (F_) nm##_7_entry, \
- (F_) nm##_6_entry, \
- (F_) nm##_5_entry, \
- (F_) nm##_4_entry, \
- (F_) nm##_3_entry, \
- (F_) nm##_2_entry, \
- (F_) nm##_1_entry, \
- (F_) nm##_0_entry \
+ (F_) nm##_7_ret, \
+ (F_) nm##_6_ret, \
+ (F_) nm##_5_ret, \
+ (F_) nm##_4_ret, \
+ (F_) nm##_3_ret, \
+ (F_) nm##_2_ret, \
+ (F_) nm##_1_ret, \
+ (F_) nm##_0_ret \
}, \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INIT_ENTRY(nm##_entry) \
+ i : { \
+ i : { \
+ layout : { \
+ bitmap : (StgWord)bitmap_ }, \
+ STD_INFO(srt_len_, type_), \
+ INIT_ENTRY(nm##_ret) \
+ }, \
+ RET_INFO(srt_,srt_off_) \
} \
}
static const StgSRT lbl = {
#define BITMAP(lbl,size,contents) \
- static const StgLargeBitmap lbl = { \
- (size*4+SIZEOF_VOID_P-1)/SIZEOF_VOID_P, { contents } };
+ static const StgLargeBitmap lbl = { size, { contents } };
#if SIZEOF_VOID_P == 8
-#define BITMAP_SWITCH64(small, large) small
#define BITMAP64(first, second) \
(((StgWord32)(first)) | ((StgWord)(StgWord32)(second) << 32))
#else
-#define BITMAP_SWITCH64(small, large) large
#define BITMAP64(first, second) first, second
#endif
#define BITMAP32(x) ((StgWord32)(x))
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.27 2002/05/14 08:15:49 matthewc Exp $
+ * $Id: InfoTables.h,v 1.28 2002/12/11 15:36:37 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Info Tables
*
#define ip_IND(ip) ( ipFlags(ip) & _IND)
/* -----------------------------------------------------------------------------
- Info Tables
+ Bitmaps
+
+ These are used to describe the pointerhood of a sequence of words
+ (usually on the stack) to the garbage collector. The two primary
+ uses are for stack frames, and functions (where we need to describe
+ the layout of a PAP to the GC).
-------------------------------------------------------------------------- */
-/* A large bitmap. Small 32-bit ones live in the info table, but sometimes
- * 32 bits isn't enough and we have to generate a larger one. (sizes
- * differ for 64-bit machines.
- */
+//
+// Small bitmaps: for a small bitmap, we store the size and bitmap in
+// the same word, using the following macros. If the bitmap doesn't
+// fit in a single word, we use a pointer to an StgLargeBitmap below.
+//
+#define MK_SMALL_BITMAP(size,bits) (((bits)<<BITMAP_BITS_SHIFT) | (size))
+
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+//
+// A large bitmap.
+//
typedef struct {
StgWord size;
StgWord bitmap[FLEXIBLE_ARRAY];
} StgLargeBitmap;
-/*
- * Stuff describing the closure layout. Well, actually, it might
- * contain the selector index for a THUNK_SELECTOR. If we're on a
- * 64-bit architecture then we can enlarge some of these fields, since
- * the union contains a pointer field.
- */
+/* ----------------------------------------------------------------------------
+ Info Tables
+ ------------------------------------------------------------------------- */
+//
+// Stuff describing the closure layout. Well, actually, it might
+// contain the selector index for a THUNK_SELECTOR. This union is one
+// word long.
+//
typedef union {
- struct {
-#if SIZEOF_VOID_P == 8
- StgWord32 ptrs; /* number of pointers */
- StgWord32 nptrs; /* number of non-pointers */
-#else
- StgWord16 ptrs; /* number of pointers */
- StgWord16 nptrs; /* number of non-pointers */
-#endif
- } payload;
+ struct { // Heap closure payload layout:
+ StgHalfWord ptrs; // number of pointers
+ StgHalfWord nptrs; // number of non-pointers
+ } payload;
+
+ StgWord bitmap; // word-sized bit pattern describing
+ // a stack frame: see below
+
+ StgLargeBitmap* large_bitmap; // pointer to large bitmap structure
+
+ StgWord selector_offset; // used in THUNK_SELECTORs
- StgWord bitmap; /* bit pattern, 1 = pointer, 0 = non-pointer */
- StgWord selector_offset; /* used in THUNK_SELECTORs */
- StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */
-
} StgClosureInfo;
-/*
- * Info tables. All info tables are the same type, to simplify code
- * generation. However, the mangler removes any unused SRT fields
- * from the asm to save space (convention: if srt_len is zero, or the
- * type is a CONSTR_ type, then the SRT field isn't present.
- */
+//
+// An SRT.
+//
typedef StgClosure* StgSRT[];
-/*
- * The entry code pointer must be the first word of an info table.
- * See the comment in ghc/rts/Storage.h (Plan C) for details.
- */
+//
+// The "standard" part of an info table. Every info table has this bit.
+//
typedef struct _StgInfoTable {
+
#ifndef TABLES_NEXT_TO_CODE
- StgFunPtr entry;
+ StgFunPtr entry; // pointer to the entry code
#endif
- StgSRT *srt; /* pointer to the SRT table */
+
#if defined(PAR) || defined(GRAN)
struct _StgInfoTable *rbh_infoptr;
#endif
#ifdef DEBUG_CLOSURE
StgDebugInfo debug;
#endif
- StgClosureInfo layout; /* closure layout info (pointer-sized) */
-#if SIZEOF_VOID_P == 8
- StgWord32 type; /* } These 2 elements fit into 64 bits */
- StgWord32 srt_len; /* } */
-#else
- StgWord type : 16; /* } These 2 elements fit into 32 bits */
- StgWord srt_len : 16; /* } */
-#endif
+
+ StgClosureInfo layout; // closure layout info (one word)
+
+ StgHalfWord type; // closure type
+ StgHalfWord srt_len; // number of entries in SRT (or constructor tag)
+
#ifdef TABLES_NEXT_TO_CODE
StgCode code[FLEXIBLE_ARRAY];
-#else
- StgFunPtr vector[FLEXIBLE_ARRAY];
#endif
} StgInfoTable;
-/* Info tables are read-only, therefore we uniformly declare them with
- * C's const attribute. This isn't just a nice thing to do: it's
- * necessary because the garbage collector has to distinguish between
- * closure pointers and info table pointers when traversing the
- * stack. We distinguish the two by checking whether the pointer is
- * into text-space or not.
- */
-
-#if ia64_TARGET_ARCH
-/* We need to give the compiler a gentle hint to put it in text-space */
-#define INFO_TBL_CONST const __attribute__((section (".text")))
+
+/* -----------------------------------------------------------------------------
+ Function info tables
+
+ This is the general form of function info tables. The compiler
+ will omit some of the fields in common cases:
+
+ - If fun_type is not ARG_GEN or ARG_GEN_BIG, then the slow_apply
+ and bitmap fields may be left out (they are at the end, so omitting
+ them doesn't affect the layout).
+
+ - If srt_len (in the std info table part) is zero, then the srt
+ field may be omitted. This only applies if the slow_apply and
+ bitmap fields have also been omitted.
+ -------------------------------------------------------------------------- */
+
+typedef struct _StgFunInfoTable {
+#if defined(TABLES_NEXT_TO_CODE)
+ StgFun *slow_apply; // apply to args on the stack
+ StgWord bitmap; // arg ptr/nonptr bitmap
+ StgSRT *srt; // pointer to the SRT table
+ StgHalfWord fun_type; // function type
+ StgHalfWord arity; // function arity
+ StgInfoTable i;
#else
-#define INFO_TBL_CONST const
+ StgInfoTable i;
+ StgHalfWord fun_type; // function type
+ StgHalfWord arity; // function arity
+ StgSRT *srt; // pointer to the SRT table
+ StgWord bitmap; // arg ptr/nonptr bitmap
+ StgFun *slow_apply; // apply to args on the stack
+#endif
+} StgFunInfoTable;
+
+/* -----------------------------------------------------------------------------
+ Return info tables
+ -------------------------------------------------------------------------- */
+
+// When info tables are laid out backwards, we can omit the SRT
+// pointer iff srt_len is zero.
+
+typedef struct _StgRetInfoTable {
+#if !defined(TABLES_NEXT_TO_CODE)
+ StgInfoTable i;
+#endif
+ StgSRT *srt; // pointer to the SRT table
+#if defined(TABLES_NEXT_TO_CODE)
+ StgInfoTable i;
+#endif
+#if !defined(TABLES_NEXT_TO_CODE)
+ StgFunPtr vector[FLEXIBLE_ARRAY];
+#endif
+} StgRetInfoTable;
+
+/* -----------------------------------------------------------------------------
+ Thunk info tables
+ -------------------------------------------------------------------------- */
+
+// When info tables are laid out backwards, we can omit the SRT
+// pointer iff srt_len is zero.
+
+typedef struct _StgThunkInfoTable {
+#if !defined(TABLES_NEXT_TO_CODE)
+ StgInfoTable i;
+#endif
+ StgSRT *srt; // pointer to the SRT table
+#if defined(TABLES_NEXT_TO_CODE)
+ StgInfoTable i;
#endif
+} StgThunkInfoTable;
#endif /* INFOTABLES_H */
/* -----------------------------------------------------------------------------
- * $Id: MachDeps.h,v 1.7 2001/10/03 13:57:42 simonmar Exp $
+ * $Id: MachDeps.h,v 1.8 2002/12/11 15:36:37 simonmar Exp $
*
- * (c) The GRASP/AQUA Project, Glasgow University, 1998
- * (c) The GHC Team, 1998-1999
- * (c) The University of Glasgow 2001
+ * (c) The University of Glasgow 2002
*
* Definitions that characterise machine specific properties of basic
* types (C & Haskell).
/* -----------------------------------------------------------------------------
- * $Id: MachRegs.h,v 1.12 2002/10/02 09:08:44 wolfgang Exp $
+ * $Id: MachRegs.h,v 1.13 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
CALLER_SAVES_USER one or more of R<n>, F, D
are caller-saves.
- CALLER_SAVES_SYSTEM one or more of Sp, Su, SpLim, Hp, HpLim
+ CALLER_SAVES_SYSTEM one or more of Sp, SpLim, Hp, HpLim
are caller-saves.
This is so that the callWrapper mechanism knows which kind of
t6 $7 R7
t7 $8 R8
s0 $9 Sp
- s1 $10 Su
s2 $11 SpLim
s3 $12 Hp
s4 $13 HpLim
# define REG_D2 f7
# define REG_Sp 9
-# define REG_Su 10
# define REG_SpLim 11
# define REG_Hp 12
#define REG_D2 fr21 /* L & R */
#define REG_Sp r4
-#define REG_Su r5
#define REG_SpLim r6
#define REG_Hp r7
esi R1
edi Hp
- Leaving Su, SpLim, and HpLim out of the picture.
+ Leaving SpLim, and HpLim out of the picture.
-------------------------------------------------------------------------- */
#define REG_Base ebx
#endif
#define REG_Sp ebp
-/* #define REG_Su ebx*/
#if STOLEN_X86_REGS >= 3
# define REG_R1 esi
#define REG_Base a2
#define REG_Sp a3
-#define REG_Su a4
#define REG_SpLim d3
#define REG_Hp d4
#define REG_D2 f30
#define REG_Sp 16
-#define REG_Su 17
#define REG_SpLim 18
#define REG_Hp 19
#define REG_D2 f19
#define REG_Sp r22
-#define REG_Su r23
#define REG_SpLim r24
#define REG_Hp r25
#define REG_D2 f21
#define REG_Sp loc24
-#define REG_Su loc25
#define REG_SpLim loc26
#define REG_Hp loc27
#define REG_D2 f4
#define REG_Sp i0
-#define REG_Su i1
#define REG_SpLim i2
#define REG_Hp i3
#endif /* sparc */
-/* These constants define how many stg registers are *actually* in
- * registers: the code generator uses this information to avoid
- * generating code to load/store registers which are really offsets
- * from BaseReg.
+#endif /* NO_REGS */
+
+/* -----------------------------------------------------------------------------
+ * These constants define how many stg registers will be used for
+ * passing arguments (and results, in the case of an unboxed-tuple
+ * return).
+ *
+ * We usually set MAX_REAL_VANILLA_REG and co. to be the number of the
+ * highest STG register to occupy a real machine register, otherwise
+ * the calling conventions will needlessly shuffle data between the
+ * stack and memory-resident STG registers. We might occasionally
+ * set these macros to other values for testing, though.
*
* Registers above these values might still be used, for instance to
* communicate with PrimOps and RTS functions.
*/
#ifndef MAX_REAL_VANILLA_REG
-#define MAX_REAL_VANILLA_REG 8
+# if defined(REG_R8)
+# define MAX_REAL_VANILLA_REG 8
+# elif defined(REG_R7)
+# define MAX_REAL_VANILLA_REG 7
+# elif defined(REG_R6)
+# define MAX_REAL_VANILLA_REG 6
+# elif defined(REG_R5)
+# define MAX_REAL_VANILLA_REG 5
+# elif defined(REG_R4)
+# define MAX_REAL_VANILLA_REG 4
+# elif defined(REG_R3)
+# define MAX_REAL_VANILLA_REG 3
+# elif defined(REG_R2)
+# define MAX_REAL_VANILLA_REG 2
+# elif defined(REG_R1)
+# define MAX_REAL_VANILLA_REG 1
+# else
+# define MAX_REAL_VANILLA_REG 0
+# endif
#endif
#ifndef MAX_REAL_FLOAT_REG
-#define MAX_REAL_FLOAT_REG 4
+# if defined(REG_F4)
+# define MAX_REAL_FLOAT_REG 4
+# elif defined(REG_F3)
+# define MAX_REAL_FLOAT_REG 3
+# elif defined(REG_F2)
+# define MAX_REAL_FLOAT_REG 2
+# elif defined(REG_F1)
+# define MAX_REAL_FLOAT_REG 1
+# else
+# define MAX_REAL_FLOAT_REG 0
+# endif
#endif
#ifndef MAX_REAL_DOUBLE_REG
-#define MAX_REAL_DOUBLE_REG 2
+# if defined(REG_D2)
+# define MAX_REAL_DOUBLE_REG 2
+# elif defined(REG_D1)
+# define MAX_REAL_DOUBLE_REG 1
+# else
+# define MAX_REAL_DOUBLE_REG 0
+# endif
#endif
-#endif /* NO_REGS */
+#ifndef MAX_REAL_LONG_REG
+# if defined(REG_L1)
+# define MAX_REAL_LONG_REG 1
+# else
+# define MAX_REAL_LONG_REG 0
+# endif
+#endif
+
+/* define NO_ARG_REGS if we have no argument registers at all (we can
+ * optimise certain code paths using this predicate).
+ */
+#if MAX_REAL_VANILLA_REG < 2
+#define NO_ARG_REGS
+#else
+#undef NO_ARG_REGS
+#endif
#endif /* MACHREGS_H */
/* -----------------------------------------------------------------------------
- * $Id: Regs.h,v 1.11 2002/01/24 00:40:28 sof Exp $
+ * $Id: Regs.h,v 1.12 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
} StgSparkPool;
typedef struct {
- StgFunPtr stgChk0;
- StgFunPtr stgChk1;
StgFunPtr stgGCEnter1;
- StgFunPtr stgUpdatePAP;
+ StgFunPtr stgGCFun;
} StgFunTable;
typedef struct StgRegTable_ {
StgDouble rD2;
StgWord64 rL1;
StgPtr rSp;
- StgUpdateFrame *rSu;
StgPtr rSpLim;
StgPtr rHp;
StgPtr rHpLim;
* Registers Hp and HpLim are global across the entire system, and are
* copied into the RegTable before executing a thread.
*
- * Registers Sp, Su, and SpLim are saved in the TSO for the
+ * Registers Sp and SpLim are saved in the TSO for the
* thread, but are copied into the RegTable before executing a thread.
*
* All other registers are "general purpose", and are used for passing
*/
#define SAVE_Sp (CurrentTSO->sp)
-#define SAVE_Su (CurrentTSO->su)
#define SAVE_SpLim (CurrentTSO->splim)
#define SAVE_Hp (BaseReg->rHp)
#define Sp (BaseReg->rSp)
#endif
-#ifdef REG_Su
-GLOBAL_REG_DECL(StgUpdateFrame *,Su,REG_Su)
-#else
-#define Su (BaseReg->rSu)
-#endif
-
#ifdef REG_SpLim
GLOBAL_REG_DECL(P_,SpLim,REG_SpLim)
#else
#define FunReg ((StgFunTable *)((void *)BaseReg - sizeof(StgFunTable)))
-#define stg_chk_0 (FunReg->stgChk0)
-#define stg_chk_1 (FunReg->stgChk1)
#define stg_gc_enter_1 (FunReg->stgGCEnter1)
-#define stg_update_PAP (FunReg->stgUpdatePAP)
+#define stg_gc_fun (FunReg->stgGCFun)
/* -----------------------------------------------------------------------------
For any registers which are denoted "caller-saves" by the C calling
#define CALLER_RESTORE_Sp /* nothing */
#endif
-#ifdef CALLER_SAVES_Su
-#define CALLER_SAVE_Su SAVE_Su = Su;
-#define CALLER_RESTORE_Su Su = SAVE_Su;
-#else
-#define CALLER_SAVE_Su /* nothing */
-#define CALLER_RESTORE_Su /* nothing */
-#endif
-
#ifdef CALLER_SAVES_SpLim
#define CALLER_SAVE_SpLim SAVE_SpLim = SpLim;
#define CALLER_RESTORE_SpLim SpLim = SAVE_SpLim;
be addressed relative to it */
#define CALLER_SAVE_SYSTEM \
CALLER_SAVE_Sp \
- CALLER_SAVE_Su \
CALLER_SAVE_SpLim \
CALLER_SAVE_Hp \
CALLER_SAVE_HpLim \
#define CALLER_RESTORE_SYSTEM \
CALLER_RESTORE_Base \
CALLER_RESTORE_Sp \
- CALLER_RESTORE_Su \
CALLER_RESTORE_SpLim \
CALLER_RESTORE_Hp \
CALLER_RESTORE_HpLim \
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.43 2002/08/05 10:11:03 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.44 2002/12/11 15:36:39 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
struct DEBUG_FLAGS {
// flags to control debugging output & extra checking in various subsystems
rtsBool scheduler; // 's'
- rtsBool evaluator; // 'e'
+ rtsBool interpreter; // 'i'
rtsBool codegen; // 'c'
rtsBool weak; // 'w'
rtsBool gccafs; // 'G'
rtsBool gran; // 'r'
rtsBool par; // 'P'
rtsBool linker; // 'l' the object linker
+ rtsBool apply; // 'a'
};
struct COST_CENTRE_FLAGS {
/* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.15 2002/06/19 20:45:17 sof Exp $
+ * $Id: SchedAPI.h,v 1.16 2002/12/11 15:36:39 simonmar Exp $
*
- * (c) The GHC Team 1998
+ * (c) The GHC Team 1998-2002
*
* External API for the scheduler. For most uses, the functions in
* RtsAPI.h should be enough.
extern void scheduleThread(StgTSO *tso);
extern SchedulerStatus scheduleWaitThread(StgTSO *tso, /*out*/HaskellObj* ret);
-static inline void pushClosure (StgTSO *tso, StgClosure *c) {
+static inline void pushClosure (StgTSO *tso, StgWord c) {
tso->sp--;
tso->sp[0] = (W_) c;
}
-static inline void pushRealWorld (StgTSO *tso) {
- tso->sp--;
- tso->sp[0] = (W_) REALWORLD_TAG;
-}
static inline StgTSO *
createGenThread(nat stack_size, StgClosure *closure) {
StgTSO *t;
#else
t = createThread(stack_size);
#endif
- pushClosure(t,closure);
+ pushClosure(t, (W_)closure);
+ pushClosure(t, (W_)&stg_enter_info);
return t;
}
#else
t = createThread(stack_size);
#endif
- pushRealWorld(t);
- pushClosure(t,closure);
+ pushClosure(t, (W_)&stg_noforceIO_info);
+ pushClosure(t, (W_)&stg_ap_v_info);
+ pushClosure(t, (W_)closure);
+ pushClosure(t, (W_)&stg_enter_info);
return t;
}
#else
t = createThread(stack_size);
#endif
- pushClosure(t,closure);
- pushClosure(t,(StgClosure*)&stg_forceIO_closure);
+ pushClosure(t, (W_)&stg_forceIO_info);
+ pushClosure(t, (W_)&stg_ap_v_info);
+ pushClosure(t, (W_)closure);
+ pushClosure(t, (W_)&stg_enter_info);
return t;
}
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.49 2002/09/06 14:34:14 simonmar Exp $
+ * $Id: Stg.h,v 1.50 2002/12/11 15:36:39 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "StgLdvProf.h"
/* Storage format definitions */
+#include "StgFun.h"
#include "Closures.h"
#include "ClosureTypes.h"
#include "InfoTables.h"
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * (c) The GHC Team, 2002
+ *
+ * Things for functions.
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGFUN_H
+#define STGFUN_H
+
+/* generic - function comes with a small bitmap */
+#define ARG_GEN 0
+
+/* generic - function comes with a large bitmap */
+#define ARG_GEN_BIG 1
+
+/* BCO - function is really a BCO */
+#define ARG_BCO 2
+
+/* specialised function types: bitmaps and calling sequences
+ * for these functions are pre-generated (see ghc/utils/genapply), and
+ * the generated code in ghc/rts/AutoApply.hc.
+ */
+#define ARG_N 3
+#define ARG_P 4
+#define ARG_F 5
+#define ARG_D 6
+#define ARG_L 7
+#define ARG_NN 8
+#define ARG_NP 9
+#define ARG_PN 10
+#define ARG_PP 11
+#define ARG_FF 12
+#define ARG_DD 13
+#define ARG_LL 14
+#define ARG_NNN 15
+#define ARG_NNP 16
+#define ARG_NPN 17
+#define ARG_NPP 18
+#define ARG_PNN 19
+#define ARG_PNP 20
+#define ARG_PPN 21
+#define ARG_PPP 22
+#define ARG_PPPP 23
+#define ARG_PPPPP 24
+#define ARG_PPPPPP 25
+#define ARG_PPPPPPP 26
+#define ARG_PPPPPPPP 27
+
+#endif // STGFUN_H
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.49 2002/10/12 23:19:54 wolfgang Exp $
+ * $Id: StgMacros.h,v 1.50 2002/12/11 15:36:39 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define EXTFUN(f) extern StgFunPtr f(void)
#define EXTFUN_RTS(f) extern DLL_IMPORT_RTS StgFunPtr f(void)
#define FN_(f) F_ f(void)
-#define IFN_(f) static F_ f(void)
#define IF_(f) static F_ f(void)
#define EF_(f) extern F_ f(void)
#define EDF_(f) extern DLLIMPORT F_ f(void)
-#define EXTINFO_RTS extern DLL_IMPORT_RTS INFO_TBL_CONST StgInfoTable
+#define EXTINFO_RTS extern DLL_IMPORT_RTS const StgInfoTable
+#define ETI_RTS extern DLL_IMPORT_RTS const StgThunkInfoTable
+
+// Info tables as generated by the compiler are simply arrays of words.
+typedef StgWord StgWordArray[];
+
#define ED_ extern
#define EDD_ extern DLLIMPORT
#define ED_RO_ extern const
#define ID_ static
#define ID_RO_ static const
-#define EI_ extern INFO_TBL_CONST StgInfoTable
-#define EDI_ extern DLLIMPORT INFO_TBL_CONST StgInfoTable
-#define II_ static INFO_TBL_CONST StgInfoTable
+#define EI_ extern StgWordArray
+#define ERI_ extern const StgRetInfoTable
+#define II_ static StgWordArray
+#define IRI_ static const StgRetInfoTable
#define EC_ extern StgClosure
#define EDC_ extern DLLIMPORT StgClosure
#define IC_ static StgClosure
#define ICP_(x) static const StgClosure *(x)[]
/* -----------------------------------------------------------------------------
- Stack Tagging.
-
- For a block of non-pointer words on the stack, we precede the
- block with a small-integer tag giving the number of non-pointer
- words in the block.
- -------------------------------------------------------------------------- */
-
-#define ARGTAG_MAX 16 /* probably arbitrary */
-#define ARG_TAG(n) (n)
-#define ARG_SIZE(n) (StgWord)n
-
-typedef enum {
- REALWORLD_TAG = 0,
- INT_TAG = sizeofW(StgInt),
- INT64_TAG = sizeofW(StgInt64),
- WORD_TAG = sizeofW(StgWord),
- ADDR_TAG = sizeofW(StgAddr),
- CHAR_TAG = sizeofW(StgChar),
- FLOAT_TAG = sizeofW(StgFloat),
- DOUBLE_TAG = sizeofW(StgDouble),
- STABLE_TAG = sizeofW(StgWord),
-} StackTag;
-
-static inline int IS_ARG_TAG( StgWord p );
-static inline int IS_ARG_TAG( StgWord p ) { return p <= ARGTAG_MAX; }
+ Entering
-/* -----------------------------------------------------------------------------
- Argument checks.
-
- If (Sp + <n_args>) > Su { JMP_(stg_update_PAP); }
-
- Sp points to the topmost used word on the stack, and Su points to
- the most recently pushed update frame.
-
- Remember that <n_args> must include any tagging of unboxed values.
-
- ARGS_CHK_LOAD_NODE is for top-level functions, whose entry
- convention doesn't require that Node is loaded with a pointer to
- the closure. Thus we must load node before calling stg_updatePAP if
- the argument check fails.
+ It isn't safe to "enter" every closure. Functions in particular
+ have no entry code as such; their entry point contains the code to
+ apply the function.
-------------------------------------------------------------------------- */
-#define ARGS_CHK(n) \
- if ((P_)(Sp + (n)) > (P_)Su) { \
- JMP_(stg_update_PAP); \
- }
-
-#define ARGS_CHK_LOAD_NODE(n,closure) \
- if ((P_)(Sp + (n)) > (P_)Su) { \
- R1.p = (P_)closure; \
- JMP_(stg_update_PAP); \
- }
+#define ENTER() \
+ { \
+ again: \
+ switch (get_itbl(R1.cl)->type) { \
+ case IND: \
+ case IND_OLDGEN: \
+ case IND_PERM: \
+ case IND_OLDGEN_PERM: \
+ case IND_STATIC: \
+ R1.cl = ((StgInd *)R1.cl)->indirectee; \
+ goto again; \
+ case BCO: \
+ case FUN: \
+ case FUN_1_0: \
+ case FUN_0_1: \
+ case FUN_2_0: \
+ case FUN_1_1: \
+ case FUN_0_2: \
+ case FUN_STATIC: \
+ case PAP: \
+ JMP_(ENTRY_CODE(Sp[0])); \
+ default: \
+ JMP_(GET_ENTRY(R1.cl)); \
+ } \
+ }
/* -----------------------------------------------------------------------------
Heap/Stack Checks.
in the meantime.
------------------------------------------------------------------------- */
-#define STK_CHK(headroom,ret,r,layout,tag_assts) \
- if (Sp - headroom < SpLim) { \
- tag_assts \
- (r) = (P_)ret; \
- JMP_(stg_chk_##layout); \
+#define STK_CHK_FUN(headroom,assts) \
+ if (Sp - headroom < SpLim) { \
+ assts \
+ JMP_(stg_gc_fun); \
}
-
-#define HP_CHK(headroom,ret,r,layout,tag_assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += headroom) > HpLim) { \
- HpAlloc = (headroom); \
- tag_assts \
- (r) = (P_)ret; \
- JMP_(stg_chk_##layout); \
- }
-#define HP_STK_CHK(stk_headroom,hp_headroom,ret,r,layout,tag_assts) \
- DO_GRAN_ALLOCATE(hp_headroom) \
- if ((Hp += hp_headroom) > HpLim || Sp - stk_headroom < SpLim) { \
- HpAlloc = (hp_headroom); \
- tag_assts \
- (r) = (P_)ret; \
- JMP_(stg_chk_##layout); \
- }
+#define HP_CHK_FUN(headroom,assts) \
+ DO_GRAN_ALLOCATE(headroom) \
+ if ((Hp += headroom) > HpLim) { \
+ HpAlloc = (headroom); \
+ assts \
+ JMP_(stg_gc_fun); \
+ }
+
+// When doing both a heap and a stack check, don't move the heap
+// pointer unless the stack check succeeds. Otherwise we might end up
+// with slop at the end of the current block, which can confuse the
+// LDV profiler.
+#define HP_STK_CHK_FUN(stk_headroom,hp_headroom,assts) \
+ DO_GRAN_ALLOCATE(hp_headroom) \
+ if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) { \
+ HpAlloc = (hp_headroom); \
+ assts \
+ JMP_(stg_gc_fun); \
+ }
/* -----------------------------------------------------------------------------
A Heap Check in a case alternative are much simpler: everything is
HpLim points to the LAST WORD of valid allocation space.
-------------------------------------------------------------------------- */
-#define STK_CHK_NP(headroom,ptrs,tag_assts) \
- if ((Sp - (headroom)) < SpLim) { \
- tag_assts \
- JMP_(stg_gc_enter_##ptrs); \
+#define STK_CHK_NP(headroom,tag_assts) \
+ if ((Sp - (headroom)) < SpLim) { \
+ tag_assts \
+ JMP_(stg_gc_enter_1); \
}
-#define HP_CHK_NP(headroom,ptrs,tag_assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += (headroom)) > HpLim) { \
- HpAlloc = (headroom); \
- tag_assts \
- JMP_(stg_gc_enter_##ptrs); \
- }
-
-#define HP_CHK_SEQ_NP(headroom,ptrs,tag_assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += (headroom)) > HpLim) { \
- HpAlloc = (headroom); \
- tag_assts \
- JMP_(stg_gc_seq_##ptrs); \
+#define HP_CHK_NP(headroom,tag_assts) \
+ DO_GRAN_ALLOCATE(headroom) \
+ if ((Hp += (headroom)) > HpLim) { \
+ HpAlloc = (headroom); \
+ tag_assts \
+ JMP_(stg_gc_enter_1); \
}
-#define HP_STK_CHK_NP(stk_headroom, hp_headroom, ptrs, tag_assts) \
+// See comment on HP_STK_CHK_FUN above.
+#define HP_STK_CHK_NP(stk_headroom, hp_headroom, tag_assts) \
DO_GRAN_ALLOCATE(hp_headroom) \
- if ((Hp += (hp_headroom)) > HpLim || (Sp - (stk_headroom)) < SpLim) { \
+ if ((Sp - (stk_headroom)) < SpLim || (Hp += (hp_headroom)) > HpLim) { \
HpAlloc = (hp_headroom); \
tag_assts \
- JMP_(stg_gc_enter_##ptrs); \
+ JMP_(stg_gc_enter_1); \
}
#define GEN_HP_CHK_ALT(headroom,lbl,tag_assts) \
DO_GRAN_ALLOCATE(headroom) \
if ((Hp += (headroom)) > HpLim) { \
- EXTFUN_RTS(lbl); \
HpAlloc = (headroom); \
tag_assts \
JMP_(lbl); \
GEN_HP_CHK_ALT(headroom,stg_gc_f1,tag_assts);
#define HP_CHK_D1(headroom,tag_assts) \
GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
-
#define HP_CHK_L1(headroom,tag_assts) \
GEN_HP_CHK_ALT(headroom,stg_gc_l1,tag_assts);
-#define HP_CHK_UT_ALT(headroom, ptrs, nptrs, r, ret, tag_assts) \
- GEN_HP_CHK_ALT(headroom, stg_gc_ut_##ptrs##_##nptrs, \
- tag_assts r = (P_)ret;)
-
/* -----------------------------------------------------------------------------
Generic Heap checks.
- primitives (no SRT required).
- The stack layout is like this:
+ The stack frame layout for a RET_DYN is like this:
+ some pointers
+ some nonpointers
DblReg1-2
FltReg1-4
R1-8
liveness mask
stg_gen_chk_info
- so the liveness mask depends on the size of an StgDouble (FltRegs
- and R<n> are guaranteed to be 1 word in size).
+ we assume that the size of a double is always 2 pointers (wasting a
+ word when it is only one pointer, but avoiding lots of #ifdefs).
-------------------------------------------------------------------------- */
-/* VERY MAGIC CONSTANTS!
- * must agree with code in HeapStackCheck.c, stg_gen_chk
- */
-
-#if SIZEOF_DOUBLE > SIZEOF_VOID_P
+// VERY MAGIC CONSTANTS!
+// must agree with code in HeapStackCheck.c, stg_gen_chk
+//
#define ALL_NON_PTRS 0xffff
-#else /* SIZEOF_DOUBLE == SIZEOF_VOID_P */
-#define ALL_NON_PTRS 0x3fff
-#endif
+#define RET_DYN_SIZE 16
#define LIVENESS_MASK(ptr_regs) (ALL_NON_PTRS ^ (ptr_regs))
+// We can have up to 255 pointers and 255 nonpointers in the stack
+// frame.
+#define N_NONPTRS(n) ((n)<<16)
+#define N_PTRS(n) ((n)<<24)
+
+#define GET_NONPTRS(l) ((l)>>16 & 0xff)
+#define GET_PTRS(l) ((l)>>24 & 0xff)
+#define GET_LIVENESS(l) ((l) & 0xffff)
+
#define NO_PTRS 0
#define R1_PTR 1<<0
#define R2_PTR 1<<1
#define R7_PTR 1<<6
#define R8_PTR 1<<7
-#define HP_CHK_GEN(headroom,liveness,reentry,tag_assts) \
+#define HP_CHK_UNBX_TUPLE(headroom,liveness,code) \
if ((Hp += (headroom)) > HpLim ) { \
HpAlloc = (headroom); \
- tag_assts \
+ code \
R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gen_chk); \
+ JMP_(stg_gc_ut); \
}
-#define HP_CHK_GEN_TICKY(headroom,liveness,reentry,tag_assts) \
- HP_CHK_GEN(headroom,liveness,reentry,tag_assts); \
+#define HP_CHK_GEN(headroom,liveness,reentry) \
+ if ((Hp += (headroom)) > HpLim ) { \
+ HpAlloc = (headroom); \
+ R9.w = (W_)LIVENESS_MASK(liveness); \
+ R10.w = (W_)reentry; \
+ JMP_(stg_gc_gen); \
+ }
+
+#define HP_CHK_GEN_TICKY(headroom,liveness,reentry) \
+ HP_CHK_GEN(headroom,liveness,reentry); \
TICK_ALLOC_HEAP_NOCTR(headroom)
-#define STK_CHK_GEN(headroom,liveness,reentry,tag_assts) \
+#define STK_CHK_GEN(headroom,liveness,reentry) \
if ((Sp - (headroom)) < SpLim) { \
- tag_assts \
R9.w = (W_)LIVENESS_MASK(liveness); \
R10.w = (W_)reentry; \
- JMP_(stg_gen_chk); \
+ JMP_(stg_gc_gen); \
}
#define MAYBE_GC(liveness,reentry) \
if (doYouWantToGC()) { \
R9.w = (W_)LIVENESS_MASK(liveness); \
R10.w = (W_)reentry; \
- JMP_(stg_gen_hp); \
+ JMP_(stg_gc_gen_hp); \
}
/* -----------------------------------------------------------------------------
We use a RET_DYN frame the same as for a dynamic heap check.
------------------------------------------------------------------------- */
-EXTINFO_RTS(stg_gen_chk_info);
-
/* -----------------------------------------------------------------------------
Vectored Returns
Return vectors are placed in *reverse order* immediately before the info
table for the return address. Hence the formula for computing the
- actual return address is (addr - sizeof(InfoTable) - tag - 1).
+ actual return address is (addr - sizeof(RetInfoTable) - tag - 1).
The extra subtraction of one word is because tags start at zero.
-------------------------------------------------------------------------- */
#ifdef TABLES_NEXT_TO_CODE
-#define RET_VEC(p,t) (*((P_)(p) - sizeofW(StgInfoTable) - t - 1))
+#define RET_VEC(p,t) (*((P_)(p) - sizeofW(StgRetInfoTable) - t - 1))
#else
-#define RET_VEC(p,t) (((StgInfoTable *)p)->vector[t])
+#define RET_VEC(p,t) (((StgRetInfoTable *)p)->vector[t])
#endif
/* -----------------------------------------------------------------------------
#endif /* EAGER_BLACKHOLING */
#define UPD_FRAME_UPDATEE(p) ((P_)(((StgUpdateFrame *)(p))->updatee))
-#define UPDATE_SU_FROM_UPD_FRAME(p) (Su=((StgUpdateFrame *)(p))->link)
/* -----------------------------------------------------------------------------
Moving Floats and Doubles
ASSIGN_FLT is for assigning a float to memory (usually the
stack/heap). The memory address is guaranteed to be
- StgWord aligned (currently == sizeof(long)).
+ StgWord aligned (currently == sizeof(void *)).
PK_FLT is for pulling a float out of memory. The memory is
guaranteed to be StgWord aligned.
extern DLL_IMPORT_RTS const StgPolyInfoTable stg_catch_frame_info;
/* -----------------------------------------------------------------------------
- Seq frames
-
- A seq frame is very like an update frame, except that it doesn't do
- an update...
- -------------------------------------------------------------------------- */
-
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_seq_frame_info;
-
-#define PUSH_SEQ_FRAME(sp) \
- { \
- StgSeqFrame *__frame; \
- TICK_SEQF_PUSHED(); \
- __frame = (StgSeqFrame *)(sp); \
- SET_HDR((StgClosure *)__frame,(StgInfoTable *)&stg_seq_frame_info,CCCS);\
- __frame->link = Su; \
- Su = (StgUpdateFrame *)__frame; \
- }
-
-/* -----------------------------------------------------------------------------
Split markers
-------------------------------------------------------------------------- */
tso = CurrentTSO;
tso->sp = Sp;
- tso->su = Su;
CloseNursery(Hp);
#ifdef REG_CurrentTSO
tso = CurrentTSO;
Sp = tso->sp;
- Su = tso->su;
SpLim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
OpenNursery(Hp,HpLim);
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.43 2002/03/02 17:46:03 sof Exp $
+ * $Id: StgMiscClosures.h,v 1.44 2002/12/11 15:36:39 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Entry code for various built-in closure types.
*
* these objects can be found in StgMiscClosures.hc.
*/
-/* entry code */
-
-STGFUN(stg_IND_entry);
-STGFUN(stg_IND_STATIC_entry);
-STGFUN(stg_IND_PERM_entry);
-STGFUN(stg_IND_OLDGEN_entry);
-STGFUN(stg_IND_OLDGEN_PERM_entry);
-STGFUN(stg_CAF_UNENTERED_entry);
-STGFUN(stg_CAF_ENTERED_entry);
-STGFUN(stg_BLACKHOLE_entry);
-STGFUN(stg_CAF_BLACKHOLE_entry);
-STGFUN(stg_BLACKHOLE_BQ_entry);
-#ifdef SMP
-STGFUN(stg_WHITEHOLE_entry);
-#endif
-#ifdef TICKY_TICKY
-STGFUN(stg_SE_BLACKHOLE_entry);
-STGFUN(stg_SE_CAF_BLACKHOLE_entry);
-#endif
-#if defined(PAR) || defined(GRAN)
-STGFUN(stg_RBH_entry);
-#endif
-STGFUN(stg_BCO_entry);
-STGFUN(stg_EVACUATED_entry);
-STGFUN(stg_FOREIGN_entry);
-STGFUN(stg_WEAK_entry);
-STGFUN(stg_NO_FINALIZER_entry);
-STGFUN(stg_DEAD_WEAK_entry);
-STGFUN(stg_STABLE_NAME_entry);
-STGFUN(stg_TSO_entry);
-STGFUN(stg_FULL_MVAR_entry);
-STGFUN(stg_EMPTY_MVAR_entry);
-STGFUN(stg_ARR_WORDS_entry);
-STGFUN(stg_MUT_ARR_PTRS_entry);
-STGFUN(stg_MUT_ARR_PTRS_FROZEN_entry);
-STGFUN(stg_MUT_VAR_entry);
-STGFUN(stg_END_TSO_QUEUE_entry);
-STGFUN(stg_MUT_CONS_entry);
-STGFUN(stg_END_MUT_LIST_entry);
-STGFUN(stg_dummy_ret_entry);
-
-/* entry code for constructors created by the bytecode interpreter */
+/* Various entry points */
+STGFUN(stg_PAP_entry);
+
+/* Entry code for constructors created by the bytecode interpreter */
STGFUN(stg_interp_constr_entry);
STGFUN(stg_interp_constr1_entry);
STGFUN(stg_interp_constr2_entry);
/* Magic glue code for when compiled code returns a value in R1/F1/D1
or a VoidRep to the interpreter. */
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1p_info;
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1n_info;
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_F1_info;
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_D1_info;
-extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_V_info;
-
-/* Used by the interpreter to return an unboxed value on the stack to
- compiled code. */
-extern DLL_IMPORT_RTS const StgInfoTable stg_gc_unbx_r1_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_gc_f1_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_gc_d1_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_gc_l1_info;
+extern DLL_IMPORT_RTS const StgPolyInfoTable stg_ctoi_ret_R1p_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_R1unpt_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_R1n_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_F1_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_D1_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_L1_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_V_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_apply_interp_info;
/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
#if defined(PAR)
extern DLL_IMPORT_RTS const StgInfoTable stg_FETCH_ME_BQ_info;
#endif
-extern DLL_IMPORT_RTS const StgInfoTable stg_BCO_info;
+extern DLL_IMPORT_RTS const StgFunInfoTable stg_BCO_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_EVACUATED_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_FOREIGN_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_WEAK_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_CONS_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_END_MUT_LIST_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_catch_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_seq_info;
+extern DLL_IMPORT_RTS const StgPolyInfoTable stg_seq_frame_info;
+extern DLL_IMPORT_RTS const StgInfoTable stg_PAP_info;
+extern DLL_IMPORT_RTS const StgInfoTable stg_AP_info;
+extern DLL_IMPORT_RTS const StgInfoTable stg_AP_STACK_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_dummy_ret_info;
-
+extern DLL_IMPORT_RTS const StgInfoTable stg_raise_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_forceIO_info;
+extern DLL_IMPORT_RTS const StgRetInfoTable stg_noforceIO_info;
/* closures */
extern DLL_IMPORT_RTS StgClosure stg_END_TSO_QUEUE_closure;
extern DLL_IMPORT_RTS StgIntCharlikeClosure stg_CHARLIKE_closure[];
extern DLL_IMPORT_RTS StgIntCharlikeClosure stg_INTLIKE_closure[];
-/* standard entry points */
-
-/* EXTFUN_RTS(stg_error_entry); No longer used */
- /* (see also below -- KSW 1998-12) */
+/* standard entry points */
/* standard selector thunks */
EXTFUN_RTS(stg_sel_14_noupd_entry);
EXTFUN_RTS(stg_sel_15_noupd_entry);
-/* standard ap thunks */
-
-EXTINFO_RTS stg_ap_1_upd_info;
-EXTINFO_RTS stg_ap_2_upd_info;
-EXTINFO_RTS stg_ap_3_upd_info;
-EXTINFO_RTS stg_ap_4_upd_info;
-EXTINFO_RTS stg_ap_5_upd_info;
-EXTINFO_RTS stg_ap_6_upd_info;
-EXTINFO_RTS stg_ap_7_upd_info;
-EXTINFO_RTS stg_ap_8_upd_info;
-
-/* standard GC & stack check entry points */
-
-EXTFUN(stg_gc_entertop);
-EXTFUN(stg_gc_enter_1_hponly);
-EXTFUN(__stg_gc_enter_1);
-EXTFUN(stg_gc_enter_2);
-EXTFUN(stg_gc_enter_3);
-EXTFUN(stg_gc_enter_4);
-EXTFUN(stg_gc_enter_5);
-EXTFUN(stg_gc_enter_6);
-EXTFUN(stg_gc_enter_7);
-EXTFUN(stg_gc_enter_8);
-EXTFUN(stg_gc_seq_1);
-
-EI_(stg_gc_noregs_info);
+// standard ap thunks
+
+ETI_RTS stg_ap_1_upd_info;
+ETI_RTS stg_ap_2_upd_info;
+ETI_RTS stg_ap_3_upd_info;
+ETI_RTS stg_ap_4_upd_info;
+ETI_RTS stg_ap_5_upd_info;
+ETI_RTS stg_ap_6_upd_info;
+ETI_RTS stg_ap_7_upd_info;
+ETI_RTS stg_ap_8_upd_info;
+
+// standard application routines (see also rts/gen_apply.py,
+// and compiler/codeGen/CgStackery.lhs).
+
+extern DLL_IMPORT_RTS const StgPolyInfoTable stg_ap_0_info;
+ERI_(stg_ap_v_info);
+ERI_(stg_ap_f_info);
+ERI_(stg_ap_d_info);
+ERI_(stg_ap_l_info);
+ERI_(stg_ap_n_info);
+ERI_(stg_ap_p_info);
+ERI_(stg_ap_pv_info);
+ERI_(stg_ap_pp_info);
+ERI_(stg_ap_ppv_info);
+ERI_(stg_ap_ppp_info);
+ERI_(stg_ap_pppp_info);
+ERI_(stg_ap_ppppp_info);
+ERI_(stg_ap_pppppp_info);
+ERI_(stg_ap_ppppppp_info);
+
+EXTFUN(stg_ap_0_ret);
+EXTFUN(stg_ap_v_ret);
+EXTFUN(stg_ap_f_ret);
+EXTFUN(stg_ap_d_ret);
+EXTFUN(stg_ap_l_ret);
+EXTFUN(stg_ap_n_ret);
+EXTFUN(stg_ap_p_ret);
+EXTFUN(stg_ap_pv_ret);
+EXTFUN(stg_ap_pp_ret);
+EXTFUN(stg_ap_ppv_ret);
+EXTFUN(stg_ap_ppp_ret);
+EXTFUN(stg_ap_pppp_ret);
+EXTFUN(stg_ap_ppppp_ret);
+EXTFUN(stg_ap_pppppp_ret);
+EXTFUN(stg_ap_ppppppp_ret);
+
+/* standard GC & stack check entry points, all defined in HeapStackCheck.hc */
+
+ERI_(stg_enter_info);
+EF_(stg_enter_ret);
+
+ERI_(stg_gc_void_info);
+
+EF_(__stg_gc_enter_1);
+
EF_(stg_gc_noregs);
-EI_(stg_gc_unpt_r1_info);
+ERI_(stg_gc_unpt_r1_info);
EF_(stg_gc_unpt_r1);
-EI_(stg_ut_1_0_unreg_info);
-
-EI_(stg_gc_unbx_r1_info);
+ERI_(stg_gc_unbx_r1_info);
EF_(stg_gc_unbx_r1);
-EI_(stg_gc_f1_info);
+ERI_(stg_gc_f1_info);
EF_(stg_gc_f1);
-EI_(stg_gc_d1_info);
+ERI_(stg_gc_d1_info);
EF_(stg_gc_d1);
-EI_(stg_gc_ut_1_0_info);
-EI_(stg_gc_l1_info);
+ERI_(stg_gc_l1_info);
EF_(stg_gc_l1);
-EF_(stg_gc_ut_1_0);
-
-EI_(stg_gc_ut_0_1_info);
-EF_(stg_gc_ut_0_1);
-
-EXTFUN(__stg_chk_0);
-EXTFUN(__stg_chk_1);
-EXTFUN(stg_chk_1n);
-EXTFUN(stg_chk_2);
-EXTFUN(stg_chk_3);
-EXTFUN(stg_chk_4);
-EXTFUN(stg_chk_5);
-EXTFUN(stg_chk_6);
-EXTFUN(stg_chk_7);
-EXTFUN(stg_chk_8);
-EXTFUN(stg_gen_chk_ret);
-EXTFUN(stg_gen_chk);
-EXTFUN(stg_gen_hp);
-EXTFUN(stg_gen_yield);
-EXTFUN(stg_yield_noregs);
-EXTFUN(stg_yield_to_interpreter);
-EXTFUN(stg_gen_block);
-EXTFUN(stg_block_noregs);
-EXTFUN(stg_block_1);
-EXTFUN(stg_block_takemvar);
-EXTFUN(stg_block_putmvar);
+
+EF_(__stg_gc_fun);
+ERI_(stg_gc_fun_info);
+EF_(stg_gc_fun_ret);
+
+EF_(stg_gc_gen);
+ERI_(stg_gc_gen_info);
+
+EF_(stg_ut_1_0_unreg_ret);
+ERI_(stg_ut_1_0_unreg_info);
+
+EF_(stg_gc_gen_hp);
+EF_(stg_gc_ut);
+EF_(stg_gen_yield);
+EF_(stg_yield_noregs);
+EF_(stg_yield_to_interpreter);
+EF_(stg_gen_block);
+EF_(stg_block_noregs);
+EF_(stg_block_1);
+EF_(stg_block_takemvar);
+EF_(stg_block_putmvar);
/* ----------------------------------------------------------------------------
- * $Id: StgTicky.h,v 1.12 2002/04/09 11:00:11 njn Exp $
+ * $Id: StgTicky.h,v 1.13 2002/12/11 15:36:39 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
ALLOC_BH_gds += (g); ALLOC_BH_slp += (s); \
TICK_ALLOC_HISTO(BH,_HS,g,s)
-#define TICK_ALLOC_UPD_PAP(g,s) \
- ALLOC_UPD_PAP_ctr++; ALLOC_UPD_PAP_adm += sizeofW(StgPAP)-1; \
- ALLOC_UPD_PAP_gds += (g); ALLOC_UPD_PAP_slp += (s); \
- TICK_ALLOC_HISTO(UPD_PAP,sizeofW(StgPAP)-1,g,s)
+#define TICK_ALLOC_PAP(g,s) \
+ ALLOC_PAP_ctr++; ALLOC_PAP_adm += sizeofW(StgPAP)-1; \
+ ALLOC_PAP_gds += (g); ALLOC_PAP_slp += (s); \
+ TICK_ALLOC_HISTO(PAP,sizeofW(StgPAP)-1,g,s)
#define TICK_ALLOC_TSO(g,s) \
ALLOC_TSO_ctr++; ALLOC_TSO_adm += sizeofW(StgTSO); \
char *str; /* name of the thing */
char *arg_kinds; /* info about the args types */
I_ entry_count; /* Trips to fast entry code */
- I_ slow_entry_count; /* Trips to slow entry code */
I_ allocs; /* number of allocations by this fun */
struct _StgEntCounter *link;/* link to chain them all together */
} StgEntCounter;
static StgEntCounter f_ct \
= { 0, arity, args, \
str, arg_kinds, \
- 0, 0, 0, NULL };
-
-/* The slow entry point for a function always goes to
- the fast entry point, which will register the stats block,
- so no need to do so here */
-#define TICK_ENT_STATIC_FUN_STD(f_ct) \
- f_ct.slow_entry_count++; \
- ENT_STATIC_FUN_STD_ctr++ /* The static total one */
-
-#define TICK_ENT_DYN_FUN_STD(f_ct) \
- f_ct.slow_entry_count++; \
- ENT_DYN_FUN_STD_ctr++ /* The dynamic total one */
+ 0, 0, NULL };
#define TICK_ENT_FUN_DIRECT_BODY(f_ct) \
{ \
f_ct.registeredp = 1; \
} \
f_ct.entry_count += 1; \
- } \
+ }
#define TICK_ENT_STATIC_FUN_DIRECT(f_ct) \
TICK_ENT_FUN_DIRECT_BODY(f_ct) \
#define TICK_ENT_DYN_IND(n) ENT_DYN_IND_ctr++ /* enter dynamic indirection */
#define TICK_ENT_PERM_IND(n) ENT_PERM_IND_ctr++ /* enter permanent indirection */
#define TICK_ENT_PAP(n) ENT_PAP_ctr++ /* enter PAP */
-#define TICK_ENT_AP_UPD(n) ENT_AP_UPD_ctr++ /* enter AP_UPD */
+#define TICK_ENT_AP(n) ENT_AP_ctr++ /* enter AP_UPD */
+#define TICK_ENT_AP_STACK(n) ENT_AP_STACK_ctr++ /* enter AP_STACK_UPD */
#define TICK_ENT_BH() ENT_BH_ctr++ /* enter BLACKHOLE */
+#define TICK_SLOW_HISTO(n) \
+ { unsigned __idx; \
+ __idx = (n); \
+ SLOW_CALL_hst[((__idx > 8) ? 8 : __idx)] += 1; \
+ }
+
+// A slow call with n arguments
+#define TICK_SLOW_CALL(n) SLOW_CALL_ctr++; \
+ TICK_SLOW_HISTO(n)
+
+// A slow call to a FUN found insufficient arguments, and built a PAP
+#define TICK_SLOW_CALL_BUILT_PAP(n) SLOW_CALL_BUILT_PAP_ctr++
+
+// A slow call to a PAP found insufficient arguments, and build a new PAP
+#define TICK_SLOW_CALL_NEW_PAP(n) SLOW_CALL_NEW_PAP_ctr++
+
/* -----------------------------------------------------------------------------
Returns
-------------------------------------------------------------------------- */
-/* Whenever a ``return'' occurs, it is returning the constituent parts of
- * a data constructor. The parts can be returned either in registers, or
- * by allocating some heap to put it in (the TICK_ALLOC_* macros account for
- * the allocation). The constructor can either be an existing one
- * *OLD* or we could have {\em just} figured out this stuff
- * *NEW*.
- */
-
#define TICK_RET_HISTO(categ,n) \
{ I_ __idx; \
__idx = (n); \
#define TICK_RET_UNBOXED_TUP(n) RET_UNBOXED_TUP_ctr++; \
TICK_RET_HISTO(UNBOXED_TUP,n)
-#define TICK_RET_SEMI(n) RET_SEMI_IN_HEAP_ctr++; \
- TICK_RET_HISTO(SEMI_IN_HEAP,n)
-
-#define TICK_RET_SEMI_BY_DEFAULT()/*???*/ RET_SEMI_BY_DEFAULT_ctr++
-
-#define TICK_RET_SEMI_FAILED(tag) do { \
- if ((tag) == INFO_IND_TAG) \
- RET_SEMI_FAILED_IND_ctr++; \
- else \
- RET_SEMI_FAILED_UNEVAL_ctr++; \
- } while (0)
-
#define TICK_VEC_RETURN(n) VEC_RETURN_ctr++; \
TICK_RET_HISTO(VEC_RETURN,n)
Macro Counts
------------------ -------------------------------------------
TICK_UPDF_PUSHED Update frame pushed
- TICK_SEQF_PUSHED Seq frame pushed
TICK_CATCHF_PUSHED Catch frame pushed
TICK_UPDF_OMITTED A thunk decided not to push an update frame
TICK_UPDF_RCC_PUSHED Cost Centre restore frame pushed
#define TICK_UPDF_OMITTED() UPDF_OMITTED_ctr++
#define TICK_UPDF_PUSHED(tgt,inf) UPDF_PUSHED_ctr++ \
/* ; fprintf(stderr,"UPDF_PUSHED:%p:%p\n",tgt,inf) */
-#define TICK_SEQF_PUSHED() SEQF_PUSHED_ctr++
#define TICK_CATCHF_PUSHED() CATCHF_PUSHED_ctr++
#define TICK_UPDF_RCC_PUSHED() UPDF_RCC_PUSHED_ctr++
#define TICK_UPDF_RCC_OMITTED() UPDF_RCC_OMITTED_ctr++
#endif
;
-EXTERN unsigned long ALLOC_UPD_PAP_ctr INIT(0);
-EXTERN unsigned long ALLOC_UPD_PAP_adm INIT(0);
-EXTERN unsigned long ALLOC_UPD_PAP_gds INIT(0);
-EXTERN unsigned long ALLOC_UPD_PAP_slp INIT(0);
-EXTERN unsigned long ALLOC_UPD_PAP_hst[5]
+EXTERN unsigned long ALLOC_PAP_ctr INIT(0);
+EXTERN unsigned long ALLOC_PAP_adm INIT(0);
+EXTERN unsigned long ALLOC_PAP_gds INIT(0);
+EXTERN unsigned long ALLOC_PAP_slp INIT(0);
+EXTERN unsigned long ALLOC_PAP_hst[5]
#ifdef TICKY_C
= {0,0,0,0,0}
#endif
= {0,0,0,0,0}
#endif
;
-#endif
+#endif // PAR
EXTERN unsigned long ENT_VIA_NODE_ctr INIT(0);
EXTERN unsigned long ENT_STATIC_THK_ctr INIT(0);
EXTERN unsigned long ENT_DYN_THK_ctr INIT(0);
-EXTERN unsigned long ENT_STATIC_FUN_STD_ctr INIT(0);
-EXTERN unsigned long ENT_DYN_FUN_STD_ctr INIT(0);
EXTERN unsigned long ENT_STATIC_FUN_DIRECT_ctr INIT(0);
EXTERN unsigned long ENT_DYN_FUN_DIRECT_ctr INIT(0);
EXTERN unsigned long ENT_STATIC_CON_ctr INIT(0);
EXTERN unsigned long ENT_DYN_IND_ctr INIT(0);
EXTERN unsigned long ENT_PERM_IND_ctr INIT(0);
EXTERN unsigned long ENT_PAP_ctr INIT(0);
-EXTERN unsigned long ENT_AP_UPD_ctr INIT(0);
+EXTERN unsigned long ENT_AP_ctr INIT(0);
+EXTERN unsigned long ENT_AP_STACK_ctr INIT(0);
EXTERN unsigned long ENT_BH_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_BUILT_PAP_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_NEW_PAP_ctr INIT(0);
+
+EXTERN unsigned long SLOW_CALL_hst[8]
+#ifdef TICKY_C
+ = {0,0,0,0,0,0,0,0}
+#endif
+;
+
EXTERN unsigned long RET_NEW_ctr INIT(0);
EXTERN unsigned long RET_OLD_ctr INIT(0);
EXTERN unsigned long RET_UNBOXED_TUP_ctr INIT(0);
-EXTERN unsigned long RET_SEMI_BY_DEFAULT_ctr INIT(0);
-EXTERN unsigned long RET_SEMI_IN_HEAP_ctr INIT(0);
-EXTERN unsigned long RET_SEMI_FAILED_IND_ctr INIT(0);
-EXTERN unsigned long RET_SEMI_FAILED_UNEVAL_ctr INIT(0);
EXTERN unsigned long VEC_RETURN_ctr INIT(0);
EXTERN unsigned long UPDF_OMITTED_ctr INIT(0);
EXTERN unsigned long UPDF_PUSHED_ctr INIT(0);
-EXTERN unsigned long SEQF_PUSHED_ctr INIT(0);
EXTERN unsigned long CATCHF_PUSHED_ctr INIT(0);
EXTERN unsigned long UPDF_RCC_PUSHED_ctr INIT(0);
EXTERN unsigned long UPDF_RCC_OMITTED_ctr INIT(0);
#define TICK_ALLOC_CON(g,s)
#define TICK_ALLOC_TUP(g,s)
#define TICK_ALLOC_BH(g,s)
-#define TICK_ALLOC_UPD_PAP(g,s)
+#define TICK_ALLOC_PAP(g,s)
#define TICK_ALLOC_TSO(g,s)
#define TICK_ALLOC_FMBQ(a,g,s)
#define TICK_ALLOC_FME(a,g,s)
#define TICK_ENT_STATIC_THK()
#define TICK_ENT_DYN_THK()
-#define TICK_ENT_STATIC_FUN_STD(n)
-#define TICK_ENT_DYN_FUN_STD(n)
#define TICK_ENT_STATIC_FUN_DIRECT(n)
#define TICK_ENT_DYN_FUN_DIRECT(n)
-
#define TICK_ENT_STATIC_CON(n)
#define TICK_ENT_DYN_CON(n)
#define TICK_ENT_STATIC_IND(n)
#define TICK_ENT_DYN_IND(n)
#define TICK_ENT_PERM_IND(n)
#define TICK_ENT_PAP(n)
-#define TICK_ENT_AP_UPD(n)
+#define TICK_ENT_AP(n)
+#define TICK_ENT_AP_STACK(n)
#define TICK_ENT_BH()
+#define TICK_SLOW_CALL(n)
+#define TICK_SLOW_CALL_BUILT_PAP(n)
+#define TICK_SLOW_CALL_NEW_PAP(n)
+
#define TICK_RET_NEW(n)
#define TICK_RET_OLD(n)
#define TICK_RET_UNBOXED_TUP(n)
#define TICK_UPDF_OMITTED()
#define TICK_UPDF_PUSHED(tgt,inf)
-#define TICK_SEQF_PUSHED()
#define TICK_CATCHF_PUSHED()
#define TICK_UPDF_RCC_PUSHED()
#define TICK_UPDF_RCC_OMITTED()
/* -----------------------------------------------------------------------------
- * $Id: StgTypes.h,v 1.18 2001/10/03 13:57:42 simonmar Exp $
+ * $Id: StgTypes.h,v 1.19 2002/12/11 15:36:39 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#if SIZEOF_VOID_P == 8
typedef StgInt64 StgInt;
typedef StgWord64 StgWord;
+typedef StgWord32 StgHalfWord;
#else
#if SIZEOF_VOID_P == 4
typedef StgInt32 StgInt;
typedef StgWord32 StgWord;
+typedef StgWord16 StgHalfWord;
#else
#error GHC untested on this architecture: sizeof(void *) != 4 or 8
#endif
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.27 2002/06/26 08:18:41 stolz Exp $
+ * $Id: TSO.h,v 1.28 2002/12/11 15:36:40 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
* The what_next field of a TSO indicates how the thread is to be run.
*/
typedef enum {
- ThreadEnterGHC, /* enter top thunk on stack */
ThreadRunGHC, /* return to address on top of stack */
- ThreadEnterInterp, /* enter top thunk on stack (w/ interpreter) */
+ ThreadInterpret, /* interpret this thread */
ThreadKilled, /* thread has died, don't run it */
ThreadRelocated, /* thread has moved, link points to new locn */
ThreadComplete /* thread has finished */
StgWord stack_size; /* stack size in *words* */
StgWord max_stack_size; /* maximum stack size in *words* */
StgPtr sp;
- StgUpdateFrame* su;
StgWord stack[FLEXIBLE_ARRAY];
} StgTSO;
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.27 2001/12/10 18:07:09 sof Exp $
+ * $Id: Updates.h,v 1.28 2002/12/11 15:36:40 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
extern DLL_IMPORT_RTS const StgPolyInfoTable stg_upd_frame_info;
+extern DLL_IMPORT_RTS const StgPolyInfoTable stg_noupd_frame_info;
#define PUSH_UPD_FRAME(target, Sp_offset) \
{ \
TICK_UPDF_PUSHED(target, GET_INFO((StgClosure*)target)); \
__frame = (StgUpdateFrame *)(Sp + (Sp_offset)) - 1; \
SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); \
- __frame->link = Su; \
__frame->updatee = (StgClosure *)(target); \
PUSH_STD_CCCS(__frame); \
- Su = __frame; \
}
/* -----------------------------------------------------------------------------
Update-related prototypes
-------------------------------------------------------------------------- */
-EXTFUN_RTS(__stg_update_PAP);
-
-DLL_IMPORT_RTS extern STGFUN(stg_upd_frame_entry);
-
-extern DLL_IMPORT_RTS const StgInfoTable stg_PAP_info;
-DLL_IMPORT_RTS STGFUN(stg_PAP_entry);
-
-extern DLL_IMPORT_RTS const StgInfoTable stg_AP_UPD_info;
-DLL_IMPORT_RTS STGFUN(stg_AP_UPD_entry);
-
-extern DLL_IMPORT_RTS const StgInfoTable stg_raise_info;
-
#endif /* UPDATES_H */
/* --------------------------------------------------------------------------
- * $Id: mkDerivedConstants.c,v 1.3 2002/01/29 18:32:18 sof Exp $
+ * $Id: mkDerivedConstants.c,v 1.4 2002/12/11 15:36:40 simonmar Exp $
*
* (c) The GHC Team, 1992-1998
*
*
* ------------------------------------------------------------------------*/
-#include "Rts.h"
+#define IN_STG_CODE 0
+#include "Stg.h"
#define OFFSET(s_type, field) ((unsigned int)&(((s_type*)0)->field))
sizeofW(StgMutArrPtrs) - sizeofW(StgHeader));
printf("#define STD_ITBL_SIZE %d\n", sizeofW(StgInfoTable));
+ printf("#define RET_ITBL_SIZE %d\n", sizeofW(StgRetInfoTable) - sizeofW(StgInfoTable));
printf("#define PROF_ITBL_SIZE %d\n", sizeofW(StgProfInfo));
printf("#define GRAN_ITBL_SIZE %d\n", 0);
printf("#define TICKY_ITBL_SIZE %d\n", sizeofW(StgTickyInfo));
printf("#define UF_RET %d\n",
OFFSET(StgUpdateFrame,header.info));
- printf("#define UF_SU %d\n",
- OFFSET(StgUpdateFrame,link) / sizeof(W_));
-
printf("#define UF_UPDATEE %d\n",
OFFSET(StgUpdateFrame,updatee) / sizeof(W_));
- printf("#define STD_SEQ_FRAME_SIZE %d\n", sizeofW(StgSeqFrame));
- printf("#define GRAN_SEQ_FRAME_SIZE %d\n",
- sizeofW(StgSeqFrame) + sizeofW(StgGranHeader));
- printf("#define PROF_SEQ_FRAME_SIZE %d\n",
- sizeofW(StgSeqFrame) + sizeofW(StgProfHeader));
-
printf("#define BLOCK_SIZE %d\n", BLOCK_SIZE);
printf("#define MBLOCK_SIZE %d\n", MBLOCK_SIZE);
return 0;
/* --------------------------------------------------------------------------
- * $Id: mkNativeHdr.c,v 1.10 2002/07/21 11:46:34 panne Exp $
+ * $Id: mkNativeHdr.c,v 1.11 2002/12/11 15:36:40 simonmar Exp $
*
* (c) The GHC Team, 1992-1998
*
#define OFFSET_D2 OFFSET(RegTable, RegTable.rD2)
#define OFFSET_L1 OFFSET(RegTable, RegTable.rL1)
#define OFFSET_Sp OFFSET(RegTable, RegTable.rSp)
-#define OFFSET_Su OFFSET(RegTable, RegTable.rSu)
#define OFFSET_SpLim OFFSET(RegTable, RegTable.rSpLim)
#define OFFSET_Hp OFFSET(RegTable, RegTable.rHp)
#define OFFSET_HpLim OFFSET(RegTable, RegTable.rHpLim)
#define FUN_OFFSET(sym) ((StgPtr)&cap.f.sym - (StgPtr)&cap.r)
-#define OFFSET_stgChk0 FUN_OFFSET(stgChk0)
-#define OFFSET_stgChk1 FUN_OFFSET(stgChk1)
#define OFFSET_stgGCEnter1 FUN_OFFSET(stgGCEnter1)
-#define OFFSET_stgUpdatePAP FUN_OFFSET(stgUpdatePAP)
+#define OFFSET_stgGCFun FUN_OFFSET(stgGCFun)
#define OFFW_Capability_r OFFSET(cap, cap.r)
#define TSO_SP OFFSET(tso, tso.sp)
-#define TSO_SU OFFSET(tso, tso.su)
#define TSO_STACK OFFSET(tso, tso.stack)
#define BDESCR_START OFFSET(bd, bd.start)
printf("#define OFFSET_L1 %d\n", OFFSET_L1);
#endif
printf("#define OFFSET_Sp %d\n", OFFSET_Sp);
- printf("#define OFFSET_Su %d\n", OFFSET_Su);
printf("#define OFFSET_SpLim %d\n", OFFSET_SpLim);
printf("#define OFFSET_Hp %d\n", OFFSET_Hp);
printf("#define OFFSET_HpLim %d\n", OFFSET_HpLim);
printf("#define OFFSET_CurrentNursery %d\n", OFFSET_CurrentNursery);
printf("#define OFFSET_HpAlloc %d\n", OFFSET_HpAlloc);
- printf("#define OFFSET_stgChk0 (%d)\n", OFFSET_stgChk0);
- printf("#define OFFSET_stgChk1 (%d)\n", OFFSET_stgChk1);
printf("#define OFFSET_stgGCEnter1 (%d)\n", OFFSET_stgGCEnter1);
- printf("#define OFFSET_stgUpdatePAP (%d)\n", OFFSET_stgUpdatePAP);
+ printf("#define OFFSET_stgGCFun (%d)\n", OFFSET_stgGCFun);
printf("\n-- Offset of the .r (StgRegTable) field in a Capability\n");
printf("\n-- TSO offsets for the Native Code Generator\n");
printf("#define TSO_SP %d\n", TSO_SP);
- printf("#define TSO_SU %d\n", TSO_SU);
printf("#define TSO_STACK %d\n", TSO_STACK);
printf("\n-- Block descriptor offsets for the Native Code Generator\n");
# -----------------------------------------------------------------------------
-# $Id: paths.mk,v 1.42 2002/09/30 10:13:23 simonmar Exp $
+# $Id: paths.mk,v 1.43 2002/12/11 15:36:41 simonmar Exp $
#
# ghc project specific make variables
#
GHC_TOUCHY_DIR_REL = $(GHC_UTILS_DIR_REL)/touchy
GHC_PKG_DIR_REL = $(GHC_UTILS_DIR_REL)/ghc-pkg
GHC_GENPRIMOP_DIR_REL = $(GHC_UTILS_DIR_REL)/genprimopcode
+GHC_GENAPPLY_DIR_REL = $(GHC_UTILS_DIR_REL)/genapply
GHC_MANGLER_DIR_REL = $(GHC_DRIVER_DIR_REL)/mangler
GHC_SPLIT_DIR_REL = $(GHC_DRIVER_DIR_REL)/split
GHC_SYSMAN_DIR_REL = $(GHC_RUNTIME_DIR_REL)/parallel
GHC_DRIVER_DIR = $(GHC_TOP)/$(GHC_DRIVER_DIR_REL)
GHC_PKG_DIR = $(GHC_TOP)/$(GHC_PKG_DIR_REL)
GHC_GENPRIMOP_DIR = $(GHC_TOP)/$(GHC_GENPRIMOP_DIR_REL)
+GHC_GENAPPLY_DIR = $(GHC_TOP)/$(GHC_GENAPPLY_DIR_REL)
GHC_MANGLER_DIR = $(GHC_TOP)/$(GHC_MANGLER_DIR_REL)
GHC_SPLIT_DIR = $(GHC_TOP)/$(GHC_SPLIT_DIR_REL)
GHC_SYSMAN_PGM = SysMan
GHC_PKG_INPLACE_PGM = ghc-pkg-inplace
GHC_GENPRIMOP_PGM = genprimopcode
+GHC_GENAPPLY_PGM = genapply
# -----------------------------------------------------------------------------
# Auxilliary programs used by GHC
GHC_SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM)
GHC_PKG_INPLACE = $(GHC_PKG_DIR)/$(GHC_PKG_INPLACE_PGM)
GHC_GENPRIMOP = $(GHC_GENPRIMOP_DIR)/$(GHC_GENPRIMOP_PGM)
+GHC_GENAPPLY = $(GHC_GENAPPLY_DIR)/$(GHC_GENAPPLY_PGM)
--- /dev/null
+// -----------------------------------------------------------------------------
+// Apply.h
+//
+// (c) The University of Glasgow 2002
+//
+// Helper bits for the generic apply code (AutoApply.hc)
+// -----------------------------------------------------------------------------
+
+#ifndef APPLY_H
+#define APPLY_H
+
+// Build a new PAP: function is in R1,p
+// ret addr and m arguments taking up n words are on the stack.
+#define BUILD_PAP(m,n,f) \
+ { \
+ StgPAP *pap; \
+ nat size, i; \
+ TICK_SLOW_CALL_BUILT_PAP(); \
+ size = PAP_sizeW(n); \
+ HP_CHK_NP(size, Sp[0] = f;); \
+ TICK_ALLOC_PAP(n, 0); \
+ pap = (StgPAP *) (Hp + 1 - size); \
+ SET_HDR(pap, &stg_PAP_info, CCCS); \
+ pap->arity = arity - m; \
+ pap->fun = R1.cl; \
+ pap->n_args = n; \
+ for (i = 0; i < n; i++) { \
+ pap->payload[i] = (StgClosure *)Sp[1+i]; \
+ } \
+ R1.p = (P_)pap; \
+ Sp += 1 + n; \
+ JMP_(ENTRY_CODE(Sp[0])); \
+ }
+
+// Copy the old PAP, build a new one with the extra arg(s)
+// ret addr and m arguments taking up n words are on the stack.
+#define NEW_PAP(m,n,f) \
+ { \
+ StgPAP *pap, *new_pap; \
+ nat size, i; \
+ TICK_SLOW_CALL_NEW_PAP(); \
+ pap = (StgPAP *)R1.p; \
+ size = PAP_sizeW(pap->n_args + n); \
+ HP_CHK_NP(size, Sp[0] = f;); \
+ TICK_ALLOC_PAP(n, 0); \
+ new_pap = (StgPAP *) (Hp + 1 - size); \
+ SET_HDR(new_pap, &stg_PAP_info, CCCS); \
+ new_pap->arity = arity - m; \
+ new_pap->n_args = pap->n_args + n; \
+ new_pap->fun = pap->fun; \
+ for (i = 0; i < pap->n_args; i++) { \
+ new_pap->payload[i] = pap->payload[i]; \
+ } \
+ for (i = 0; i < n; i++) { \
+ new_pap->payload[pap->n_args+i] = (StgClosure *)Sp[1+i]; \
+ } \
+ R1.p = (P_)new_pap; \
+ Sp += n+1; \
+ JMP_(ENTRY_CODE(Sp[0])); \
+ }
+
+// canned slow entry points, indexed by arg type (ARG_P, ARG_PP, etc.)
+extern StgFun * stg_ap_stack_entries[];
+
+// canned register save code for heap check failure in a function
+extern StgFun * stg_stack_save_entries[];
+
+// canned bitmap for each arg type
+extern StgWord stg_arg_bitmaps[];
+
+#endif // APPLY_H
+
--- /dev/null
+// -----------------------------------------------------------------------------
+// Apply.hc
+//
+// (c) The University of Glasgow 2002
+//
+// Application-related bits.
+//
+// -----------------------------------------------------------------------------
+
+#include "Stg.h"
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "Storage.h"
+#include "RtsUtils.h"
+#include "Printer.h"
+#include "Sanity.h"
+#include "Apply.h"
+
+#include <stdio.h>
+
+// ----------------------------------------------------------------------------
+// Evaluate a closure and return it.
+//
+// stg_ap_0_info <--- Sp
+//
+// NOTE: this needs to be a polymorphic return point, because we can't
+// be sure that the thing being evaluated is not a function.
+
+// These names are just to keep VEC_POLY_INFO_TABLE() happy - all the
+// entry points in the polymorphic info table point to the same code.
+#define stg_ap_0_0_ret stg_ap_0_ret
+#define stg_ap_0_1_ret stg_ap_0_ret
+#define stg_ap_0_2_ret stg_ap_0_ret
+#define stg_ap_0_3_ret stg_ap_0_ret
+#define stg_ap_0_4_ret stg_ap_0_ret
+#define stg_ap_0_5_ret stg_ap_0_ret
+#define stg_ap_0_6_ret stg_ap_0_ret
+#define stg_ap_0_7_ret stg_ap_0_ret
+
+VEC_POLY_INFO_TABLE(stg_ap_0,
+ MK_SMALL_BITMAP(0/*framsize*/, 0/*bitmap*/),
+ 0,0,0,RET_SMALL,,EF_);
+F_
+stg_ap_0_ret(void)
+{
+ // fn is in R1, no args on the stack
+ StgInfoTable *info;
+ nat arity;
+ FB_;
+
+ IF_DEBUG(apply,fprintf(stderr, "stg_ap_0_ret... "); printClosure(R1.cl));
+ IF_DEBUG(sanity,checkStackChunk(Sp+1,CurrentTSO->stack + CurrentTSO->stack_size));
+
+ Sp++;
+ ENTER();
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for a PAP.
+
+ This entry code is *only* called by one of the stg_ap functions.
+ On entry: Sp points to the remaining arguments on the stack. If
+ the stack check fails, we can just push the PAP on the stack and
+ return to the scheduler.
+
+ On entry: R1 points to the PAP. The rest of the function's arguments
+ (*all* of 'em) are on the stack, starting at Sp[0].
+
+ The idea is to copy the chunk of stack from the PAP object onto the
+ stack / into registers, and enter the function.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_PAP_info,stg_PAP_entry,/*special layout*/0,0,PAP,,EF_,"PAP","PAP");
+STGFUN(stg_PAP_entry)
+{
+ nat Words;
+ StgPtr p;
+ nat i;
+ StgPAP *pap;
+ FB_
+
+ pap = (StgPAP *) R1.p;
+
+ Words = pap->n_args;
+
+ // Check for stack overflow and bump the stack pointer.
+ // We have a hand-rolled stack check fragment here, because none of
+ // the canned ones suit this situation.
+ if ((Sp - Words) < SpLim) {
+ // there is a return address on the stack in the event of a
+ // stack check failure. The various stg_apply functions arrange
+ // this before calling stg_PAP_entry.
+ JMP_(stg_gc_unpt_r1);
+ }
+ // Sp is already pointing one word below the arguments...
+ Sp -= Words-1;
+
+ // profiling
+ TICK_ENT_PAP(pap);
+ LDV_ENTER(pap);
+ // Enter PAP cost centre -- lexical scoping only
+ ENTER_CCS_PAP_CL(pap);
+
+ R1.cl = pap->fun;
+ p = (P_)(pap->payload);
+
+ // Reload the stack
+ for (i=0; i<Words; i++) {
+ Sp[i] = (W_) *p++;
+ }
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+#ifdef NO_ARG_REGS
+ JMP_(GET_ENTRY(R1.cl));
+#else
+ {
+ StgFunInfoTable *info;
+ info = get_fun_itbl(R1.cl);
+ if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
+ JMP_(info->slow_apply);
+ } else if (info->fun_type == ARG_BCO) {
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_apply_interp_info;
+ JMP_(stg_yield_to_interpreter);
+ } else {
+ JMP_(stg_ap_stack_entries[info->fun_type]);
+ }
+ }
+#endif
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for an AP (a PAP with arity zero).
+
+ The entry code is very similar to a PAP, except there are no
+ further arguments on the stack to worry about, so the stack check
+ is simpler. We must also push an update frame on the stack before
+ applying the function.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP_info,stg_AP_entry,/*special layout*/0,0,AP,,EF_,"AP","AP");
+STGFUN(stg_AP_entry)
+{
+ nat Words;
+ P_ p;
+ nat i;
+ StgAP *ap;
+
+ FB_
+
+ ap = (StgAP *) R1.p;
+
+ Words = ap->n_args;
+
+ // Check for stack overflow.
+ STK_CHK_GEN(Words+sizeofW(StgUpdateFrame), R1_PTR, stg_AP_entry);
+
+ PUSH_UPD_FRAME(R1.p, 0);
+ Sp -= sizeofW(StgUpdateFrame) + Words;
+
+ TICK_ENT_AP(ap);
+ LDV_ENTER(ap);
+
+ // Enter PAP cost centre -- lexical scoping only
+ ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_CL */
+
+ R1.cl = ap->fun;
+ p = (P_)(ap->payload);
+
+ // Reload the stack
+ for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+#ifdef NO_ARG_REGS
+ JMP_(GET_ENTRY(R1.cl));
+#else
+ {
+ StgFunInfoTable *info;
+ info = get_fun_itbl(R1.cl);
+ if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
+ JMP_(info->slow_apply);
+ } else if (info->fun_type == ARG_BCO) {
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_apply_interp_info;
+ JMP_(stg_yield_to_interpreter);
+ } else {
+ JMP_(stg_ap_stack_entries[info->fun_type]);
+ }
+ }
+#endif
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for an AP_STACK.
+
+ Very similar to a PAP and AP. The layout is the same as PAP
+ and AP, except that the payload is a chunk of stack instead of
+ being described by the function's info table. Like an AP,
+ there are no further arguments on the stack to worry about.
+ However, the function closure (ap->fun) does not necessarily point
+ directly to a function, so we have to enter it using stg_ap_0.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP_STACK_info,stg_AP_STACK_entry,/*special layout*/0,0,AP_STACK,,EF_,"AP_STACK","AP_STACK");
+STGFUN(stg_AP_STACK_entry)
+{
+ nat Words;
+ P_ p;
+ nat i;
+ StgAP_STACK *ap;
+
+ FB_
+
+ ap = (StgAP_STACK *) R1.p;
+
+ Words = ap->size;
+
+ // Check for stack overflow.
+ STK_CHK_GEN(Words+sizeofW(StgUpdateFrame), R1_PTR, stg_AP_STACK_entry);
+
+ PUSH_UPD_FRAME(R1.p, 0);
+ Sp -= sizeofW(StgUpdateFrame) + Words;
+
+ TICK_ENT_AP(ap);
+ LDV_ENTER(ap);
+
+ // Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_STACK_CL */
+
+ R1.cl = ap->fun;
+ p = (P_)(ap->payload);
+
+ // Reload the stack
+ for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+ ENTER();
+ FE_
+}
void
initCapability( Capability *cap )
{
- cap->f.stgChk0 = (F_)__stg_chk_0;
- cap->f.stgChk1 = (F_)__stg_chk_1;
cap->f.stgGCEnter1 = (F_)__stg_gc_enter_1;
- cap->f.stgUpdatePAP = (F_)__stg_update_PAP;
+ cap->f.stgGCFun = (F_)__stg_gc_fun;
}
#if defined(SMP)
/* -----------------------------------------------------------------------------
- * $Id: ClosureFlags.c,v 1.12 2002/04/19 12:23:11 simonmar Exp $
+ * $Id: ClosureFlags.c,v 1.13 2002/12/11 15:36:41 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
/* THUNK_STATIC = */ ( _BTM| _STA|_THU| _SRT ),
/* THUNK_SELECTOR = */ ( _BTM| _THU| _SRT ),
/* BCO = */ (_HNF| _NS ),
-/* AP_UPD = */ ( _BTM| _THU ),
+/* AP = */ ( _THU ),
/* PAP = */ (_HNF| _NS ),
+/* AP_STACK = */ ( _THU ),
/* IND = */ ( _NS| _IND ),
/* IND_OLDGEN = */ ( _NS| _IND ),
/* IND_PERM = */ ( _NS| _IND ),
/* RET_BIG = */ ( _SRT ),
/* RET_VEC_BIG = */ ( _SRT ),
/* RET_DYN = */ ( _SRT ),
+/* RET_FUN = */ ( 0 ),
/* UPDATE_FRAME = */ ( _BTM ),
/* CATCH_FRAME = */ ( _BTM ),
/* STOP_FRAME = */ ( _BTM ),
-/* SEQ_FRAME = */ ( _BTM ),
/* CAF_BLACKHOLE = */ ( _BTM|_NS| _UPT ),
/* BLACKHOLE = */ ( _NS| _UPT ),
/* BLACKHOLE_BQ = */ ( _NS| _MUT|_UPT ),
/* FETCH_ME_BQ = */ ( _NS| _MUT|_UPT ),
/* RBH = */ ( _NS| _MUT|_UPT ),
/* EVACUATED = */ ( 0 ),
-/* REMOTE_REF = */ (_HNF| _NS| _UPT )
+/* REMOTE_REF = */ (_HNF| _NS| _UPT ),
+/* STACK = */ (_HNF| _NS| _MUT )
};
-
/* -----------------------------------------------------------------------------
* Bytecode disassembler
*
- * Copyright (c) 1994-1998.
+ * Copyright (c) 1994-2002.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.25 $
- * $Date: 2002/07/17 09:21:49 $
+ * $Revision: 1.26 $
+ * $Date: 2002/12/11 15:36:41 $
* ---------------------------------------------------------------------------*/
#ifdef DEBUG
* Disassembler
* ------------------------------------------------------------------------*/
-int disInstr ( StgBCO *bco, int pc )
+int
+disInstr ( StgBCO *bco, int pc )
{
int i;
- StgArrWords* instr_arr = bco->instrs;
- UShort* instrs = (UShort*)(&instr_arr->payload[0]);
+ StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco));
StgArrWords* literal_arr = bco->literals;
StgWord* literals = (StgWord*)(&literal_arr->payload[0]);
case bci_STKCHECK:
fprintf(stderr, "STKCHECK %d\n", instrs[pc] );
pc += 1; break;
- case bci_ARGCHECK:
- fprintf(stderr, "ARGCHECK %d\n", instrs[pc] );
- pc += 1; break;
case bci_PUSH_L:
fprintf(stderr, "PUSH_L %d\n", instrs[pc] );
pc += 1; break;
fprintf(stderr, "PUSH_G " ); printPtr( ptrs[instrs[pc]] );
fprintf(stderr, "\n" );
pc += 1; break;
- case bci_PUSH_AS:
- fprintf(stderr, "PUSH_AS " ); printPtr( ptrs[instrs[pc]] );
- fprintf(stderr, " 0x%x", literals[instrs[pc+1]] );
+
+ case bci_PUSH_ALTS:
+ fprintf(stderr, "PUSH_ALTS " ); printPtr( ptrs[instrs[pc]] );
fprintf(stderr, "\n");
- pc += 2; break;
+ pc += 1; break;
+ case bci_PUSH_ALTS_P:
+ fprintf(stderr, "PUSH_ALTS_P " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+ case bci_PUSH_ALTS_N:
+ fprintf(stderr, "PUSH_ALTS_N " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+ case bci_PUSH_ALTS_F:
+ fprintf(stderr, "PUSH_ALTS_F " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+ case bci_PUSH_ALTS_D:
+ fprintf(stderr, "PUSH_ALTS_D " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+ case bci_PUSH_ALTS_L:
+ fprintf(stderr, "PUSH_ALTS_L " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+ case bci_PUSH_ALTS_V:
+ fprintf(stderr, "PUSH_ALTS_V " ); printPtr( ptrs[instrs[pc]] );
+ fprintf(stderr, "\n");
+ pc += 1; break;
+
case bci_PUSH_UBX:
fprintf(stderr, "PUSH_UBX ");
for (i = 0; i < instrs[pc+1]; i++)
fprintf(stderr, "0x%x ", literals[i + instrs[pc]] );
fprintf(stderr, "\n");
pc += 2; break;
- case bci_PUSH_TAG:
- fprintf(stderr, "PUSH_TAG %d\n", instrs[pc] );
- pc += 1; break;
+ case bci_PUSH_APPLY_N:
+ fprintf(stderr, "PUSH_APPLY_N\n");
+ break;
+ case bci_PUSH_APPLY_V:
+ fprintf(stderr, "PUSH_APPLY_V\n");
+ break;
+ case bci_PUSH_APPLY_F:
+ fprintf(stderr, "PUSH_APPLY_F\n");
+ break;
+ case bci_PUSH_APPLY_D:
+ fprintf(stderr, "PUSH_APPLY_D\n");
+ break;
+ case bci_PUSH_APPLY_L:
+ fprintf(stderr, "PUSH_APPLY_L\n");
+ break;
+ case bci_PUSH_APPLY_P:
+ fprintf(stderr, "PUSH_APPLY_P\n");
+ break;
+ case bci_PUSH_APPLY_PP:
+ fprintf(stderr, "PUSH_APPLY_PP\n");
+ break;
+ case bci_PUSH_APPLY_PPP:
+ fprintf(stderr, "PUSH_APPLY_PPP\n");
+ break;
+ case bci_PUSH_APPLY_PPPP:
+ fprintf(stderr, "PUSH_APPLY_PPPP\n");
+ break;
+ case bci_PUSH_APPLY_PPPPP:
+ fprintf(stderr, "PUSH_APPLY_PPPPP\n");
+ break;
+ case bci_PUSH_APPLY_PPPPPP:
+ fprintf(stderr, "PUSH_APPLY_PPPPPP\n");
+ break;
+ case bci_PUSH_APPLY_PPPPPPP:
+ fprintf(stderr, "PUSH_APPLY_PPPPPPP\n");
+ break;
case bci_SLIDE:
- fprintf(stderr, "SLIDE %d down by %d\n", instrs[pc], instrs[pc+1] );
+ fprintf(stderr, "SLIDE %d down by %d\n", instrs[pc], instrs[pc+1] );
pc += 2; break;
- case bci_ALLOC:
- fprintf(stderr, "ALLOC %d words\n", instrs[pc] );
+ case bci_ALLOC_AP:
+ fprintf(stderr, "ALLOC_AP %d words\n", instrs[pc] );
pc += 1; break;
+ case bci_ALLOC_PAP:
+ fprintf(stderr, "ALLOC_PAP %d words, %d arity\n",
+ instrs[pc], instrs[pc+1] );
+ pc += 2; break;
case bci_MKAP:
- fprintf(stderr, "MKAP %d words, %d stkoff\n", instrs[pc+1],
+ fprintf(stderr, "MKAP %d words, %d stkoff\n", instrs[pc+1],
instrs[pc] );
pc += 2; break;
case bci_UNPACK:
- fprintf(stderr, "UNPACK %d\n", instrs[pc] );
+ fprintf(stderr, "UNPACK %d\n", instrs[pc] );
pc += 1; break;
- case bci_UPK_TAG:
- fprintf(stderr, "UPK_TAG %d words, %d conoff, %d stkoff\n",
- instrs[pc], instrs[pc+1], instrs[pc+2] );
- pc += 3; break;
case bci_PACK:
- fprintf(stderr, "PACK %d words with itbl ", instrs[pc+1] );
+ fprintf(stderr, "PACK %d words with itbl ", instrs[pc+1] );
printPtr( (StgPtr)itbls[instrs[pc]] );
fprintf(stderr, "\n");
pc += 2; break;
- case bci_CASEFAIL:
- fprintf(stderr, "CASEFAIL\n" );
- break;
- case bci_JMP:
- fprintf(stderr, "JMP to %d\n", instrs[pc]);
- pc += 1; break;
-
case bci_TESTLT_I:
- fprintf(stderr, "TESTLT_I %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTLT_I %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_I:
- fprintf(stderr, "TESTEQ_I %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTEQ_I %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTLT_F:
- fprintf(stderr, "TESTLT_F %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTLT_F %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_F:
- fprintf(stderr, "TESTEQ_F %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTEQ_F %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTLT_D:
- fprintf(stderr, "TESTLT_D %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTLT_D %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_D:
- fprintf(stderr, "TESTEQ_D %d, fail to %d\n", literals[instrs[pc]],
+ fprintf(stderr, "TESTEQ_D %d, fail to %d\n", literals[instrs[pc]],
instrs[pc+1]);
pc += 2; break;
case bci_TESTLT_P:
- fprintf(stderr, "TESTLT_P %d, fail to %d\n", instrs[pc],
+ fprintf(stderr, "TESTLT_P %d, fail to %d\n", instrs[pc],
instrs[pc+1]);
pc += 2; break;
case bci_TESTEQ_P:
- fprintf(stderr, "TESTEQ_P %d, fail to %d\n", instrs[pc],
+ fprintf(stderr, "TESTEQ_P %d, fail to %d\n", instrs[pc],
instrs[pc+1]);
pc += 2; break;
- case bci_RETURN:
- fprintf(stderr, "RETURN " ); printPtr( (StgPtr)itbls[instrs[pc]] );
- fprintf(stderr, "\n");
+ case bci_CASEFAIL:
+ fprintf(stderr, "CASEFAIL\n" );
+ break;
+ case bci_JMP:
+ fprintf(stderr, "JMP to %d\n", instrs[pc]);
pc += 1; break;
+
case bci_ENTER:
fprintf(stderr, "ENTER\n");
break;
+
+ case bci_RETURN:
+ fprintf(stderr, "RETURN\n" );
+ break;
+ case bci_RETURN_P:
+ fprintf(stderr, "RETURN_P\n" );
+ break;
+ case bci_RETURN_N:
+ fprintf(stderr, "RETURN_N\n" );
+ break;
+ case bci_RETURN_F:
+ fprintf(stderr, "RETURN_F\n" );
+ break;
+ case bci_RETURN_D:
+ fprintf(stderr, "RETURN_D\n" );
+ break;
+ case bci_RETURN_L:
+ fprintf(stderr, "RETURN_L\n" );
+ break;
+ case bci_RETURN_V:
+ fprintf(stderr, "RETURN_V\n" );
+ break;
+
default:
barf("disInstr: unknown opcode");
}
void disassemble( StgBCO *bco )
{
nat i, j;
- StgArrWords* instr_arr = bco->instrs;
- UShort* instrs = (UShort*)(&instr_arr->payload[0]);
+ StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco));
StgMutArrPtrs* ptrs = bco->ptrs;
nat nbcs = (int)instrs[0];
nat pc = 1;
/* -----------------------------------------------------------------------------
- * $Id: Exception.h,v 1.4 2000/12/04 12:31:20 simonmar Exp $
+ * $Id: Exception.h,v 1.5 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
*
* ---------------------------------------------------------------------------*/
-extern const StgInfoTable stg_blockAsyncExceptionszh_ret_info;
-extern const StgInfoTable stg_unblockAsyncExceptionszh_ret_info;
+extern const StgRetInfoTable stg_blockAsyncExceptionszh_ret_info;
+extern const StgRetInfoTable stg_unblockAsyncExceptionszh_ret_info;
/* Determine whether a thread is interruptible (ie. blocked
* indefinitely). Interruptible threads can be sent an exception with
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.25 2002/04/23 06:34:26 sof Exp $
+ * $Id: Exception.hc,v 1.26 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
{
FB_
/* Args: R1 :: IO a */
- STK_CHK_GEN( 2/* worst case */, R1_PTR, blockAsyncExceptionszh_fast, );
+ STK_CHK_GEN( 2/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
if (CurrentTSO->blocked_exceptions == NULL) {
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
}
}
Sp--;
- Sp[0] = ARG_TAG(0);
- JMP_(GET_ENTRY(R1.cl));
+ JMP_(stg_ap_v_ret);
FE_
}
-INFO_TABLE_SRT_BITMAP(stg_unblockAsyncExceptionszh_ret_info, stg_unblockAsyncExceptionszh_ret_entry, 0, 0, 0, 0, RET_SMALL, , EF_, 0, 0);
+INFO_TABLE_RET( \
+ stg_unblockAsyncExceptionszh_ret_info, \
+ stg_unblockAsyncExceptionszh_ret_entry, \
+ MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), \
+ 0, 0, 0, RET_SMALL, , EF_, 0, 0 \
+);
+
FN_(stg_unblockAsyncExceptionszh_ret_entry)
{
FB_
{
FB_
/* Args: R1 :: IO a */
- STK_CHK_GEN(2, R1_PTR, unblockAsyncExceptionszh_fast, );
+ STK_CHK_GEN(2, R1_PTR, unblockAsyncExceptionszh_fast);
if (CurrentTSO->blocked_exceptions != NULL) {
#if defined(GRAN)
}
}
Sp--;
- Sp[0] = ARG_TAG(0);
- JMP_(GET_ENTRY(R1.cl));
+ JMP_(stg_ap_v_ret);
FE_
}
-INFO_TABLE_SRT_BITMAP(stg_blockAsyncExceptionszh_ret_info, stg_blockAsyncExceptionszh_ret_entry, 0, 0, 0, 0, RET_SMALL, , EF_, 0, 0);
+INFO_TABLE_RET( \
+ stg_blockAsyncExceptionszh_ret_info, \
+ stg_blockAsyncExceptionszh_ret_entry, \
+ MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), \
+ 0, 0, 0, RET_SMALL, , EF_, 0, 0 \
+);
+
FN_(stg_blockAsyncExceptionszh_ret_entry)
{
FB_
if (CurrentTSO->what_next == ThreadKilled) {
R1.w = ThreadFinished;
JMP_(StgReturn);
- }
- LoadThreadState();
- if (CurrentTSO->what_next == ThreadEnterGHC) {
- R1.w = Sp[0];
- Sp++;
- JMP_(GET_ENTRY(R1.cl));
} else {
- barf("killThreadzh_fast");
+ LoadThreadState();
+ ASSERT(CurrentTSO->what_next == ThreadRunGHC);
+ JMP_(ENTRY_CODE(Sp[0]));
}
} else {
STGCALL2(raiseAsyncWithLock, R1.t, R2.cl);
FN_(label) \
{ \
FB_ \
- Su = ((StgCatchFrame *)Sp)->link; \
Sp += sizeofW(StgCatchFrame); \
JMP_(ret); \
FE_ \
FB_ \
rval = Sp[0]; \
Sp++; \
- Su = ((StgCatchFrame *)Sp)->link; \
Sp += sizeofW(StgCatchFrame) - 1; \
Sp[0] = rval; \
JMP_(ret); \
#define SP_OFF 1
#endif
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_entry,ENTRY_CODE(Sp[SP_OFF]));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_entry,RET_VEC(Sp[SP_OFF],0));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_entry,RET_VEC(Sp[SP_OFF],1));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_entry,RET_VEC(Sp[SP_OFF],2));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_entry,RET_VEC(Sp[SP_OFF],3));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_entry,RET_VEC(Sp[SP_OFF],4));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_entry,RET_VEC(Sp[SP_OFF],5));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_entry,RET_VEC(Sp[SP_OFF],6));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_entry,RET_VEC(Sp[SP_OFF],7));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_ret,ENTRY_CODE(Sp[SP_OFF]));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,RET_VEC(Sp[SP_OFF],0));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,RET_VEC(Sp[SP_OFF],1));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,RET_VEC(Sp[SP_OFF],2));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,RET_VEC(Sp[SP_OFF],3));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,RET_VEC(Sp[SP_OFF],4));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,RET_VEC(Sp[SP_OFF],5));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,RET_VEC(Sp[SP_OFF],6));
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,RET_VEC(Sp[SP_OFF],7));
#if defined(PROFILING)
-#define CATCH_FRAME_BITMAP 15
+#define CATCH_FRAME_BITMAP 7
+#define CATCH_FRAME_WORDS 4
#else
-#define CATCH_FRAME_BITMAP 3
+#define CATCH_FRAME_BITMAP 1
+#define CATCH_FRAME_WORDS 2
#endif
/* Catch frames are very similar to update frames, but when entering
* kind of return to the activation record underneath us on the stack.
*/
-VEC_POLY_INFO_TABLE(stg_catch_frame, CATCH_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_);
+VEC_POLY_INFO_TABLE(stg_catch_frame, \
+ MK_SMALL_BITMAP(CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP), \
+ NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, CATCH_FRAME,, EF_);
/* -----------------------------------------------------------------------------
* The catch infotable
FB_
/* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
- STK_CHK_GEN(sizeofW(StgCatchFrame) + 1, R1_PTR | R2_PTR, catchzh_fast, );
+ STK_CHK_GEN(sizeofW(StgCatchFrame) + 1, R1_PTR | R2_PTR, catchzh_fast);
/* Set up the catch frame */
Sp -= sizeofW(StgCatchFrame);
SET_HDR(fp,(StgInfoTable *)&stg_catch_frame_info,CCCS);
fp -> handler = R2.cl;
fp -> exceptions_blocked = (CurrentTSO->blocked_exceptions != NULL);
- fp -> link = Su;
- Su = (StgUpdateFrame *)fp;
TICK_CATCHF_PUSHED();
- /* Push realworld token and enter R1. */
+
+/* Apply R1 to the realworld token */
Sp--;
- Sp[0] = ARG_TAG(0);
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
-
+ JMP_(stg_ap_v_ret);
FE_
}
FN_(raisezh_fast)
{
StgClosure *handler;
- StgUpdateFrame *p;
+ StgPtr p;
StgClosure *raise_closure;
FB_
/* args : R1 = exception */
}
#endif
- p = Su;
-
/* This closure represents the expression 'raise# E' where E
* is the exception raise. It is used to overwrite all the
* thunks which are currently under evaluataion.
SET_HDR(raise_closure, &stg_raise_info, CCCS);
raise_closure->payload[0] = R1.cl;
- while (1) {
-
- switch (get_itbl(p)->type) {
-
- case UPDATE_FRAME:
- UPD_IND(p->updatee,raise_closure);
- p = p->link;
- continue;
-
- case SEQ_FRAME:
- p = ((StgSeqFrame *)p)->link;
- continue;
-
- case CATCH_FRAME:
- /* found it! */
- break;
-
- case STOP_FRAME:
- /* We've stripped the entire stack, the thread is now dead. */
- Sp = CurrentTSO->stack + CurrentTSO->stack_size - 1;
- Sp[0] = R1.w; /* save the exception */
- Su = (StgUpdateFrame *)(Sp+1);
- CurrentTSO->what_next = ThreadKilled;
- SaveThreadState(); /* inline! */
- R1.w = ThreadFinished;
- JMP_(StgReturn);
-
- default:
- barf("raisezh_fast: weird activation record");
- }
+ // Walk up the stack, looking for the catch frame. On the way,
+ // we update any closures pointed to from update frames with the
+ // raise closure that we just built.
+ {
+ StgPtr next;
+ StgRetInfoTable *info;
+
+ p = Sp;
+ while(1) {
+
+ info = get_ret_itbl((StgClosure *)p);
+ next = p + stack_frame_sizeW((StgClosure *)p);
+ switch (info->i.type) {
+
+ case UPDATE_FRAME:
+ UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
+ p = next;
+ continue;
+
+ case CATCH_FRAME:
+ /* found it! */
+ break;
+
+ case STOP_FRAME:
+ /* We've stripped the entire stack, the thread is now dead. */
+ Sp = CurrentTSO->stack + CurrentTSO->stack_size - 1;
+ Sp[0] = R1.w; /* save the exception */
+ CurrentTSO->what_next = ThreadKilled;
+ SaveThreadState(); /* inline! */
+ R1.w = ThreadFinished;
+ JMP_(StgReturn);
+
+ default:
+ p = next;
+ continue;
+ }
- break;
-
+ break;
+ }
}
/* Ok, p points to the enclosing CATCH_FRAME. Pop everything down to
* and including this frame, update Su, push R1, and enter the handler.
*/
- Su = ((StgCatchFrame *)p)->link;
handler = ((StgCatchFrame *)p)->handler;
Sp = (P_)p + sizeofW(StgCatchFrame);
CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
}
- /* Enter the handler, passing the exception value and a realworld
+ /* Call the handler, passing the exception value and a realworld
* token as arguments.
*/
Sp -= 2;
+ Sp[1] = (W_)&stg_ap_v_info;
Sp[0] = R1.w;
- Sp[1] = ARG_TAG(0);
- TICK_ENT_VIA_NODE();
R1.cl = handler;
- JMP_(GET_ENTRY(R1.cl));
-
+ Sp--;
+ JMP_(stg_ap_p_ret);
FE_
}
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.145 2002/10/25 09:40:47 simonmar Exp $
+ * $Id: GC.c,v 1.146 2002/12/11 15:36:42 simonmar Exp $
*
- * (c) The GHC Team 1998-1999
+ * (c) The GHC Team 1998-2002
*
* Generational garbage collector
*
#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
+#include "Apply.h"
#include "Storage.h"
#include "StoragePriv.h"
#include "Stats.h"
Static function declarations
-------------------------------------------------------------------------- */
+static bdescr * gc_alloc_block ( step *stp );
static void mark_root ( StgClosure **root );
static StgClosure * evacuate ( StgClosure *q );
static void zero_static_object_list ( StgClosure* first_static );
static StgClosure * eval_thunk_selector ( nat field, StgSelector * p );
-static void scavenge ( step * );
-static void scavenge_mark_stack ( void );
-static void scavenge_stack ( StgPtr p, StgPtr stack_end );
-static rtsBool scavenge_one ( StgPtr p );
-static void scavenge_large ( step * );
-static void scavenge_static ( void );
-static void scavenge_mutable_list ( generation *g );
-static void scavenge_mut_once_list ( generation *g );
+
+static void scavenge ( step * );
+static void scavenge_mark_stack ( void );
+static void scavenge_stack ( StgPtr p, StgPtr stack_end );
+static rtsBool scavenge_one ( StgPtr p );
+static void scavenge_large ( step * );
+static void scavenge_static ( void );
+static void scavenge_mutable_list ( generation *g );
+static void scavenge_mut_once_list ( generation *g );
+
+static void scavenge_large_bitmap ( StgPtr p,
+ StgLargeBitmap *large_bitmap,
+ nat size );
#if 0 && defined(DEBUG)
static void gcCAFs ( void );
}
/* -----------------------------------------------------------------------------
+ Allocate a new to-space block in the given step.
+ -------------------------------------------------------------------------- */
+
+static bdescr *
+gc_alloc_block(step *stp)
+{
+ bdescr *bd = allocBlock();
+ bd->gen_no = stp->gen_no;
+ bd->step = stp;
+ bd->link = NULL;
+
+ // blocks in to-space in generations up to and including N
+ // get the BF_EVACUATED flag.
+ if (stp->gen_no <= N) {
+ bd->flags = BF_EVACUATED;
+ } else {
+ bd->flags = 0;
+ }
+
+ // Start a new to-space block, chain it on after the previous one.
+ if (stp->hp_bd == NULL) {
+ stp->hp_bd = bd;
+ } else {
+ stp->hp_bd->free = stp->hp;
+ stp->hp_bd->link = bd;
+ stp->hp_bd = bd;
+ }
+
+ stp->hp = bd->start;
+ stp->hpLim = stp->hp + BLOCK_SIZE_W;
+
+ stp->n_to_blocks++;
+ new_blocks++;
+
+ return bd;
+}
+
+/* -----------------------------------------------------------------------------
GarbageCollect
- For garbage collecting generation N (and all younger generations):
+ Rough outline of the algorithm: for garbage collecting generation N
+ (and all younger generations):
- follow all pointers in the root set. the root set includes all
- mutable objects in all steps in all generations.
+ mutable objects in all generations (mutable_list and mut_once_list).
- for each pointer, evacuate the object it points to into either
- + to-space in the next higher step in that generation, if one exists,
- + if the object's generation == N, then evacuate it to the next
- generation if one exists, or else to-space in the current
- generation.
- + if the object's generation < N, then evacuate it to to-space
- in the next generation.
+
+ + to-space of the step given by step->to, which is the next
+ highest step in this generation or the first step in the next
+ generation if this is the last step.
+
+ + to-space of generations[evac_gen]->steps[0], if evac_gen != 0.
+ When we evacuate an object we attempt to evacuate
+ everything it points to into the same generation - this is
+ achieved by setting evac_gen to the desired generation. If
+ we can't do this, then an entry in the mut_once list has to
+ be made for the cross-generation pointer.
+
+ + if the object is already in a generation > N, then leave
+ it alone.
- repeatedly scavenge to-space from each step in each generation
being collected until no more objects can be evacuated.
*/
new_blocks = 0;
- /* Initialise to-space in all the generations/steps that we're
- * collecting.
- */
+ // Initialise to-space in all the generations/steps that we're
+ // collecting.
+ //
for (g = 0; g <= N; g++) {
generations[g].mut_once_list = END_MUT_LIST;
generations[g].mut_list = END_MUT_LIST;
continue;
}
- /* Get a free block for to-space. Extra blocks will be chained on
- * as necessary.
- */
- bd = allocBlock();
stp = &generations[g].steps[s];
ASSERT(stp->gen_no == g);
- ASSERT(stp->hp ? Bdescr(stp->hp)->step == stp : rtsTrue);
- bd->gen_no = g;
- bd->step = stp;
- bd->link = NULL;
- bd->flags = BF_EVACUATED; // it's a to-space block
- stp->hp = bd->start;
- stp->hpLim = stp->hp + BLOCK_SIZE_W;
- stp->hp_bd = bd;
+
+ // start a new to-space for this step.
+ stp->hp = NULL;
+ stp->hp_bd = NULL;
+ stp->to_blocks = NULL;
+
+ // allocate the first to-space block; extra blocks will be
+ // chained on as necessary.
+ bd = gc_alloc_block(stp);
stp->to_blocks = bd;
- stp->n_to_blocks = 1;
stp->scan = bd->start;
stp->scan_bd = bd;
+
+ // initialise the large object queues.
stp->new_large_objects = NULL;
stp->scavenged_large_objects = NULL;
stp->n_scavenged_large_blocks = 0;
- new_blocks++;
+
// mark the large objects as not evacuated yet
for (bd = stp->large_objects; bd; bd = bd->link) {
bd->flags = BF_LARGE;
}
/* make sure the older generations have at least one block to
- * allocate into (this makes things easier for copy(), see below.
+ * allocate into (this makes things easier for copy(), see below).
*/
for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
for (s = 0; s < generations[g].n_steps; s++) {
stp = &generations[g].steps[s];
if (stp->hp_bd == NULL) {
ASSERT(stp->blocks == NULL);
- bd = allocBlock();
- bd->gen_no = g;
- bd->step = stp;
- bd->link = NULL;
- bd->flags = 0; // *not* a to-space block or a large object
- stp->hp = bd->start;
- stp->hpLim = stp->hp + BLOCK_SIZE_W;
- stp->hp_bd = bd;
+ bd = gc_alloc_block(stp);
stp->blocks = bd;
stp->n_blocks = 1;
- new_blocks++;
}
/* Set the scan pointer for older generations: remember we
* still have to scavenge objects that have been promoted. */
for (s = 0; s < generations[g].n_steps; s++) {
stp = &generations[g].steps[s];
if (!(g == 0 && s == 0 && RtsFlags.GcFlags.generations > 1)) {
+ ASSERT(Bdescr(stp->hp) == stp->hp_bd);
stp->hp_bd->free = stp->hp;
- stp->hp_bd->link = NULL;
}
}
}
// add the new blocks we promoted during this GC
stp->n_blocks += stp->n_to_blocks;
+ stp->n_to_blocks = 0;
stp->n_large_blocks += stp->n_scavenged_large_blocks;
}
}
while (1) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
- /* ToDo: for static closures, check the static link field.
- * Problem here is that we sometimes don't set the link field, eg.
- * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
- */
-
- loop:
- bd = Bdescr((P_)p);
+ // ignore static closures
+ //
+ // ToDo: for static closures, check the static link field.
+ // Problem here is that we sometimes don't set the link field, eg.
+ // for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
+ //
+ if (!HEAP_ALLOCED(p)) {
+ return p;
+ }
// ignore closures in generations that we're not collecting.
- if (LOOKS_LIKE_STATIC(p) || bd->gen_no > N) {
+ bd = Bdescr((P_)p);
+ if (bd->gen_no > N) {
return p;
}
case TSO:
if (((StgTSO *)p)->what_next == ThreadRelocated) {
p = (StgClosure *)((StgTSO *)p)->link;
- goto loop;
- }
+ continue;
+ }
+ return NULL;
default:
// dead.
*root = evacuate(*root);
}
-static void
-addBlock(step *stp)
-{
- bdescr *bd = allocBlock();
- bd->gen_no = stp->gen_no;
- bd->step = stp;
-
- if (stp->gen_no <= N) {
- bd->flags = BF_EVACUATED;
- } else {
- bd->flags = 0;
- }
-
- stp->hp_bd->free = stp->hp;
- stp->hp_bd->link = bd;
- stp->hp = bd->start;
- stp->hpLim = stp->hp + BLOCK_SIZE_W;
- stp->hp_bd = bd;
- stp->n_to_blocks++;
- new_blocks++;
-}
-
-
static __inline__ void
upd_evacuee(StgClosure *p, StgClosure *dest)
{
* necessary.
*/
if (stp->hp + size >= stp->hpLim) {
- addBlock(stp);
+ gc_alloc_block(stp);
}
for(to = stp->hp, from = (P_)src; size>0; --size) {
}
if (stp->hp + size_to_reserve >= stp->hpLim) {
- addBlock(stp);
+ gc_alloc_block(stp);
}
for(to = stp->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
the promotion until the next GC.
-------------------------------------------------------------------------- */
-
static StgClosure *
mkMutCons(StgClosure *ptr, generation *gen)
{
* necessary.
*/
if (stp->hp + sizeofW(StgIndOldGen) >= stp->hpLim) {
- addBlock(stp);
+ gc_alloc_block(stp);
}
q = (StgMutVar *)stp->hp;
#endif
// make sure the info pointer is into text space
- ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
- || IS_HUGS_CONSTR_INFO(GET_INFO(q))));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
info = get_itbl(q);
switch (info -> type) {
case MUT_VAR:
case MVAR:
- to = copy(q,sizeW_fromITBL(info),stp);
- return to;
+ return copy(q,sizeW_fromITBL(info),stp);
case CONSTR_0_1:
{
p = evacuate(p);
thunk_selector_depth--;
upd_evacuee(q,p);
+#ifdef PROFILING
+ // We store the size of the just evacuated object in the
+ // LDV word so that the profiler can guess the position of
+ // the next object later.
+ SET_EVACUAEE_FOR_LDV(q, THUNK_SELECTOR_sizeW());
+#endif
return p;
}
}
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
- case SEQ_FRAME:
// shouldn't see these
barf("evacuate: stack frame at %p\n", q);
- case AP_UPD:
case PAP:
- /* PAPs and AP_UPDs are special - the payload is a copy of a chunk
- * of stack, tagging and all.
- */
+ case AP:
return copy(q,pap_sizeW((StgPAP*)q),stp);
+ case AP_STACK:
+ return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
+
case EVACUATED:
/* Already evacuated, just return the forwarding address.
* HOWEVER: if the requested destination generation (evac_gen) is
}
}
- case AP_UPD:
+ case AP:
case THUNK:
case THUNK_1_0:
case THUNK_0_1:
-------------------------------------------------------------------------- */
void
-move_TSO(StgTSO *src, StgTSO *dest)
+move_TSO (StgTSO *src, StgTSO *dest)
{
ptrdiff_t diff;
// relocate the stack pointers...
diff = (StgPtr)dest - (StgPtr)src; // In *words*
dest->sp = (StgPtr)dest->sp + diff;
- dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
-
- relocate_stack(dest, diff);
-}
-
-/* -----------------------------------------------------------------------------
- relocate_stack is called to update the linkage between
- UPDATE_FRAMEs (and SEQ_FRAMEs etc.) when a stack is moved from one
- place to another.
- -------------------------------------------------------------------------- */
-
-StgTSO *
-relocate_stack(StgTSO *dest, ptrdiff_t diff)
-{
- StgUpdateFrame *su;
- StgCatchFrame *cf;
- StgSeqFrame *sf;
-
- su = dest->su;
-
- while ((P_)su < dest->stack + dest->stack_size) {
- switch (get_itbl(su)->type) {
-
- // GCC actually manages to common up these three cases!
-
- case UPDATE_FRAME:
- su->link = (StgUpdateFrame *) ((StgPtr)su->link + diff);
- su = su->link;
- continue;
-
- case CATCH_FRAME:
- cf = (StgCatchFrame *)su;
- cf->link = (StgUpdateFrame *) ((StgPtr)cf->link + diff);
- su = cf->link;
- continue;
-
- case SEQ_FRAME:
- sf = (StgSeqFrame *)su;
- sf->link = (StgUpdateFrame *) ((StgPtr)sf->link + diff);
- su = sf->link;
- continue;
-
- case STOP_FRAME:
- // all done!
- break;
-
- default:
- barf("relocate_stack %d", (int)(get_itbl(su)->type));
- }
- break;
- }
-
- return dest;
}
-
-
+/* evacuate the SRT. If srt_len is zero, then there isn't an
+ * srt field in the info table. That's ok, because we'll
+ * never dereference it.
+ */
static inline void
-scavenge_srt(const StgInfoTable *info)
+scavenge_srt (StgClosure **srt, nat srt_len)
{
- StgClosure **srt, **srt_end;
+ StgClosure **srt_end;
+
+ srt_end = srt + srt_len;
- /* evacuate the SRT. If srt_len is zero, then there isn't an
- * srt field in the info table. That's ok, because we'll
- * never dereference it.
- */
- srt = (StgClosure **)(info->srt);
- srt_end = srt + info->srt_len;
for (; srt < srt_end; srt++) {
/* Special-case to handle references to closures hiding out in DLLs, since
double indirections required to get at those. The code generator knows
}
}
+
+static inline void
+scavenge_thunk_srt(const StgInfoTable *info)
+{
+ StgThunkInfoTable *thunk_info;
+
+ thunk_info = itbl_to_thunk_itbl(info);
+ scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_len);
+}
+
+static inline void
+scavenge_fun_srt(const StgInfoTable *info)
+{
+ StgFunInfoTable *fun_info;
+
+ fun_info = itbl_to_fun_itbl(info);
+ scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_len);
+}
+
+static inline void
+scavenge_ret_srt(const StgInfoTable *info)
+{
+ StgRetInfoTable *ret_info;
+
+ ret_info = itbl_to_ret_itbl(info);
+ scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_len);
+}
+
/* -----------------------------------------------------------------------------
Scavenge a TSO.
-------------------------------------------------------------------------- */
static void
scavengeTSO (StgTSO *tso)
{
- // chase the link field for any TSOs on the same queue
- (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if ( tso->why_blocked == BlockedOnMVar
- || tso->why_blocked == BlockedOnBlackHole
- || tso->why_blocked == BlockedOnException
+ // chase the link field for any TSOs on the same queue
+ (StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole
+ || tso->why_blocked == BlockedOnException
#if defined(PAR)
- || tso->why_blocked == BlockedOnGA
- || tso->why_blocked == BlockedOnGA_NoSend
+ || tso->why_blocked == BlockedOnGA
+ || tso->why_blocked == BlockedOnGA_NoSend
#endif
- ) {
- tso->block_info.closure = evacuate(tso->block_info.closure);
- }
- if ( tso->blocked_exceptions != NULL ) {
- tso->blocked_exceptions =
- (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
- }
- // scavenge this thread's stack
- scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ ) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
+ }
+ if ( tso->blocked_exceptions != NULL ) {
+ tso->blocked_exceptions =
+ (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions);
+ }
+
+ // scavenge this thread's stack
+ scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
+}
+
+/* -----------------------------------------------------------------------------
+ Blocks of function args occur on the stack (at the top) and
+ in PAPs.
+ -------------------------------------------------------------------------- */
+
+static inline StgPtr
+scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
+{
+ StgPtr p;
+ StgWord bitmap;
+ nat size;
+
+ p = (StgPtr)args;
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ size = BITMAP_SIZE(fun_info->bitmap);
+ goto small_bitmap;
+ case ARG_GEN_BIG:
+ size = ((StgLargeBitmap *)fun_info->bitmap)->size;
+ scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ small_bitmap:
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ break;
+ }
+ return p;
+}
+
+static inline StgPtr
+scavenge_PAP (StgPAP *pap)
+{
+ StgPtr p;
+ StgWord bitmap, size;
+ StgFunInfoTable *fun_info;
+
+ pap->fun = evacuate(pap->fun);
+ fun_info = get_fun_itbl(pap->fun);
+ ASSERT(fun_info->i.type != PAP);
+
+ p = (StgPtr)pap->payload;
+ size = pap->n_args;
+
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ goto small_bitmap;
+ case ARG_GEN_BIG:
+ scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ p += size;
+ break;
+ case ARG_BCO:
+ scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ small_bitmap:
+ size = pap->n_args;
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ break;
+ }
+ return p;
}
/* -----------------------------------------------------------------------------
continue;
}
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
ASSERT(thunk_selector_depth == 0);
break;
}
- case THUNK_2_0:
case FUN_2_0:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
+ ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_2_0:
+ scavenge_thunk_srt(info);
case CONSTR_2_0:
((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
break;
case THUNK_1_0:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
break;
case FUN_1_0:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
case CONSTR_1_0:
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 1;
break;
case THUNK_0_1:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
break;
case FUN_0_1:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
case CONSTR_0_1:
p += sizeofW(StgHeader) + 1;
break;
case THUNK_0_2:
+ scavenge_thunk_srt(info);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
case FUN_0_2:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
case CONSTR_0_2:
p += sizeofW(StgHeader) + 2;
break;
case THUNK_1_1:
+ scavenge_thunk_srt(info);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
case FUN_1_1:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
case CONSTR_1_1:
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2;
break;
case FUN:
+ scavenge_fun_srt(info);
+ goto gen_obj;
+
case THUNK:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
// fall through
+ gen_obj:
case CONSTR:
case WEAK:
case FOREIGN:
break;
}
- case AP_UPD: // same as PAPs
- case PAP:
- /* Treat a PAP just like a section of stack, not forgetting to
- * evacuate the function pointer too...
- */
- {
- StgPAP* pap = (StgPAP *)p;
+ // A chunk of stack saved in a heap object
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
- pap->fun = evacuate(pap->fun);
- scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
- p += pap_sizeW(pap);
+ ap->fun = evacuate(ap->fun);
+ scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+ p = (StgPtr)ap->payload + ap->size;
break;
}
-
+
+ case PAP:
+ case AP:
+ p = scavenge_PAP((StgPAP *)p);
+ break;
+
case ARR_WORDS:
// nothing to follow
p += arr_words_sizeW((StgArrWords *)p);
while (!mark_stack_empty()) {
p = pop_mark_stack();
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info) || IS_HUGS_CONSTR_INFO(info)));
q = p;
switch (info->type) {
}
case FUN_2_0:
+ scavenge_fun_srt(info);
+ ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ break;
+
case THUNK_2_0:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
case CONSTR_2_0:
((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
case FUN_1_0:
case FUN_1_1:
+ scavenge_fun_srt(info);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ break;
+
case THUNK_1_0:
case THUNK_1_1:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
case CONSTR_1_0:
case CONSTR_1_1:
((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
case FUN_0_1:
case FUN_0_2:
+ scavenge_fun_srt(info);
+ break;
+
case THUNK_0_1:
case THUNK_0_2:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
+ break;
+
case CONSTR_0_1:
case CONSTR_0_2:
break;
case FUN:
+ scavenge_fun_srt(info);
+ goto gen_obj;
+
case THUNK:
- scavenge_srt(info);
+ scavenge_thunk_srt(info);
// fall through
+ gen_obj:
case CONSTR:
case WEAK:
case FOREIGN:
break;
}
- case AP_UPD: // same as PAPs
- case PAP:
- /* Treat a PAP just like a section of stack, not forgetting to
- * evacuate the function pointer too...
- */
- {
- StgPAP* pap = (StgPAP *)p;
+ // A chunk of stack saved in a heap object
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
- pap->fun = evacuate(pap->fun);
- scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+ ap->fun = evacuate(ap->fun);
+ scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
break;
}
+
+ case PAP:
+ case AP:
+ scavenge_PAP((StgPAP *)p);
+ break;
case MUT_ARR_PTRS:
// follow everything
nat saved_evac_gen = evac_gen;
rtsBool no_luck;
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p))
- || IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p))));
-
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
switch (info->type) {
case ARR_WORDS:
// nothing to follow
break;
-
+
case MUT_ARR_PTRS:
{
// follow everything
break;
}
- case AP_UPD:
- case PAP:
- {
- StgPAP* pap = (StgPAP *)p;
- pap->fun = evacuate(pap->fun);
- scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
+
+ ap->fun = evacuate(ap->fun);
+ scavenge_stack((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+ p = (StgPtr)ap->payload + ap->size;
break;
}
+ case PAP:
+ case AP:
+ p = scavenge_PAP((StgPAP *)p);
+ break;
+
case IND_OLDGEN:
// This might happen if for instance a MUT_CONS was pointing to a
// THUNK which has since been updated. The IND_OLDGEN will
for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
- // make sure the info pointer is into text space
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
- || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
/*
if (info->type==RBH)
for (; p != END_MUT_LIST; p = next, next = p->mut_link) {
- // make sure the info pointer is into text space
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
- || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
-
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
/*
if (info->type==RBH)
list... */
while (p != END_OF_STATIC_LIST) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl(p);
/*
if (info->type==RBH)
info = REVERT_INFOPTR(info); // if it's an RBH, look at the orig closure
*/
// make sure the info pointer is into text space
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
- || IS_HUGS_CONSTR_INFO(GET_INFO(p))));
/* Take this object *off* the static_objects list,
* and put it on the scavenged_static_objects list.
}
case THUNK_STATIC:
+ scavenge_thunk_srt(info);
+ break;
+
case FUN_STATIC:
- scavenge_srt(info);
+ scavenge_fun_srt(info);
break;
case CONSTR_STATIC:
}
/* -----------------------------------------------------------------------------
+ scavenge a chunk of memory described by a bitmap
+ -------------------------------------------------------------------------- */
+
+static void
+scavenge_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
+{
+ nat i, b;
+ StgWord bitmap;
+
+ b = 0;
+ bitmap = large_bitmap->bitmap[b];
+ for (i = 0; i < size; ) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ i++;
+ p++;
+ if (i % BITS_IN(W_) == 0) {
+ b++;
+ bitmap = large_bitmap->bitmap[b];
+ } else {
+ bitmap = bitmap >> 1;
+ }
+ }
+}
+
+static inline StgPtr
+scavenge_small_bitmap (StgPtr p, nat size, StgWord bitmap)
+{
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ return p;
+}
+
+/* -----------------------------------------------------------------------------
scavenge_stack walks over a section of stack and evacuates all the
objects pointed to by it. We can use the same code for walking
- PAPs, since these are just sections of copied stack.
+ AP_STACK_UPDs, since these are just sections of copied stack.
-------------------------------------------------------------------------- */
+
static void
scavenge_stack(StgPtr p, StgPtr stack_end)
{
- StgPtr q;
- const StgInfoTable* info;
+ const StgRetInfoTable* info;
StgWord bitmap;
+ nat size;
//IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
/*
* Each time around this loop, we are looking at a chunk of stack
- * that starts with either a pending argument section or an
- * activation record.
+ * that starts with an activation record.
*/
while (p < stack_end) {
- q = *(P_ *)p;
-
- // If we've got a tag, skip over that many words on the stack
- if (IS_ARG_TAG((W_)q)) {
- p += ARG_SIZE(q);
- p++; continue;
- }
-
- /* Is q a pointer to a closure?
- */
- if (! LOOKS_LIKE_GHC_INFO(q) ) {
-#ifdef DEBUG
- if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { // Is it a static closure?
- ASSERT(closure_STATIC((StgClosure *)q));
- }
- // otherwise, must be a pointer into the allocation space.
-#endif
-
- (StgClosure *)*p = evacuate((StgClosure *)q);
- p++;
- continue;
- }
-
- /*
- * Otherwise, q must be the info pointer of an activation
- * record. All activation records have 'bitmap' style layout
- * info.
- */
- info = get_itbl((StgClosure *)p);
+ info = get_ret_itbl((StgClosure *)p);
- switch (info->type) {
+ switch (info->i.type) {
- // Dynamic bitmap: the mask is stored on the stack
- case RET_DYN:
- bitmap = ((StgRetDyn *)p)->liveness;
- p = (P_)&((StgRetDyn *)p)->payload[0];
- goto small_bitmap;
-
- // probably a slow-entry point return address:
- case FUN:
- case FUN_STATIC:
- {
-#if 0
- StgPtr old_p = p;
- p++; p++;
- IF_DEBUG(sanity,
- belch("HWL: scavenge_stack: FUN(_STATIC) adjusting p from %p to %p (instead of %p)",
- old_p, p, old_p+1));
-#else
- p++; // what if FHS!=1 !? -- HWL
-#endif
- goto follow_srt;
- }
-
- /* Specialised code for update frames, since they're so common.
- * We *know* the updatee points to a BLACKHOLE, CAF_BLACKHOLE,
- * or BLACKHOLE_BQ, so just inline the code to evacuate it here.
- */
case UPDATE_FRAME:
- {
- StgUpdateFrame *frame = (StgUpdateFrame *)p;
-
+ ((StgUpdateFrame *)p)->updatee
+ = evacuate(((StgUpdateFrame *)p)->updatee);
p += sizeofW(StgUpdateFrame);
-
-#ifndef not_yet
- frame->updatee = evacuate(frame->updatee);
continue;
-#else // specialised code for update frames, not sure if it's worth it.
- StgClosure *to;
- nat type = get_itbl(frame->updatee)->type;
-
- if (type == EVACUATED) {
- frame->updatee = evacuate(frame->updatee);
- continue;
- } else {
- bdescr *bd = Bdescr((P_)frame->updatee);
- step *stp;
- if (bd->gen_no > N) {
- if (bd->gen_no < evac_gen) {
- failed_to_evac = rtsTrue;
- }
- continue;
- }
-
- // Don't promote blackholes
- stp = bd->step;
- if (!(stp->gen_no == 0 &&
- stp->no != 0 &&
- stp->no == stp->gen->n_steps-1)) {
- stp = stp->to;
- }
-
- switch (type) {
- case BLACKHOLE:
- case CAF_BLACKHOLE:
- to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
- sizeofW(StgHeader), stp);
- frame->updatee = to;
- continue;
- case BLACKHOLE_BQ:
- to = copy(frame->updatee, BLACKHOLE_sizeW(), stp);
- frame->updatee = to;
- recordMutable((StgMutClosure *)to);
- continue;
- default:
- /* will never be SE_{,CAF_}BLACKHOLE, since we
- don't push an update frame for single-entry thunks. KSW 1999-01. */
- barf("scavenge_stack: UPDATE_FRAME updatee");
- }
- }
-#endif
- }
// small bitmap (< 32 entries, or 64 on a 64-bit machine)
case STOP_FRAME:
case CATCH_FRAME:
- case SEQ_FRAME:
- case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
- bitmap = info->layout.bitmap;
- p++;
- // this assumes that the payload starts immediately after the info-ptr
- small_bitmap:
- while (bitmap != 0) {
- if ((bitmap & 1) == 0) {
- (StgClosure *)*p = evacuate((StgClosure *)*p);
- }
+ bitmap = BITMAP_BITS(info->i.layout.bitmap);
+ size = BITMAP_SIZE(info->i.layout.bitmap);
+ // NOTE: the payload starts immediately after the info-ptr, we
+ // don't have an StgHeader in the same sense as a heap closure.
p++;
- bitmap = bitmap >> 1;
- }
-
+ p = scavenge_small_bitmap(p, size, bitmap);
+
follow_srt:
- scavenge_srt(info);
- continue;
+ scavenge_srt((StgClosure **)info->srt, info->i.srt_len);
+ continue;
+
+ case RET_BCO: {
+ StgBCO *bco;
+ nat size;
+
+ p++;
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
+ bco = (StgBCO *)*p;
+ p++;
+ size = BCO_BITMAP_SIZE(bco);
+ scavenge_large_bitmap(p, BCO_BITMAP(bco), size);
+ p += size;
+ continue;
+ }
// large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
- {
- StgPtr q;
- StgLargeBitmap *large_bitmap;
- nat i;
+ {
+ nat size;
- large_bitmap = info->layout.large_bitmap;
+ size = info->i.layout.large_bitmap->size;
p++;
+ scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
+ p += size;
+ // and don't forget to follow the SRT
+ goto follow_srt;
+ }
- for (i=0; i<large_bitmap->size; i++) {
- bitmap = large_bitmap->bitmap[i];
- q = p + BITS_IN(W_);
- while (bitmap != 0) {
- if ((bitmap & 1) == 0) {
- (StgClosure *)*p = evacuate((StgClosure *)*p);
- }
+ // Dynamic bitmap: the mask is stored on the stack, and
+ // there are a number of non-pointers followed by a number
+ // of pointers above the bitmapped area. (see StgMacros.h,
+ // HEAP_CHK_GEN).
+ case RET_DYN:
+ {
+ StgWord dyn;
+ dyn = ((StgRetDyn *)p)->liveness;
+
+ // traverse the bitmap first
+ bitmap = GET_LIVENESS(dyn);
+ p = (P_)&((StgRetDyn *)p)->payload[0];
+ size = RET_DYN_SIZE;
+ p = scavenge_small_bitmap(p, size, bitmap);
+
+ // skip over the non-ptr words
+ p += GET_NONPTRS(dyn);
+
+ // follow the ptr words
+ for (size = GET_PTRS(dyn); size > 0; size--) {
+ (StgClosure *)*p = evacuate((StgClosure *)*p);
p++;
- bitmap = bitmap >> 1;
- }
- if (i+1 < large_bitmap->size) {
- while (p < q) {
- (StgClosure *)*p = evacuate((StgClosure *)*p);
- p++;
- }
- }
}
+ continue;
+ }
- // and don't forget to follow the SRT
+ case RET_FUN:
+ {
+ StgRetFun *ret_fun = (StgRetFun *)p;
+ StgFunInfoTable *fun_info;
+
+ ret_fun->fun = evacuate(ret_fun->fun);
+ fun_info = get_fun_itbl(ret_fun->fun);
+ p = scavenge_arg_block(fun_info, ret_fun->payload);
goto follow_srt;
- }
+ }
default:
- barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->type));
+ barf("scavenge_stack: weird activation record found on stack: %d", (int)(info->i.type));
}
- }
+ }
}
/*-----------------------------------------------------------------------------
static void
threadLazyBlackHole(StgTSO *tso)
{
- StgUpdateFrame *update_frame;
- StgBlockingQueue *bh;
- StgPtr stack_end;
-
- stack_end = &tso->stack[tso->stack_size];
- update_frame = tso->su;
-
- while (1) {
- switch (get_itbl(update_frame)->type) {
-
- case CATCH_FRAME:
- update_frame = ((StgCatchFrame *)update_frame)->link;
- break;
-
- case UPDATE_FRAME:
- bh = (StgBlockingQueue *)update_frame->updatee;
-
- /* if the thunk is already blackholed, it means we've also
- * already blackholed the rest of the thunks on this stack,
- * so we can stop early.
- *
- * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
- * don't interfere with this optimisation.
- */
- if (bh->header.info == &stg_BLACKHOLE_info) {
- return;
- }
+ StgClosure *frame;
+ StgRetInfoTable *info;
+ StgBlockingQueue *bh;
+ StgPtr stack_end;
+
+ stack_end = &tso->stack[tso->stack_size];
+
+ frame = (StgClosure *)tso->sp;
- if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
- bh->header.info != &stg_CAF_BLACKHOLE_info) {
+ while (1) {
+ info = get_ret_itbl(frame);
+
+ switch (info->i.type) {
+
+ case UPDATE_FRAME:
+ bh = (StgBlockingQueue *)((StgUpdateFrame *)frame)->updatee;
+
+ /* if the thunk is already blackholed, it means we've also
+ * already blackholed the rest of the thunks on this stack,
+ * so we can stop early.
+ *
+ * The blackhole made for a CAF is a CAF_BLACKHOLE, so they
+ * don't interfere with this optimisation.
+ */
+ if (bh->header.info == &stg_BLACKHOLE_info) {
+ return;
+ }
+
+ if (bh->header.info != &stg_BLACKHOLE_BQ_info &&
+ bh->header.info != &stg_CAF_BLACKHOLE_info) {
#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
- belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
+ belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
#endif
#ifdef PROFILING
- // @LDV profiling
- // We pretend that bh is now dead.
- LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
+ // @LDV profiling
+ // We pretend that bh is now dead.
+ LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
#endif
- SET_INFO(bh,&stg_BLACKHOLE_info);
+ SET_INFO(bh,&stg_BLACKHOLE_info);
#ifdef PROFILING
- // @LDV profiling
- // We pretend that bh has just been created.
- LDV_recordCreate(bh);
+ // @LDV profiling
+ // We pretend that bh has just been created.
+ LDV_recordCreate(bh);
#endif
- }
-
- update_frame = update_frame->link;
- break;
-
- case SEQ_FRAME:
- update_frame = ((StgSeqFrame *)update_frame)->link;
- break;
-
- case STOP_FRAME:
- return;
- default:
- barf("threadPaused");
+ }
+
+ frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
+ break;
+
+ case STOP_FRAME:
+ return;
+
+ // normal stack frames; do nothing except advance the pointer
+ default:
+ (StgPtr)frame += stack_frame_sizeW(frame);
+ }
}
- }
}
*
* -------------------------------------------------------------------------- */
+struct stack_gap { StgWord gap_size; struct stack_gap *next_gap; };
+
static void
threadSqueezeStack(StgTSO *tso)
{
- lnat displacement = 0;
- StgUpdateFrame *frame;
- StgUpdateFrame *next_frame; // Temporally next
- StgUpdateFrame *prev_frame; // Temporally previous
- StgPtr bottom;
- rtsBool prev_was_update_frame;
-#if DEBUG
- StgUpdateFrame *top_frame;
- nat upd_frames=0, stop_frames=0, catch_frames=0, seq_frames=0,
- bhs=0, squeezes=0;
- void printObj( StgClosure *obj ); // from Printer.c
+ StgPtr frame;
+ rtsBool prev_was_update_frame;
+ StgClosure *updatee = NULL;
+ StgPtr bottom;
+ StgRetInfoTable *info;
+ StgWord current_gap_size;
+ struct stack_gap *gap;
- top_frame = tso->su;
-#endif
-
- bottom = &(tso->stack[tso->stack_size]);
- frame = tso->su;
+ // Stage 1:
+ // Traverse the stack upwards, replacing adjacent update frames
+ // with a single update frame and a "stack gap". A stack gap
+ // contains two values: the size of the gap, and the distance
+ // to the next gap (or the stack top).
- /* There must be at least one frame, namely the STOP_FRAME.
- */
- ASSERT((P_)frame < bottom);
+ bottom = &(tso->stack[tso->stack_size]);
- /* Walk down the stack, reversing the links between frames so that
- * we can walk back up as we squeeze from the bottom. Note that
- * next_frame and prev_frame refer to next and previous as they were
- * added to the stack, rather than the way we see them in this
- * walk. (It makes the next loop less confusing.)
- *
- * Stop if we find an update frame pointing to a black hole
- * (see comment in threadLazyBlackHole()).
- */
-
- next_frame = NULL;
- // bottom - sizeof(StgStopFrame) is the STOP_FRAME
- while ((P_)frame < bottom - sizeofW(StgStopFrame)) {
- prev_frame = frame->link;
- frame->link = next_frame;
- next_frame = frame;
- frame = prev_frame;
-#if DEBUG
- IF_DEBUG(sanity,
- if (!(frame>=top_frame && frame<=(StgUpdateFrame *)bottom)) {
- printObj((StgClosure *)prev_frame);
- barf("threadSqueezeStack: current frame is rubbish %p; previous was %p\n",
- frame, prev_frame);
- })
- switch (get_itbl(frame)->type) {
- case UPDATE_FRAME:
- upd_frames++;
- if (frame->updatee->header.info == &stg_BLACKHOLE_info)
- bhs++;
- break;
- case STOP_FRAME:
- stop_frames++;
- break;
- case CATCH_FRAME:
- catch_frames++;
- break;
- case SEQ_FRAME:
- seq_frames++;
- break;
- default:
- barf("Found non-frame during stack squeezing at %p (prev frame was %p)\n",
- frame, prev_frame);
- printObj((StgClosure *)prev_frame);
- }
-#endif
- if (get_itbl(frame)->type == UPDATE_FRAME
- && frame->updatee->header.info == &stg_BLACKHOLE_info) {
- break;
- }
- }
+ frame = tso->sp;
- /* Now, we're at the bottom. Frame points to the lowest update
- * frame on the stack, and its link actually points to the frame
- * above. We have to walk back up the stack, squeezing out empty
- * update frames and turning the pointers back around on the way
- * back up.
- *
- * The bottom-most frame (the STOP_FRAME) has not been altered, and
- * we never want to eliminate it anyway. Just walk one step up
- * before starting to squeeze. When you get to the topmost frame,
- * remember that there are still some words above it that might have
- * to be moved.
- */
-
- prev_frame = frame;
- frame = next_frame;
+ ASSERT(frame < bottom);
+
+ prev_was_update_frame = rtsFalse;
+ current_gap_size = 0;
+ gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame));
- prev_was_update_frame = (get_itbl(prev_frame)->type == UPDATE_FRAME);
+ while (frame < bottom) {
+
+ info = get_ret_itbl((StgClosure *)frame);
+ switch (info->i.type) {
- /*
- * Loop through all of the frames (everything except the very
- * bottom). Things are complicated by the fact that we have
- * CATCH_FRAMEs and SEQ_FRAMEs interspersed with the update frames.
- * We can only squeeze when there are two consecutive UPDATE_FRAMEs.
- */
- while (frame != NULL) {
- StgPtr sp;
- StgPtr frame_bottom = (P_)frame + sizeofW(StgUpdateFrame);
- rtsBool is_update_frame;
-
- next_frame = frame->link;
- is_update_frame = (get_itbl(frame)->type == UPDATE_FRAME);
+ case UPDATE_FRAME:
+ {
+ StgUpdateFrame *upd = (StgUpdateFrame *)frame;
- /* Check to see if
- * 1. both the previous and current frame are update frames
- * 2. the current frame is empty
- */
- if (prev_was_update_frame && is_update_frame &&
- (P_)prev_frame == frame_bottom + displacement) {
-
- // Now squeeze out the current frame
- StgClosure *updatee_keep = prev_frame->updatee;
- StgClosure *updatee_bypass = frame->updatee;
-
-#if DEBUG
- IF_DEBUG(gc, belch("@@ squeezing frame at %p", frame));
- squeezes++;
-#endif
+ if (upd->updatee->header.info == &stg_BLACKHOLE_info) {
- /* Deal with blocking queues. If both updatees have blocked
- * threads, then we should merge the queues into the update
- * frame that we're keeping.
- *
- * Alternatively, we could just wake them up: they'll just go
- * straight to sleep on the proper blackhole! This is less code
- * and probably less bug prone, although it's probably much
- * slower --SDM
- */
-#if 0 // do it properly...
-# if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
-# error Unimplemented lazy BH warning. (KSW 1999-01)
-# endif
- if (GET_INFO(updatee_bypass) == stg_BLACKHOLE_BQ_info
- || GET_INFO(updatee_bypass) == stg_CAF_BLACKHOLE_info
- ) {
- // Sigh. It has one. Don't lose those threads!
- if (GET_INFO(updatee_keep) == stg_BLACKHOLE_BQ_info) {
- // Urgh. Two queues. Merge them.
- P_ keep_tso = ((StgBlockingQueue *)updatee_keep)->blocking_queue;
-
- while (keep_tso->link != END_TSO_QUEUE) {
- keep_tso = keep_tso->link;
- }
- keep_tso->link = ((StgBlockingQueue *)updatee_bypass)->blocking_queue;
+ // found a BLACKHOLE'd update frame; we've been here
+ // before, in a previous GC, so just break out.
- } else {
- // For simplicity, just swap the BQ for the BH
- P_ temp = updatee_keep;
-
- updatee_keep = updatee_bypass;
- updatee_bypass = temp;
-
- // Record the swap in the kept frame (below)
- prev_frame->updatee = updatee_keep;
- }
- }
-#endif
+ // Mark the end of the gap, if we're in one.
+ if (current_gap_size != 0) {
+ gap = (struct stack_gap *)(frame-sizeofW(StgUpdateFrame));
+ }
+
+ frame += sizeofW(StgUpdateFrame);
+ goto done_traversing;
+ }
- TICK_UPD_SQUEEZED();
- /* wasn't there something about update squeezing and ticky to be
- * sorted out? oh yes: we aren't counting each enter properly
- * in this case. See the log somewhere. KSW 1999-04-21
- *
- * Check two things: that the two update frames don't point to
- * the same object, and that the updatee_bypass isn't already an
- * indirection. Both of these cases only happen when we're in a
- * block hole-style loop (and there are multiple update frames
- * on the stack pointing to the same closure), but they can both
- * screw us up if we don't check.
- */
- if (updatee_bypass != updatee_keep && !closure_IND(updatee_bypass)) {
- // this wakes the threads up
- UPD_IND_NOLOCK(updatee_bypass, updatee_keep);
- }
-
- sp = (P_)frame - 1; // sp = stuff to slide
- displacement += sizeofW(StgUpdateFrame);
-
- } else {
- // No squeeze for this frame
- sp = frame_bottom - 1; // Keep the current frame
-
- /* Do lazy black-holing.
- */
- if (is_update_frame) {
- StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
- if (bh->header.info != &stg_BLACKHOLE_info &&
- bh->header.info != &stg_BLACKHOLE_BQ_info &&
- bh->header.info != &stg_CAF_BLACKHOLE_info) {
+ if (prev_was_update_frame) {
+
+ TICK_UPD_SQUEEZED();
+ /* wasn't there something about update squeezing and ticky to be
+ * sorted out? oh yes: we aren't counting each enter properly
+ * in this case. See the log somewhere. KSW 1999-04-21
+ *
+ * Check two things: that the two update frames don't point to
+ * the same object, and that the updatee_bypass isn't already an
+ * indirection. Both of these cases only happen when we're in a
+ * block hole-style loop (and there are multiple update frames
+ * on the stack pointing to the same closure), but they can both
+ * screw us up if we don't check.
+ */
+ if (upd->updatee != updatee && !closure_IND(upd->updatee)) {
+ // this wakes the threads up
+ UPD_IND_NOLOCK(upd->updatee, updatee);
+ }
+
+ // now mark this update frame as a stack gap. The gap
+ // marker resides in the bottom-most update frame of
+ // the series of adjacent frames, and covers all the
+ // frames in this series.
+ current_gap_size += sizeofW(StgUpdateFrame);
+ ((struct stack_gap *)frame)->gap_size = current_gap_size;
+ ((struct stack_gap *)frame)->next_gap = gap;
+
+ frame += sizeofW(StgUpdateFrame);
+ continue;
+ }
+
+ // single update frame, or the topmost update frame in a series
+ else {
+ StgBlockingQueue *bh = (StgBlockingQueue *)upd->updatee;
+
+ // Do lazy black-holing
+ if (bh->header.info != &stg_BLACKHOLE_info &&
+ bh->header.info != &stg_BLACKHOLE_BQ_info &&
+ bh->header.info != &stg_CAF_BLACKHOLE_info) {
#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
- belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
+ belch("Unexpected lazy BHing required at 0x%04x",(int)bh);
#endif
#ifdef DEBUG
- /* zero out the slop so that the sanity checker can tell
- * where the next closure is.
- */
- {
- StgInfoTable *info = get_itbl(bh);
- nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
- /* don't zero out slop for a THUNK_SELECTOR, because its layout
- * info is used for a different purpose, and it's exactly the
- * same size as a BLACKHOLE in any case.
- */
- if (info->type != THUNK_SELECTOR) {
- for (i = np; i < np + nw; i++) {
- ((StgClosure *)bh)->payload[i] = 0;
- }
- }
- }
+ /* zero out the slop so that the sanity checker can tell
+ * where the next closure is.
+ */
+ {
+ StgInfoTable *bh_info = get_itbl(bh);
+ nat np = bh_info->layout.payload.ptrs,
+ nw = bh_info->layout.payload.nptrs, i;
+ /* don't zero out slop for a THUNK_SELECTOR,
+ * because its layout info is used for a
+ * different purpose, and it's exactly the
+ * same size as a BLACKHOLE in any case.
+ */
+ if (bh_info->type != THUNK_SELECTOR) {
+ for (i = np; i < np + nw; i++) {
+ ((StgClosure *)bh)->payload[i] = 0;
+ }
+ }
+ }
#endif
#ifdef PROFILING
- // @LDV profiling
- // We pretend that bh is now dead.
- LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
+ // We pretend that bh is now dead.
+ LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
#endif
- //
- // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
- //
- SET_INFO(bh,&stg_BLACKHOLE_info);
+ // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+ SET_INFO(bh,&stg_BLACKHOLE_info);
#ifdef PROFILING
- // @LDV profiling
- // We pretend that bh has just been created.
- LDV_recordCreate(bh);
+ // We pretend that bh has just been created.
+ LDV_recordCreate(bh);
#endif
+ }
+
+ prev_was_update_frame = rtsTrue;
+ updatee = upd->updatee;
+ frame += sizeofW(StgUpdateFrame);
+ continue;
+ }
}
- }
+
+ default:
+ prev_was_update_frame = rtsFalse;
- // Fix the link in the current frame (should point to the frame below)
- frame->link = prev_frame;
- prev_was_update_frame = is_update_frame;
- }
-
- // Now slide all words from sp up to the next frame
-
- if (displacement > 0) {
- P_ next_frame_bottom;
+ // we're not in a gap... check whether this is the end of a gap
+ // (an update frame can't be the end of a gap).
+ if (current_gap_size != 0) {
+ gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame));
+ }
+ current_gap_size = 0;
- if (next_frame != NULL)
- next_frame_bottom = (P_)next_frame + sizeofW(StgUpdateFrame);
- else
- next_frame_bottom = tso->sp - 1;
-
-#if 0
- IF_DEBUG(gc,
- belch("sliding [%p, %p] by %ld", sp, next_frame_bottom,
- displacement))
-#endif
-
- while (sp >= next_frame_bottom) {
- sp[displacement] = *sp;
- sp -= 1;
- }
+ frame += stack_frame_sizeW((StgClosure *)frame);
+ continue;
+ }
}
- (P_)prev_frame = (P_)frame + displacement;
- frame = next_frame;
- }
- tso->sp += displacement;
- tso->su = prev_frame;
-#if 0
- IF_DEBUG(gc,
- belch("@@ threadSqueezeStack: squeezed %d update-frames; found %d BHs; found %d update-, %d stop-, %d catch, %d seq-frames",
- squeezes, bhs, upd_frames, stop_frames, catch_frames, seq_frames))
-#endif
-}
+done_traversing:
+
+ // Now we have a stack with gaps in it, and we have to walk down
+ // shoving the stack up to fill in the gaps. A diagram might
+ // help:
+ //
+ // +| ********* |
+ // | ********* | <- sp
+ // | |
+ // | | <- gap_start
+ // | ......... | |
+ // | stack_gap | <- gap | chunk_size
+ // | ......... | |
+ // | ......... | <- gap_end v
+ // | ********* |
+ // | ********* |
+ // | ********* |
+ // -| ********* |
+ //
+ // 'sp' points the the current top-of-stack
+ // 'gap' points to the stack_gap structure inside the gap
+ // ***** indicates real stack data
+ // ..... indicates gap
+ // <empty> indicates unused
+ //
+ {
+ void *sp;
+ void *gap_start, *next_gap_start, *gap_end;
+ nat chunk_size;
+
+ next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
+ sp = next_gap_start;
+
+ while ((StgPtr)gap > tso->sp) {
+ // we're working in *bytes* now...
+ gap_start = next_gap_start;
+ gap_end = gap_start - gap->gap_size * sizeof(W_);
+
+ gap = gap->next_gap;
+ next_gap_start = (void *)gap + sizeof(StgUpdateFrame);
+
+ chunk_size = gap_end - next_gap_start;
+ sp -= chunk_size;
+ memmove(sp, next_gap_start, chunk_size);
+ }
+
+ tso->sp = (StgPtr)sp;
+ }
+}
/* -----------------------------------------------------------------------------
* Pausing a thread
/* -----------------------------------------------------------------------------
- * $Id: GCCompact.c,v 1.12 2002/03/12 11:51:06 simonmar Exp $
+ * $Id: GCCompact.c,v 1.13 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team 2001
*
#include "GCCompact.h"
#include "Schedule.h"
#include "StablePriv.h"
+#include "Apply.h"
/* -----------------------------------------------------------------------------
Threading / unthreading pointers.
the chain with the new location of the object. We stop when we
reach the info pointer at the end.
- We use a trick to identify the info pointer, because the
- LOOKS_LIKE_GHC_INFO() macro involves a function call and can be
- expensive. The trick is that when swapping pointers for threading,
- we set the low bit of the original pointer, with the result that
- all the pointers in the chain have their low bits set except for
- the info pointer.
+ We use a trick to identify the info pointer: when swapping pointers
+ for threading, we set the low bit of the original pointer, with the
+ result that all the pointers in the chain have their low bits set
+ except for the info pointer.
-------------------------------------------------------------------------- */
static inline void
StgPtr q = (StgPtr)*p;
bdescr *bd;
- ASSERT(!LOOKS_LIKE_GHC_INFO(q));
+ // It doesn't look like a closure at the moment, because the info
+ // ptr is possibly threaded:
+ // ASSERT(LOOKS_LIKE_CLOSURE_PTR(q));
+
if (HEAP_ALLOCED(q)) {
bd = Bdescr(q);
// a handy way to discover whether the ptr is into the
while (((StgWord)q & 1) != 0) {
q = (P_)*((StgPtr)((StgWord)q-1));
}
+
+ ASSERT(LOOKS_LIKE_INFO_PTR(q));
return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
}
return sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
case THUNK_SELECTOR:
return THUNK_SELECTOR_sizeW();
- case AP_UPD:
+ case AP_STACK:
+ return ap_stack_sizeW((StgAP_STACK *)p);
+ case AP:
case PAP:
return pap_sizeW((StgPAP *)p);
case ARR_WORDS:
}
}
+static inline void
+thread_large_bitmap( StgPtr p, StgLargeBitmap *large_bitmap, nat size )
+{
+ nat i, b;
+ StgWord bitmap;
+
+ b = 0;
+ bitmap = large_bitmap->bitmap[b];
+ for (i = 0; i < size; ) {
+ if ((bitmap & 1) == 0) {
+ thread(p);
+ }
+ i++;
+ p++;
+ if (i % BITS_IN(W_) == 0) {
+ b++;
+ bitmap = large_bitmap->bitmap[b];
+ } else {
+ bitmap = bitmap >> 1;
+ }
+ }
+}
+
+static inline StgPtr
+thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
+{
+ StgPtr p;
+ StgWord bitmap;
+ nat size;
+
+ p = (StgPtr)args;
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ size = BITMAP_SIZE(fun_info->bitmap);
+ goto small_bitmap;
+ case ARG_GEN_BIG:
+ size = ((StgLargeBitmap *)fun_info->bitmap)->size;
+ thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ small_bitmap:
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ thread(p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ break;
+ }
+ return p;
+}
+
static void
thread_stack(StgPtr p, StgPtr stack_end)
{
- StgPtr q;
- const StgInfoTable* info;
+ const StgRetInfoTable* info;
StgWord bitmap;
+ nat size;
// highly similar to scavenge_stack, but we do pointer threading here.
while (p < stack_end) {
- q = (StgPtr)*p;
- // If we've got a tag, skip over that many words on the stack
- if ( IS_ARG_TAG((W_)q) ) {
- p += ARG_SIZE(q);
- p++; continue;
- }
-
- // Is q a pointer to a closure?
- if ( !LOOKS_LIKE_GHC_INFO(q) ) {
- thread(p);
- p++;
- continue;
- }
-
- // Otherwise, q must be the info pointer of an activation
+ // *p must be the info pointer of an activation
// record. All activation records have 'bitmap' style layout
// info.
//
- info = get_itbl((StgClosure *)p);
+ info = get_ret_itbl((StgClosure *)p);
- switch (info->type) {
+ switch (info->i.type) {
// Dynamic bitmap: the mask is stored on the stack
case RET_DYN:
- bitmap = ((StgRetDyn *)p)->liveness;
+ {
+ StgWord dyn;
+ dyn = ((StgRetDyn *)p)->liveness;
+
+ // traverse the bitmap first
+ bitmap = GET_LIVENESS(dyn);
p = (P_)&((StgRetDyn *)p)->payload[0];
- goto small_bitmap;
+ size = RET_DYN_SIZE;
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ thread(p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
- // probably a slow-entry point return address:
- case FUN:
- case FUN_STATIC:
- p++;
+ // skip over the non-ptr words
+ p += GET_NONPTRS(dyn);
+
+ // follow the ptr words
+ for (size = GET_PTRS(dyn); size > 0; size--) {
+ thread(p);
+ p++;
+ }
continue;
+ }
// small bitmap (<= 32 entries, or 64 on a 64-bit machine)
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
- case SEQ_FRAME:
- case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
- bitmap = info->layout.bitmap;
+ bitmap = BITMAP_BITS(info->i.layout.bitmap);
+ size = BITMAP_SIZE(info->i.layout.bitmap);
p++;
- // this assumes that the payload starts immediately after the info-ptr
- small_bitmap:
- while (bitmap != 0) {
+ // NOTE: the payload starts immediately after the info-ptr, we
+ // don't have an StgHeader in the same sense as a heap closure.
+ while (size > 0) {
if ((bitmap & 1) == 0) {
thread(p);
}
p++;
bitmap = bitmap >> 1;
+ size--;
}
continue;
+ case RET_BCO: {
+ StgBCO *bco;
+ nat size;
+
+ p++;
+ thread(p);
+ bco = (StgBCO *)*p;
+ p++;
+ size = BCO_BITMAP_SIZE(bco);
+ thread_large_bitmap(p, BCO_BITMAP(bco), size);
+ p += size;
+ continue;
+ }
+
// large bitmap (> 32 entries, or 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
- {
- StgPtr q;
- StgLargeBitmap *large_bitmap;
- nat i;
-
- large_bitmap = info->layout.large_bitmap;
p++;
+ size = info->i.layout.large_bitmap->size;
+ thread_large_bitmap(p, info->i.layout.large_bitmap, size);
+ p += size;
+ continue;
- for (i=0; i<large_bitmap->size; i++) {
- bitmap = large_bitmap->bitmap[i];
- q = p + BITS_IN(W_);
- while (bitmap != 0) {
- if ((bitmap & 1) == 0) {
- thread(p);
- }
- p++;
- bitmap = bitmap >> 1;
- }
- if (i+1 < large_bitmap->size) {
- while (p < q) {
- thread(p);
- p++;
- }
- }
- }
+ case RET_FUN:
+ {
+ StgRetFun *ret_fun = (StgRetFun *)p;
+ StgFunInfoTable *fun_info;
+
+ fun_info = get_fun_itbl(ret_fun->fun); // *before* threading it!
+ thread((StgPtr)&ret_fun->fun);
+ p = thread_arg_block(fun_info, ret_fun->payload);
continue;
}
default:
barf("thread_stack: weird activation record found on stack: %d",
- (int)(info->type));
+ (int)(info->i.type));
}
}
}
+static inline StgPtr
+thread_PAP (StgPAP *pap)
+{
+ StgPtr p;
+ StgWord bitmap, size;
+ StgFunInfoTable *fun_info;
+
+ thread((StgPtr)&pap->fun);
+ fun_info = get_fun_itbl(pap->fun);
+ ASSERT(fun_info->i.type != PAP);
+
+ p = (StgPtr)pap->payload;
+ size = pap->n_args;
+
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ goto small_bitmap;
+ case ARG_GEN_BIG:
+ thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ p += size;
+ break;
+ case ARG_BCO:
+ thread_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ small_bitmap:
+ size = pap->n_args;
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ thread(p);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ break;
+ }
+ return p;
+}
+
+static inline StgPtr
+thread_AP_STACK (StgAP_STACK *ap)
+{
+ thread((StgPtr)&ap->fun);
+ thread_stack((P_)ap->payload, (P_)ap->payload + ap->size);
+ return (P_)ap + sizeofW(StgAP_STACK) + ap->size;
+}
+
+static StgPtr
+thread_TSO (StgTSO *tso)
+{
+ thread((StgPtr)&tso->link);
+ thread((StgPtr)&tso->global_link);
+
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole
+ || tso->why_blocked == BlockedOnException
+#if defined(PAR)
+ || tso->why_blocked == BlockedOnGA
+ || tso->why_blocked == BlockedOnGA_NoSend
+#endif
+ ) {
+ thread((StgPtr)&tso->block_info.closure);
+ }
+ if ( tso->blocked_exceptions != NULL ) {
+ thread((StgPtr)&tso->blocked_exceptions);
+ }
+
+ thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
+ return (StgPtr)tso + tso_sizeW(tso);
+}
+
+
static void
update_fwd_large( bdescr *bd )
{
}
case TSO:
- {
- StgTSO *tso = (StgTSO *)p;
- thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
- thread((StgPtr)&tso->link);
- thread((StgPtr)&tso->global_link);
+ thread_TSO((StgTSO *)p);
+ continue;
+
+ case AP_STACK:
+ thread_AP_STACK((StgAP_STACK *)p);
continue;
- }
- case AP_UPD:
case PAP:
- {
- StgPAP* pap = (StgPAP *)p;
- thread((StgPtr)&pap->fun);
- thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
+ thread_PAP((StgPAP *)p);
continue;
- }
default:
barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
}
}
+static inline StgPtr
+thread_obj (StgInfoTable *info, StgPtr p)
+{
+ switch (info->type) {
+ case FUN_0_1:
+ case CONSTR_0_1:
+ return p + sizeofW(StgHeader) + 1;
+
+ case FUN_1_0:
+ case CONSTR_1_0:
+ thread((StgPtr)&((StgClosure *)p)->payload[0]);
+ return p + sizeofW(StgHeader) + 1;
+
+ case THUNK_1_0:
+ thread((StgPtr)&((StgClosure *)p)->payload[0]);
+ return p + sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
+
+ case THUNK_0_1: // MIN_UPD_SIZE
+ case THUNK_0_2:
+ case FUN_0_2:
+ case CONSTR_0_2:
+ return p + sizeofW(StgHeader) + 2;
+
+ case THUNK_1_1:
+ case FUN_1_1:
+ case CONSTR_1_1:
+ thread((StgPtr)&((StgClosure *)p)->payload[0]);
+ return p + sizeofW(StgHeader) + 2;
+
+ case THUNK_2_0:
+ case FUN_2_0:
+ case CONSTR_2_0:
+ thread((StgPtr)&((StgClosure *)p)->payload[0]);
+ thread((StgPtr)&((StgClosure *)p)->payload[1]);
+ return p + sizeofW(StgHeader) + 2;
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ case FOREIGN:
+ case STABLE_NAME:
+ case BCO:
+ case IND_PERM:
+ case MUT_VAR:
+ case MUT_CONS:
+ case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
+ case BLACKHOLE:
+ case BLACKHOLE_BQ:
+ {
+ StgPtr end;
+
+ end = (P_)((StgClosure *)p)->payload +
+ info->layout.payload.ptrs;
+ for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
+ thread(p);
+ }
+ return p + info->layout.payload.nptrs;
+ }
+
+ case WEAK:
+ {
+ StgWeak *w = (StgWeak *)p;
+ thread((StgPtr)&w->key);
+ thread((StgPtr)&w->value);
+ thread((StgPtr)&w->finalizer);
+ if (w->link != NULL) {
+ thread((StgPtr)&w->link);
+ }
+ return p + sizeofW(StgWeak);
+ }
+
+ case MVAR:
+ {
+ StgMVar *mvar = (StgMVar *)p;
+ thread((StgPtr)&mvar->head);
+ thread((StgPtr)&mvar->tail);
+ thread((StgPtr)&mvar->value);
+ return p + sizeofW(StgMVar);
+ }
+
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
+ return p + sizeofW(StgIndOldGen);
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ thread((StgPtr)&s->selectee);
+ return p + THUNK_SELECTOR_sizeW();
+ }
+
+ case AP_STACK:
+ return thread_AP_STACK((StgAP_STACK *)p);
+
+ case PAP:
+ case AP:
+ return thread_PAP((StgPAP *)p);
+
+ case ARR_WORDS:
+ return p + arr_words_sizeW((StgArrWords *)p);
+
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ // follow everything
+ {
+ StgPtr next;
+
+ next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ thread(p);
+ }
+ return p;
+ }
+
+ case TSO:
+ return thread_TSO((StgTSO *)p);
+
+ default:
+ barf("update_fwd: unknown/strange object %d", (int)(info->type));
+ }
+}
+
static void
update_fwd( bdescr *blocks )
{
// linearly scan the objects in this block
while (p < bd->free) {
-
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = get_itbl((StgClosure *)p);
-
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
- || IS_HUGS_CONSTR_INFO(info)));
-
- switch (info->type) {
- case FUN_0_1:
- case CONSTR_0_1:
- p += sizeofW(StgHeader) + 1;
- break;
-
- case FUN_1_0:
- case CONSTR_1_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_1_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
- break;
-
- case THUNK_0_1: // MIN_UPD_SIZE
- case THUNK_0_2:
- case FUN_0_2:
- case CONSTR_0_2:
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_1:
- case FUN_1_1:
- case CONSTR_1_1:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_2_0:
- case FUN_2_0:
- case CONSTR_2_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- thread((StgPtr)&((StgClosure *)p)->payload[1]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case FUN:
- case THUNK:
- case CONSTR:
- case FOREIGN:
- case STABLE_NAME:
- case BCO:
- case IND_PERM:
- case MUT_VAR:
- case MUT_CONS:
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- case BLACKHOLE_BQ:
- {
- StgPtr end;
-
- end = (P_)((StgClosure *)p)->payload +
- info->layout.payload.ptrs;
- for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
- thread(p);
- }
- p += info->layout.payload.nptrs;
- break;
- }
-
- // the info table for a weak ptr lies about the number of ptrs
- // (because we have special GC routines for them, but we
- // want to use the standard evacuate code). So we have to
- // special case here.
- case WEAK:
- {
- StgWeak *w = (StgWeak *)p;
- thread((StgPtr)&w->key);
- thread((StgPtr)&w->value);
- thread((StgPtr)&w->finalizer);
- if (w->link != NULL) {
- thread((StgPtr)&w->link);
- }
- p += sizeofW(StgWeak);
- break;
- }
-
- // again, the info table for MVar isn't suitable here (it includes
- // the mut_link field as a pointer, and we don't want to
- // thread it).
- case MVAR:
- {
- StgMVar *mvar = (StgMVar *)p;
- thread((StgPtr)&mvar->head);
- thread((StgPtr)&mvar->tail);
- thread((StgPtr)&mvar->value);
- p += sizeofW(StgMVar);
- break;
- }
-
- case IND_OLDGEN:
- case IND_OLDGEN_PERM:
- thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
- p += sizeofW(StgIndOldGen);
- break;
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- thread((StgPtr)&s->selectee);
- p += THUNK_SELECTOR_sizeW();
- break;
- }
-
- case AP_UPD: // same as PAPs
- case PAP:
- {
- StgPAP* pap = (StgPAP *)p;
-
- thread((P_)&pap->fun);
- thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
- p += pap_sizeW(pap);
- break;
- }
-
- case ARR_WORDS:
- p += arr_words_sizeW((StgArrWords *)p);
- break;
-
- case MUT_ARR_PTRS:
- case MUT_ARR_PTRS_FROZEN:
- // follow everything
- {
- StgPtr next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- thread(p);
- }
- break;
- }
-
- case TSO:
- {
- StgTSO *tso = (StgTSO *)p;
- thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
- thread((StgPtr)&tso->link);
- thread((StgPtr)&tso->global_link);
- p += tso_sizeW(tso);
- break;
- }
-
- default:
- barf("update_fwd: unknown/strange object %d", (int)(info->type));
- }
+ p = thread_obj(info, p);
}
}
}
info = get_threaded_info(p);
q = p;
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
- || IS_HUGS_CONSTR_INFO(info)));
- switch (info->type) {
- case FUN_0_1:
- case CONSTR_0_1:
- p += sizeofW(StgHeader) + 1;
- break;
-
- case FUN_1_0:
- case CONSTR_1_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 1;
- break;
-
- case THUNK_1_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
- break;
-
- case THUNK_0_1: // MIN_UPD_SIZE
- case THUNK_0_2:
- case FUN_0_2:
- case CONSTR_0_2:
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_1_1:
- case FUN_1_1:
- case CONSTR_1_1:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case THUNK_2_0:
- case FUN_2_0:
- case CONSTR_2_0:
- thread((StgPtr)&((StgClosure *)p)->payload[0]);
- thread((StgPtr)&((StgClosure *)p)->payload[1]);
- p += sizeofW(StgHeader) + 2;
- break;
-
- case FUN:
- case THUNK:
- case CONSTR:
- case FOREIGN:
- case STABLE_NAME:
- case BCO:
- case IND_PERM:
- case MUT_VAR:
- case MUT_CONS:
- case CAF_BLACKHOLE:
- case SE_CAF_BLACKHOLE:
- case SE_BLACKHOLE:
- case BLACKHOLE:
- case BLACKHOLE_BQ:
- {
- StgPtr end;
-
- end = (P_)((StgClosure *)p)->payload +
- info->layout.payload.ptrs;
- for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
- thread(p);
- }
- p += info->layout.payload.nptrs;
- break;
- }
-
- case WEAK:
- {
- StgWeak *w = (StgWeak *)p;
- thread((StgPtr)&w->key);
- thread((StgPtr)&w->value);
- thread((StgPtr)&w->finalizer);
- if (w->link != NULL) {
- thread((StgPtr)&w->link);
- }
- p += sizeofW(StgWeak);
- break;
- }
-
- case MVAR:
- {
- StgMVar *mvar = (StgMVar *)p;
- thread((StgPtr)&mvar->head);
- thread((StgPtr)&mvar->tail);
- thread((StgPtr)&mvar->value);
- p += sizeofW(StgMVar);
- break;
- }
-
- case IND_OLDGEN:
- case IND_OLDGEN_PERM:
- thread((StgPtr)&((StgIndOldGen *)p)->indirectee);
- p += sizeofW(StgIndOldGen);
- break;
-
- case THUNK_SELECTOR:
- {
- StgSelector *s = (StgSelector *)p;
- thread((StgPtr)&s->selectee);
- p += THUNK_SELECTOR_sizeW();
- break;
- }
-
- case AP_UPD: // same as PAPs
- case PAP:
- {
- StgPAP* pap = (StgPAP *)p;
-
- thread((P_)&pap->fun);
- thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
- p += pap_sizeW(pap);
- break;
- }
-
- case ARR_WORDS:
- p += arr_words_sizeW((StgArrWords *)p);
- break;
-
- case MUT_ARR_PTRS:
- case MUT_ARR_PTRS_FROZEN:
- // follow everything
- {
- StgPtr next;
-
- next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
- for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
- thread(p);
- }
- break;
- }
-
- case TSO:
- {
- StgTSO *tso = (StgTSO *)p;
- thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
- thread((StgPtr)&tso->link);
- thread((StgPtr)&tso->global_link);
- p += tso_sizeW(tso);
- break;
- }
-
- default:
- barf("update_fwd: unknown/strange object %d", (int)(info->type));
- }
+ p = thread_obj(info, p);
size = p - q;
if (free + size > free_bd->start + BLOCK_SIZE_W) {
}
unthread(p,free);
+ ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info));
info = get_itbl((StgClosure *)p);
size = obj_sizeW((StgClosure *)p,info);
- ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
- || IS_HUGS_CONSTR_INFO(info)));
-
if (free != p) {
move(free,p,size);
}
/* -----------------------------------------------------------------------------
- * $Id: HeapStackCheck.hc,v 1.26 2002/03/02 17:43:44 sof Exp $
+ * $Id: HeapStackCheck.hc,v 1.27 2002/12/11 15:36:42 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Canned Heap-Check and Stack-Check sequences.
*
#include "Storage.h" /* for CurrentTSO */
#include "StgRun.h" /* for StgReturn and register saving */
#include "Schedule.h" /* for context_switch */
+#include "RtsFlags.h"
+#include "Apply.h"
+
+#include <stdio.h>
/* Stack/Heap Check Failure
* ------------------------
*/
#define GC_GENERIC \
+ DEBUG_ONLY(heapCheckFail()); \
if (Hp > HpLim) { \
Hp -= HpAlloc; \
if (HpAlloc <= BLOCK_SIZE_W && ExtendNursery(Hp,HpLim)) {\
if (context_switch) { \
R1.i = ThreadYielding; \
} else { \
- Sp++; \
- JMP_(ENTRY_CODE(Sp[-1])); \
+ JMP_(ENTRY_CODE(Sp[0])); \
} \
} else { \
R1.i = HeapOverflow; \
CurrentTSO->what_next = ThreadRunGHC; \
JMP_(StgReturn);
-#define GC_ENTER \
- if (Hp > HpLim) { \
- Hp -= HpAlloc; \
- if (HpAlloc <= BLOCK_SIZE_W && ExtendNursery(Hp,HpLim)) {\
- if (context_switch) { \
- R1.i = ThreadYielding; \
- } else { \
- R1.w = *Sp; \
- Sp++; \
- JMP_(ENTRY_CODE(*R1.p)); \
- } \
- } else { \
- R1.i = HeapOverflow; \
- } \
- } else { \
- R1.i = StackOverflow; \
- } \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadEnterGHC; \
- JMP_(StgReturn);
-
-#define HP_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = HeapOverflow; \
- JMP_(StgReturn);
-
-#define STK_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = StackOverflow; \
- JMP_(StgReturn);
-
-#define YIELD_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = ThreadYielding; \
+#define HP_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->what_next = ThreadRunGHC; \
+ R1.i = HeapOverflow; \
JMP_(StgReturn);
-#define YIELD_TO_INTERPRETER \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadEnterInterp; \
- R1.i = ThreadYielding; \
+#define YIELD_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->what_next = ThreadRunGHC; \
+ R1.i = ThreadYielding; \
JMP_(StgReturn);
-#define BLOCK_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = ThreadBlocked; \
+#define YIELD_TO_INTERPRETER \
+ SaveThreadState(); \
+ CurrentTSO->what_next = ThreadInterpret; \
+ R1.i = ThreadYielding; \
JMP_(StgReturn);
-#define BLOCK_ENTER \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadEnterGHC;\
- R1.i = ThreadBlocked; \
+#define BLOCK_GENERIC \
+ SaveThreadState(); \
+ CurrentTSO->what_next = ThreadRunGHC; \
+ R1.i = ThreadBlocked; \
JMP_(StgReturn);
/* -----------------------------------------------------------------------------
- Heap Checks
- -------------------------------------------------------------------------- */
-
-/*
- * This one is used when we want to *enter* the top thing on the stack
- * when we return, instead of the just returning to an address. See
- * UpdatePAP for an example.
- */
-
-EXTFUN(stg_gc_entertop)
-{
- FB_
- GC_ENTER
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Heap checks in non-top-level thunks/functions.
+ Heap checks in thunks/functions.
In these cases, node always points to the function closure. This gives
us an easy way to return to the function: just leave R1 on the top of
There are canned sequences for 'n' pointer values in registers.
-------------------------------------------------------------------------- */
-EXTFUN(__stg_gc_enter_1)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- GC_ENTER
- FE_
-}
-
-EXTFUN(stg_gc_enter_1_hponly)
+INFO_TABLE_RET( stg_enter_info, stg_enter_ret,
+ MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
+EXTFUN(stg_enter_ret)
{
FB_
- Sp -= 1;
- Sp[0] = R1.w;
- R1.i = HeapOverflow;
- SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
- JMP_(StgReturn);
+ R1.w = Sp[1];
+ Sp += 2;
+ ENTER();
FE_
}
-/*- 2 Regs--------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_2)
+EXTFUN(__stg_gc_enter_1)
{
FB_
Sp -= 2;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
- FE_
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_3)
-{
- FB_
- Sp -= 3;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
- FE_
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_4)
-{
- FB_
- Sp -= 4;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
- FE_
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_5)
-{
- FB_
- Sp -= 5;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
- FE_
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_6)
-{
- FB_
- Sp -= 6;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
- FE_
-}
-
-/*- 7 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_7)
-{
- FB_
- Sp -= 7;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- GC_ENTER;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_enter_info;
+ GC_GENERIC
FE_
}
-/*- 8 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_gc_enter_8)
+#ifdef SMP
+EXTFUN(stg_gc_enter_1_hponly)
{
FB_
- Sp -= 8;
- Sp[7] = R8.w;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
+ Sp -= 1;
Sp[0] = R1.w;
- GC_ENTER;
+ R1.i = HeapOverflow;
+ SaveThreadState();
+ CurrentTSO->what_next = ThreadRunGHC;
+ JMP_(StgReturn);
FE_
}
+#endif
#if defined(GRAN)
/*
{
FB_
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp -= 1;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadYielding;
JMP_(StgReturn);
FE_
Sp -= 1;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
Sp[1] = R2.w;
Sp[0] = R1.w;
SaveThreadState();
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
EXTFUN(par_jump)
{
FB_
- CurrentTSO->what_next = ThreadEnterGHC;
+ CurrentTSO->what_next = ThreadRunGHC;
R1.i = ThreadBlocked;
JMP_(StgReturn);
FE_
#endif
/* -----------------------------------------------------------------------------
- For a case expression on a polymorphic or function-typed object, if
- the default branch (there can only be one branch) of the case fails
- a heap-check, instead of using stg_gc_enter_1 as normal, we must
- push a new SEQ frame on the stack, followed by the object returned.
-
- Otherwise, if the object is a function, it won't return to the
- correct activation record on returning from garbage collection. It will
- assume it has some arguments and apply itself.
- -------------------------------------------------------------------------- */
-
-EXTFUN(stg_gc_seq_1)
-{
- FB_
- Sp -= 1 + sizeofW(StgSeqFrame);
- PUSH_SEQ_FRAME(Sp+1);
- *Sp = R1.w;
- GC_ENTER;
- FE_
-}
-
-/* -----------------------------------------------------------------------------
Heap checks in Primitive case alternatives
A primitive case alternative is entered with a value either in
cases are covered below.
-------------------------------------------------------------------------- */
-/*-- No registers live (probably a void return) ----------------------------- */
+/*-- No Registers live ------------------------------------------------------ */
-/* If we change the policy for thread startup to *not* remove the
- * return address from the stack, we can get rid of this little
- * function/info table...
- */
-INFO_TABLE_SRT_BITMAP(stg_gc_noregs_info, stg_gc_noregs_ret, 0/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_noregs_ret)
+EXTFUN(stg_gc_noregs)
{
FB_
- JMP_(ENTRY_CODE(Sp[0]));
+ GC_GENERIC
FE_
}
-EXTFUN(stg_gc_noregs)
+/*-- void return ------------------------------------------------------------ */
+
+INFO_TABLE_RET( stg_gc_void_info, stg_gc_void_ret,
+ MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
+
+EXTFUN(stg_gc_void_ret)
{
FB_
- Sp -= 1;
- Sp[0] = (W_)&stg_gc_noregs_info;
- GC_GENERIC
+ Sp += 1;
+ JMP_(ENTRY_CODE(Sp[0]));
FE_
}
/*-- R1 is boxed/unpointed -------------------------------------------------- */
-INFO_TABLE_SRT_BITMAP(stg_gc_unpt_r1_info, stg_gc_unpt_r1_ret, 0/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_gc_unpt_r1_info, stg_gc_unpt_r1_ret,
+ MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_unpt_r1_ret)
{
FB_
- R1.w = Sp[0];
- Sp += 1;
+ R1.w = Sp[1];
+ Sp += 2;
JMP_(ENTRY_CODE(Sp[0]));
FE_
}
FE_
}
-/*-- Unboxed tuple return (unregisterised build only)------------------ */
-
-INFO_TABLE_SRT_BITMAP(stg_ut_1_0_unreg_info, stg_ut_1_0_unreg_ret, 0/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_ut_1_0_unreg_ret)
-{
- FB_
- /* R1 is on the stack (*Sp) */
- JMP_(ENTRY_CODE(Sp[1]));
- FE_
-}
-
/*-- R1 is unboxed -------------------------------------------------- */
-INFO_TABLE_SRT_BITMAP(stg_gc_unbx_r1_info, stg_gc_unbx_r1_ret, 1/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_gc_unbx_r1_info, stg_gc_unbx_r1_ret,
+ MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
+
/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
EXTFUN(stg_gc_unbx_r1_ret)
{
FB_
- R1.w = Sp[0];
- Sp += 1;
+ R1.w = Sp[1];
+ Sp += 2;
JMP_(ENTRY_CODE(Sp[0]));
FE_
}
/*-- F1 contains a float ------------------------------------------------- */
-INFO_TABLE_SRT_BITMAP(stg_gc_f1_info, stg_gc_f1_ret, 1/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_gc_f1_info, stg_gc_f1_ret,
+ MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_f1_ret)
{
FB_
- F1 = PK_FLT(Sp);
- Sp += 1;
+ F1 = PK_FLT(Sp+1);
+ Sp += 2;
JMP_(ENTRY_CODE(Sp[0]));
FE_
}
#if SIZEOF_DOUBLE == SIZEOF_VOID_P
# define DBL_BITMAP 1
+# define DBL_WORDS 1
#else
# define DBL_BITMAP 3
+# define DBL_WORDS 2
#endif
-INFO_TABLE_SRT_BITMAP(stg_gc_d1_info, stg_gc_d1_ret, DBL_BITMAP,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_gc_d1_info, stg_gc_d1_ret,
+ MK_SMALL_BITMAP(DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_d1_ret)
{
FB_
- D1 = PK_DBL(Sp);
- Sp += sizeofW(StgDouble);
+ D1 = PK_DBL(Sp+1);
+ Sp += 1 + sizeofW(StgDouble);
JMP_(ENTRY_CODE(Sp[0]));
FE_
}
#if SIZEOF_VOID_P == 8
# define LLI_BITMAP 1
+# define LLI_WORDS 1
#else
# define LLI_BITMAP 3
+# define LLI_WORDS 2
#endif
-INFO_TABLE_SRT_BITMAP(stg_gc_l1_info, stg_gc_l1_ret, LLI_BITMAP,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_gc_l1_info, stg_gc_l1_ret,
+ MK_SMALL_BITMAP(LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
EXTFUN(stg_gc_l1_ret)
{
FB_
- L1 = PK_Int64(Sp);
- Sp += sizeofW(StgWord64);
+ L1 = PK_Int64(Sp+1);
+ Sp += 1 + sizeofW(StgWord64);
JMP_(ENTRY_CODE(Sp[0]));
FE_
}
FE_
}
-/* -----------------------------------------------------------------------------
- Heap checks for unboxed tuple case alternatives
-
- The story is:
-
- - for an unboxed tuple with n components, we rearrange the components
- with pointers first followed by non-pointers. (NB: not done yet)
-
- - The first k components are allocated registers, where k is the
- number of components that will fit in real registers.
-
- - The rest are placed on the stack, with space left for tagging
- of the non-pointer block if necessary.
-
- - On failure of a heap check:
- - the tag is filled in if necessary,
- - we load Ri with the address of the continuation,
- where i is the lowest unused vanilla register.
- - jump to 'stg_gc_ut_x_y' where x is the number of pointer
- registers and y the number of non-pointers.
- - if the required canned sequence isn't available, it will
- have to be generated at compile-time by the code
- generator (this will probably happen if there are
- floating-point values, for instance).
-
- For now, just deal with R1, hence R2 contains the sequel address.
- -------------------------------------------------------------------------- */
-
-/*---- R1 contains a pointer: ------ */
-
-INFO_TABLE_SRT_BITMAP(stg_gc_ut_1_0_info, stg_gc_ut_1_0_ret, 1/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_ut_1_0_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[-2]));
- FE_
-}
-
-EXTFUN(stg_gc_ut_1_0)
-{
- FB_
- Sp -= 3;
- Sp[2] = R1.w;
- Sp[1] = R2.w;
- Sp[0] = (W_)&stg_gc_ut_1_0_info;
- GC_GENERIC
- FE_
-}
-
-/*---- R1 contains a non-pointer: ------ */
+/*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */
-INFO_TABLE_SRT_BITMAP(stg_gc_ut_0_1_info, stg_gc_ut_0_1_ret, 3/*BITMAP*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_ut_1_0_unreg_info, stg_ut_1_0_unreg_ret,
+ MK_SMALL_BITMAP(1/*size*/, 0/*BITMAP*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
-EXTFUN(stg_gc_ut_0_1_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[-2]));
- FE_
-}
-
-EXTFUN(stg_gc_ut_0_1)
+EXTFUN(stg_ut_1_0_unreg_ret)
{
FB_
- Sp -= 3;
- Sp[0] = (W_)&stg_gc_ut_0_1_info;
- Sp[1] = R2.w;
- Sp[2] = R1.w;
- GC_GENERIC
+ Sp++;
+ /* one ptr is on the stack (Sp[0]) */
+ JMP_(ENTRY_CODE(Sp[1]));
FE_
}
/* -----------------------------------------------------------------------------
- Standard top-level fast-entry heap checks.
-
- - we want to make the stack look like it should at the slow entry
- point for the function. That way we can just push the slow
- entry point on the stack and return using ThreadRunGHC.
-
- - The compiler will generate code to fill in any tags on the stack,
- in case we arrived directly at the fast entry point and these tags
- aren't present.
-
- - The rest is hopefully handled by jumping to a canned sequence.
- We currently have canned sequences for 0-8 pointer registers. If
- any registers contain non-pointers, we must reduce to an all-pointers
- situation by pushing as many registers on the stack as necessary.
-
- eg. if R1, R2 contain pointers and R3 contains a word, the heap check
- failure sequence looks like this:
-
- Sp[-1] = R3.w;
- Sp[-2] = WORD_TAG;
- Sp -= 2;
- JMP_(stg_chk_2)
-
- after pushing R3, we have pointers in R1 and R2 which corresponds
- to the 2-pointer canned sequence.
-
- -------------------------------------------------------------------------- */
-
-/*- 0 Regs -------------------------------------------------------------------*/
-
-EXTFUN(__stg_chk_0)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 1 Reg --------------------------------------------------------------------*/
-
-EXTFUN(__stg_chk_1)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = R2.w;
- GC_GENERIC;
- FE_
-}
+ Generic function entry heap check code.
+
+ At a function entry point, the arguments are as per the calling convention,
+ i.e. some in regs and some on the stack. There may or may not be
+ a pointer to the function closure in R1 - if there isn't, then the heap
+ check failure code in the function will arrange to load it.
+
+ The function's argument types are described in its info table, so we
+ can just jump to this bit of generic code to save away all the
+ registers and return to the scheduler.
+
+ This code arranges the stack like this:
+
+ | .... |
+ | args |
+ +---------------------+
+ | f_closure |
+ +---------------------+
+ | size |
+ +---------------------+
+ | stg_gc_fun_info |
+ +---------------------+
+
+ The size is the number of words of arguments on the stack, and is cached
+ in the frame in order to simplify stack walking: otherwise the size of
+ this stack frame would have to be calculated by looking at f's info table.
-/*- 1 Reg (non-ptr) ----------------------------------------------------------*/
-
-EXTFUN(stg_chk_1n)
-{
- FB_
- Sp -= 3;
- Sp[2] = R1.w;
- Sp[1] = WORD_TAG; /* ToDo: or maybe its an int? */
- Sp[0] = R2.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 2 Regs--------------------------------------------------------------------*/
-
-EXTFUN(stg_chk_2)
-{
- FB_
- Sp -= 3;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R3.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_chk_3)
-{
- FB_
- Sp -= 4;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R4.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_chk_4)
-{
- FB_
- Sp -= 5;
- Sp[4] = R4.w;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R5.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-EXTFUN(stg_chk_5)
-{
- FB_
- Sp -= 6;
- Sp[5] = R5.w;
- Sp[4] = R4.w;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R6.w;
- GC_GENERIC;
- FE_
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
+ -------------------------------------------------------------------------- */
-EXTFUN(stg_chk_6)
-{
- FB_
- Sp -= 7;
- Sp[6] = R6.w;
- Sp[5] = R5.w;
- Sp[4] = R4.w;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R7.w;
- GC_GENERIC;
- FE_
-}
+EXTFUN(__stg_gc_fun)
+{
+ StgWord size;
+ StgFunInfoTable *info;
+ FB_
+
+ info = get_fun_itbl(R1.cl);
+
+ // cache the size
+ if (info->fun_type == ARG_GEN) {
+ size = BITMAP_SIZE(info->bitmap);
+ } else if (info->fun_type == ARG_GEN_BIG) {
+ size = ((StgLargeBitmap *)info->bitmap)->size;
+ } else {
+ size = BITMAP_SIZE(stg_arg_bitmaps[info->fun_type]);
+ }
+
+#ifdef NO_ARG_REGS
+ // we don't have to save any registers away
+ Sp -= 3;
+ Sp[2] = R1.w;
+ Sp[1] = size;
+ Sp[0] = (W_)&stg_gc_fun_info;
+ GC_GENERIC
+#else
+ if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
+ // regs already saved by the heap check code
+ Sp -= 3;
+ Sp[2] = R1.w;
+ Sp[1] = size;
+ Sp[0] = (W_)&stg_gc_fun_info;
+ DEBUG_ONLY(fprintf(stderr, "stg_fun_gc_gen(ARG_GEN)"););
+ GC_GENERIC
+ } else {
+ JMP_(stg_stack_save_entries[info->fun_type]);
+ // jumps to stg_gc_noregs after saving stuff
+ }
+#endif // !NO_ARG_REGS
+
+ FE_
+}
-/*- 7 Regs -------------------------------------------------------------------*/
+/* -----------------------------------------------------------------------------
+ Generic Apply (return point)
-EXTFUN(stg_chk_7)
-{
- FB_
- Sp -= 8;
- Sp[7] = R7.w;
- Sp[6] = R6.w;
- Sp[5] = R5.w;
- Sp[4] = R4.w;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R8.w;
- GC_GENERIC;
- FE_
-}
+ The dual to stg_fun_gc_gen (above): this fragment returns to the
+ function, passing arguments in the stack and in registers
+ appropriately. The stack layout is given above.
+ -------------------------------------------------------------------------- */
-/*- 8 Regs -------------------------------------------------------------------*/
+INFO_TABLE_RET( stg_gc_fun_info,stg_gc_fun_ret,
+ MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_FUN,, EF_, 0, 0);
-EXTFUN(stg_chk_8)
+EXTFUN(stg_gc_fun_ret)
{
FB_
- Sp -= 9;
- Sp[8] = R8.w;
- Sp[7] = R7.w;
- Sp[6] = R6.w;
- Sp[5] = R5.w;
- Sp[4] = R4.w;
- Sp[3] = R3.w;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = R9.w;
- GC_GENERIC;
+ R1.w = Sp[2];
+ Sp += 3;
+#ifdef NO_ARG_REGS
+ // there are no argument registers to load up, so we can just jump
+ // straight to the function's entry point.
+ JMP_(GET_ENTRY(R1.cl));
+#else
+ {
+ StgFunInfoTable *info;
+
+ info = get_fun_itbl(R1.cl);
+ if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
+ // regs already saved by the heap check code
+ DEBUG_ONLY(fprintf(stderr, "stg_gc_fun_ret(ARG_GEN)\n"););
+ JMP_(info->slow_apply);
+ } else if (info->fun_type == ARG_BCO) {
+ // cover this case just to be on the safe side
+ Sp -= 2;
+ Sp[1] = R1.cl;
+ Sp[0] = (W_)&stg_apply_interp_info;
+ JMP_(stg_yield_to_interpreter);
+ } else {
+ JMP_(stg_ap_stack_entries[info->fun_type]);
+ }
+ }
+#endif
FE_
}
Generic Heap Check Code.
Called with Liveness mask in R9, Return address in R10.
- Stack must be consistent (tagged, and containing all necessary info pointers
+ Stack must be consistent (containing all necessary info pointers
to relevant SRTs).
+ See StgMacros.h for a description of the RET_DYN stack frame.
+
We also define an stg_gen_yield here, because it's very similar.
-------------------------------------------------------------------------- */
-#if SIZEOF_DOUBLE > SIZEOF_VOID_P
+// For simplicity, we assume that SIZEOF_DOUBLE == 2*SIZEOF_VOID_P
+// on a 64-bit machine, we'll end up wasting a couple of words, but
+// it's not a big deal.
#define RESTORE_EVERYTHING \
- D2 = PK_DBL(Sp+16); \
- D1 = PK_DBL(Sp+14); \
- F4 = PK_FLT(Sp+13); \
- F3 = PK_FLT(Sp+12); \
- F2 = PK_FLT(Sp+11); \
- F1 = PK_FLT(Sp+10); \
- R8.w = Sp[9]; \
- R7.w = Sp[8]; \
- R6.w = Sp[7]; \
- R5.w = Sp[6]; \
- R4.w = Sp[5]; \
- R3.w = Sp[4]; \
- R2.w = Sp[3]; \
- R1.w = Sp[2]; \
- Sp += 18;
+ D2 = PK_DBL(Sp+17); \
+ D1 = PK_DBL(Sp+15); \
+ F4 = PK_FLT(Sp+14); \
+ F3 = PK_FLT(Sp+13); \
+ F2 = PK_FLT(Sp+12); \
+ F1 = PK_FLT(Sp+11); \
+ R8.w = Sp[10]; \
+ R7.w = Sp[9]; \
+ R6.w = Sp[8]; \
+ R5.w = Sp[7]; \
+ R4.w = Sp[6]; \
+ R3.w = Sp[5]; \
+ R2.w = Sp[4]; \
+ R1.w = Sp[3]; \
+ Sp += 19;
#define RET_OFFSET (-17)
#define SAVE_EVERYTHING \
- ASSIGN_DBL(Sp-2,D2); \
- ASSIGN_DBL(Sp-4,D1); \
- ASSIGN_FLT(Sp-5,F4); \
- ASSIGN_FLT(Sp-6,F3); \
- ASSIGN_FLT(Sp-7,F2); \
- ASSIGN_FLT(Sp-8,F1); \
- Sp[-9] = R8.w; \
- Sp[-10] = R7.w; \
- Sp[-11] = R6.w; \
- Sp[-12] = R5.w; \
- Sp[-13] = R4.w; \
- Sp[-14] = R3.w; \
- Sp[-15] = R2.w; \
- Sp[-16] = R1.w; \
- Sp[-17] = R10.w; /* return address */ \
- Sp[-18] = R9.w; /* liveness mask */ \
- Sp[-19] = (W_)&stg_gen_chk_info; \
- Sp -= 19;
-
-#else
-
-#define RESTORE_EVERYTHING \
- D2 = PK_DBL(Sp+15); \
- D1 = PK_DBL(Sp+14); \
- F4 = PK_FLT(Sp+13); \
- F3 = PK_FLT(Sp+12); \
- F2 = PK_FLT(Sp+11); \
- F1 = PK_FLT(Sp+10); \
- R8.w = Sp[9]; \
- R7.w = Sp[8]; \
- R6.w = Sp[7]; \
- R5.w = Sp[6]; \
- R4.w = Sp[5]; \
- R3.w = Sp[4]; \
- R2.w = Sp[3]; \
- R1.w = Sp[2]; \
- Sp += 16;
-
-#define RET_OFFSET (-15)
-
-#define SAVE_EVERYTHING \
- ASSIGN_DBL(Sp-1,D2); \
- ASSIGN_DBL(Sp-2,D1); \
- ASSIGN_FLT(Sp-3,F4); \
- ASSIGN_FLT(Sp-4,F3); \
- ASSIGN_FLT(Sp-5,F2); \
- ASSIGN_FLT(Sp-6,F1); \
- Sp[-7] = R8.w; \
- Sp[-8] = R7.w; \
- Sp[-9] = R6.w; \
- Sp[-10] = R5.w; \
- Sp[-11] = R4.w; \
- Sp[-12] = R3.w; \
- Sp[-13] = R2.w; \
- Sp[-14] = R1.w; \
- Sp[-15] = R10.w; /* return address */ \
- Sp[-16] = R9.w; /* liveness mask */ \
- Sp[-17] = (W_)&stg_gen_chk_info; \
- Sp -= 17;
-
-#endif
-
-INFO_TABLE_SRT_BITMAP(stg_gen_chk_info, stg_gen_chk_ret, 0,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_DYN,, EF_, 0, 0);
+ Sp -= 19; \
+ ASSIGN_DBL(Sp+17,D2); \
+ ASSIGN_DBL(Sp+15,D1); \
+ ASSIGN_FLT(Sp+14,F4); \
+ ASSIGN_FLT(Sp+13,F3); \
+ ASSIGN_FLT(Sp+12,F2); \
+ ASSIGN_FLT(Sp+11,F1); \
+ Sp[10] = R8.w; \
+ Sp[9] = R7.w; \
+ Sp[8] = R6.w; \
+ Sp[7] = R5.w; \
+ Sp[6] = R4.w; \
+ Sp[5] = R3.w; \
+ Sp[4] = R2.w; \
+ Sp[3] = R1.w; \
+ Sp[2] = R10.w; /* return address */ \
+ Sp[1] = R9.w; /* liveness mask */ \
+ Sp[0] = (W_)&stg_gc_gen_info; \
+
+INFO_TABLE_RET( stg_gc_gen_info, stg_gc_gen_ret,
+ 0/*bitmap*/,
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_DYN,, EF_, 0, 0);
/* bitmap in the above info table is unused, the real one is on the stack.
*/
-FN_(stg_gen_chk_ret)
+FN_(stg_gc_gen_ret)
{
FB_
RESTORE_EVERYTHING;
- JMP_(Sp[RET_OFFSET]); /* NO ENTRY_CODE() - this is a direct ret address */
+ JMP_(Sp[RET_OFFSET]); /* No ENTRY_CODE() - this is an actual code ptr */
FE_
}
-FN_(stg_gen_chk)
+FN_(stg_gc_gen)
{
FB_
SAVE_EVERYTHING;
FE_
}
+// A heap check at an unboxed tuple return point. The return address
+// is on the stack, and we can find it by using the offsets given
+// to us in the liveness mask.
+FN_(stg_gc_ut)
+{
+ FB_
+ R10.w = (W_)ENTRY_CODE(Sp[GET_NONPTRS(R9.w) + GET_PTRS(R9.w)]);
+ SAVE_EVERYTHING;
+ GC_GENERIC
+ FE_
+}
+
/*
* stg_gen_hp is used by MAYBE_GC, where we can't use GC_GENERIC
* because we've just failed doYouWantToGC(), not a standard heap
* check. GC_GENERIC would end up returning StackOverflow.
*/
-FN_(stg_gen_hp)
+FN_(stg_gc_gen_hp)
{
FB_
SAVE_EVERYTHING;
FN_(stg_yield_noregs)
{
FB_
- Sp--;
- Sp[0] = (W_)&stg_gc_noregs_info;
YIELD_GENERIC;
FE_
}
+/* -----------------------------------------------------------------------------
+ Yielding to the interpreter... top of stack says what to do next.
+ -------------------------------------------------------------------------- */
+
FN_(stg_yield_to_interpreter)
{
FB_
- /* No need to save everything - no live registers */
- YIELD_TO_INTERPRETER
+ YIELD_TO_INTERPRETER;
FE_
}
FN_(stg_block_noregs)
{
FB_
- Sp--;
- Sp[0] = (W_)&stg_gc_noregs_info;
BLOCK_GENERIC;
FE_
}
FN_(stg_block_1)
{
FB_
- Sp--;
- Sp[0] = R1.w;
- BLOCK_ENTER;
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_enter_info;
+ BLOCK_GENERIC;
FE_
}
*
* -------------------------------------------------------------------------- */
-INFO_TABLE_SRT_BITMAP(stg_block_takemvar_info, stg_block_takemvar_ret,
- 0/*BITMAP*/, 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, IF_, 0, 0);
+INFO_TABLE_RET( stg_block_takemvar_info, stg_block_takemvar_ret,
+ MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, IF_, 0, 0);
IF_(stg_block_takemvar_ret)
{
FB_
- R1.w = Sp[0];
- Sp++;
+ R1.w = Sp[1];
+ Sp += 2;
JMP_(takeMVarzh_fast);
FE_
}
FE_
}
-INFO_TABLE_SRT_BITMAP(stg_block_putmvar_info, stg_block_putmvar_ret,
- 0/*BITMAP*/, 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
- RET_SMALL,, IF_, 0, 0);
+INFO_TABLE_RET( stg_block_putmvar_info, stg_block_putmvar_ret,
+ MK_SMALL_BITMAP(2/*framesize*/, 0/*bitmap*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, IF_, 0, 0);
IF_(stg_block_putmvar_ret)
{
FB_
- R2.w = Sp[1];
- R1.w = Sp[0];
- Sp += 2;
+ R2.w = Sp[2];
+ R1.w = Sp[1];
+ Sp += 3;
JMP_(putMVarzh_fast);
FE_
}
-
/* -----------------------------------------------------------------------------
- * Bytecode evaluator
- *
- * Copyright (c) 1994-2000.
+ * Bytecode interpreter
*
- * $RCSfile: Interpreter.c,v $
- * $Revision: 1.34 $
- * $Date: 2002/02/15 22:15:08 $
+ * Copyright (c) The GHC Team, 1994-2002.
* ---------------------------------------------------------------------------*/
#if !defined(SMP)
#include "RtsFlags.h"
#include "Storage.h"
#include "Updates.h"
+#include "Sanity.h"
#include "Bytecodes.h"
#include "Printer.h"
/* --------------------------------------------------------------------------
- * The new bytecode interpreter
+ * The bytecode interpreter
* ------------------------------------------------------------------------*/
-/* The interpreter can be compiled so it just interprets BCOs and
- hands literally everything else to the scheduler. This gives a
- "reference interpreter" which is correct but slow -- useful for
- debugging. By default, we handle certain closures specially so as
- to dramatically cut down on the number of deferrals to the
- scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be
- defined. */
-
-/* #define REFERENCE_INTERPRETER */
-
/* Gather stats about entry, opcode, opcode-pair frequencies. For
tuning the interpreter. */
/* #define INTERP_STATS */
+/* Sp points to the lowest live word on the stack. */
-/* iSp points to the lowest live word on the stack. */
-
-#define StackWord(n) iSp[n]
#define BCO_NEXT instrs[bciPtr++]
#define BCO_PTR(n) (W_)ptrs[n]
#define BCO_LIT(n) (W_)literals[n]
#define BCO_ITBL(n) itbls[n]
-#define LOAD_STACK_POINTERS \
- iSp = cap->r.rCurrentTSO->sp; \
- iSu = cap->r.rCurrentTSO->su; \
- /* We don't change this ... */ \
- iSpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
-
+#define LOAD_STACK_POINTERS \
+ Sp = cap->r.rCurrentTSO->sp; \
+ /* We don't change this ... */ \
+ SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
-#define SAVE_STACK_POINTERS \
- cap->r.rCurrentTSO->sp = iSp; \
- cap->r.rCurrentTSO->su = iSu;
+#define SAVE_STACK_POINTERS \
+ cap->r.rCurrentTSO->sp = Sp
-#define RETURN(retcode) \
- SAVE_STACK_POINTERS; return retcode;
+#define RETURN_TO_SCHEDULER(todo,retcode) \
+ SAVE_STACK_POINTERS; \
+ cap->r.rCurrentTSO->what_next = (todo); \
+ return (retcode);
-static __inline__ StgPtr allocate_UPD ( int n_words )
+static inline StgPtr
+allocate_UPD (int n_words)
{
- if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE)
- n_words = MIN_UPD_SIZE + sizeofW(StgHeader);
- return allocate(n_words);
+ return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words));
}
-static __inline__ StgPtr allocate_NONUPD ( int n_words )
+static inline StgPtr
+allocate_NONUPD (int n_words)
{
- if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
- n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader);
- return allocate(n_words);
+ return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words));
}
#ifdef INTERP_STATS
+
/* Hacky stats, for tuning the interpreter ... */
int it_unknown_entries[N_CLOSURE_TYPES];
int it_total_unknown_entries;
int it_oofreq[27][27];
int it_lastopc;
+#define INTERP_TICK(n) (n)++
+
void interp_startup ( void )
{
int i, j;
}
}
-#endif
+#else // !INTERP_STATS
+
+#define INTERP_TICK(n) /* nothing */
+
+#endif
-StgThreadReturnCode interpretBCO ( Capability* cap )
+static StgWord app_ptrs_itbl[] = {
+ (W_)&stg_ap_p_info,
+ (W_)&stg_ap_pp_info,
+ (W_)&stg_ap_ppp_info,
+ (W_)&stg_ap_pppp_info,
+ (W_)&stg_ap_ppppp_info,
+ (W_)&stg_ap_pppppp_info,
+ (W_)&stg_ap_ppppppp_info
+};
+
+StgThreadReturnCode
+interpretBCO (Capability* cap)
{
- /* On entry, the closure to interpret is on the top of the
- stack. */
-
- /* Use of register here is primarily to make it clear to compilers
- that these entities are non-aliasable.
- */
- register W_* iSp; /* local state -- stack pointer */
- register StgUpdateFrame* iSu; /* local state -- frame pointer */
- register StgPtr iSpLim; /* local state -- stack lim pointer */
- register StgClosure* obj;
+ // Use of register here is primarily to make it clear to compilers
+ // that these entities are non-aliasable.
+ register StgPtr Sp; // local state -- stack pointer
+ register StgPtr SpLim; // local state -- stack lim pointer
+ register StgClosure* obj;
+ nat n, m;
LOAD_STACK_POINTERS;
- /* Main object-entering loop. Object to be entered is on top of
- stack. */
- nextEnter:
+ // ------------------------------------------------------------------------
+ // Case 1:
+ //
+ // We have a closure to evaluate. Stack looks like:
+ //
+ // | XXXX_info |
+ // +---------------+
+ // Sp | -------------------> closure
+ // +---------------+
+ //
+ if (Sp[0] == (W_)&stg_enter_info) {
+ Sp++;
+ goto eval;
+ }
+
+ // ------------------------------------------------------------------------
+ // Case 2:
+ //
+ // We have a BCO application to perform. Stack looks like:
+ //
+ // | .... |
+ // +---------------+
+ // | arg1 |
+ // +---------------+
+ // | BCO |
+ // +---------------+
+ // Sp | RET_BCO |
+ // +---------------+
+ //
+ else if (Sp[0] == (W_)&stg_apply_interp_info) {
+ obj = (StgClosure *)Sp[1];
+ Sp += 2;
+ goto run_BCO_fun;
+ }
+
+ // ------------------------------------------------------------------------
+ // Case 3:
+ //
+ // We have an unboxed value to return. See comment before
+ // do_return_unboxed, below.
+ //
+ else {
+ goto do_return_unboxed;
+ }
+
+ // Evaluate the object on top of the stack.
+eval:
+ obj = (StgClosure*)Sp[0]; Sp++;
+
+eval_obj:
+ INTERP_TICK(it_total_evals);
+
+ IF_DEBUG(interpreter,
+ fprintf(stderr,
+ "\n---------------------------------------------------------------\n");
+ fprintf(stderr,"Evaluating: "); printObj(obj);
+ fprintf(stderr,"Sp = %p\n", Sp);
+ fprintf(stderr, "\n" );
- obj = (StgClosure*)StackWord(0); iSp++;
+ printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ fprintf(stderr, "\n\n");
+ );
- nextEnter_obj:
+ IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
-# ifdef INTERP_STATS
- it_total_entries++;
-# endif
+ switch ( get_itbl(obj)->type ) {
- IF_DEBUG(evaluator,
+ case IND:
+ case IND_OLDGEN:
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ case IND_STATIC:
+ {
+ obj = ((StgInd*)obj)->indirectee;
+ goto eval_obj;
+ }
+
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ case FUN:
+ case FUN_1_0:
+ case FUN_0_1:
+ case FUN_2_0:
+ case FUN_1_1:
+ case FUN_0_2:
+ case FUN_STATIC:
+ case PAP:
+ // already in WHNF
+ break;
+
+ case BCO:
+ ASSERT(BCO_ARITY(obj) > 0);
+ break;
+
+ case AP: /* Copied from stg_AP_entry. */
+ {
+ nat i, words;
+ StgAP *ap;
+
+ ap = (StgAP*)obj;
+ words = ap->n_args;
+
+ // Stack check
+ if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+
+ /* Ok; we're safe. Party on. Push an update frame. */
+ Sp -= sizeofW(StgUpdateFrame);
+ {
+ StgUpdateFrame *__frame;
+ __frame = (StgUpdateFrame *)Sp;
+ SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
+ __frame->updatee = (StgClosure *)(ap);
+ }
+
+ /* Reload the stack */
+ Sp -= words;
+ for (i=0; i < words; i++) {
+ Sp[i] = (W_)ap->payload[i];
+ }
+
+ obj = (StgClosure*)ap->fun;
+ ASSERT(get_itbl(obj)->type == BCO);
+ goto run_BCO_fun;
+ }
+
+ default:
+#ifdef INTERP_STATS
+ {
+ int j;
+
+ j = get_itbl(obj)->type;
+ ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
+ it_unknown_entries[j]++;
+ it_total_unknown_entries++;
+ }
+#endif
+ {
+ // Can't handle this object; yield to scheduler
+ IF_DEBUG(interpreter,
+ fprintf(stderr, "evaluating unknown closure -- yielding to sched\n");
+ printObj(obj);
+ );
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+ }
+ }
+
+ // ------------------------------------------------------------------------
+ // We now have an evaluated object (obj). The next thing to
+ // do is return it to the stack frame on top of the stack.
+do_return:
+ ASSERT(closure_HNF(obj));
+
+ IF_DEBUG(interpreter,
fprintf(stderr,
"\n---------------------------------------------------------------\n");
- fprintf(stderr,"Entering: "); printObj(obj);
- fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu);
+ fprintf(stderr,"Returning: "); printObj(obj);
+ fprintf(stderr,"Sp = %p\n", Sp);
fprintf(stderr, "\n" );
-
- // checkSanity(1);
- // iSp--; StackWord(0) = obj;
- // checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
- // iSp++;
-
- printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
fprintf(stderr, "\n\n");
);
+ IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+
+ switch (get_itbl((StgClosure *)Sp)->type) {
+
+ case RET_SMALL: {
+ const StgInfoTable *info;
+
+ // NOTE: not using get_itbl().
+ info = ((StgClosure *)Sp)->header.info;
+ if (info == (StgInfoTable *)&stg_ap_v_info) {
+ n = 1; m = 0; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_f_info) {
+ n = 1; m = 1; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_d_info) {
+ n = 1; m = sizeofW(StgDouble); goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_l_info) {
+ n = 1; m = sizeofW(StgInt64); goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_n_info) {
+ n = 1; m = 1; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_p_info) {
+ n = 1; m = 1; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_pp_info) {
+ n = 2; m = 2; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_ppp_info) {
+ n = 3; m = 3; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_pppp_info) {
+ n = 4; m = 4; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_ppppp_info) {
+ n = 5; m = 5; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
+ n = 6; m = 6; goto do_apply;
+ }
+ if (info == (StgInfoTable *)&stg_ap_ppppppp_info) {
+ n = 7; m = 7; goto do_apply;
+ }
+ goto do_return_unrecognised;
+ }
+
+ case UPDATE_FRAME:
+ // Returning to an update frame: do the update, pop the update
+ // frame, and continue with the next stack frame.
+ INTERP_TICK(it_retto_UPDATE);
+ UPD_IND(((StgUpdateFrame *)Sp)->updatee, obj);
+ Sp += sizeofW(StgUpdateFrame);
+ goto do_return;
+
+ case RET_BCO:
+ // Returning to an interpreted continuation: put the object on
+ // the stack, and start executing the BCO.
+ INTERP_TICK(it_retto_BCO);
+ Sp--;
+ Sp[0] = (W_)obj;
+ obj = (StgClosure*)Sp[2];
+ ASSERT(get_itbl(obj)->type == BCO);
+ goto run_BCO_return;
+
+ default:
+ do_return_unrecognised:
+ {
+ // Can't handle this return address; yield to scheduler
+ INTERP_TICK(it_retto_other);
+ IF_DEBUG(interpreter,
+ fprintf(stderr, "returning to unknown frame -- yielding to sched\n");
+ printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ );
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+ }
+ }
+
+ // -------------------------------------------------------------------------
+ // Returning an unboxed value. The stack looks like this:
+ //
+ // | .... |
+ // +---------------+
+ // | fv2 |
+ // +---------------+
+ // | fv1 |
+ // +---------------+
+ // | BCO |
+ // +---------------+
+ // | stg_ctoi_ret_ |
+ // +---------------+
+ // | retval |
+ // +---------------+
+ // | XXXX_info |
+ // +---------------+
+ //
+ // where XXXX_info is one of the stg_gc_unbx_r1_info family.
+ //
+ // We're only interested in the case when the real return address
+ // is a BCO; otherwise we'll return to the scheduler.
+
+do_return_unboxed:
+ {
+ int offset;
+
+ ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info
+ || Sp[0] == (W_)&stg_gc_unpt_r1_info
+ || Sp[0] == (W_)&stg_gc_f1_info
+ || Sp[0] == (W_)&stg_gc_d1_info
+ || Sp[0] == (W_)&stg_gc_l1_info
+ || Sp[0] == (W_)&stg_gc_void_info // VoidRep
+ );
+
+ // get the offset of the stg_ctoi_ret_XXX itbl
+ offset = stack_frame_sizeW((StgClosure *)Sp);
+
+ switch (get_itbl((StgClosure *)Sp+offset)->type) {
+
+ case RET_BCO:
+ // Returning to an interpreted continuation: put the object on
+ // the stack, and start executing the BCO.
+ INTERP_TICK(it_retto_BCO);
+ obj = (StgClosure*)Sp[offset+1];
+ ASSERT(get_itbl(obj)->type == BCO);
+ goto run_BCO_return_unboxed;
+
+ default:
+ {
+ // Can't handle this return address; yield to scheduler
+ INTERP_TICK(it_retto_other);
+ IF_DEBUG(interpreter,
+ fprintf(stderr, "returning to unknown frame -- yielding to sched\n");
+ printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ );
+ RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+ }
+ }
+ }
+ // not reached.
+
+
+ // -------------------------------------------------------------------------
+ // Application...
+
+do_apply:
+ // we have a function to apply (obj), and n arguments taking up m
+ // words on the stack. The info table (stg_ap_pp_info or whatever)
+ // is on top of the arguments on the stack.
+ {
+ switch (get_itbl(obj)->type) {
+
+ case PAP: {
+ StgPAP *pap;
+ nat arity, i;
+
+ pap = (StgPAP *)obj;
+
+ // we only cope with PAPs whose function is a BCO
+ if (get_itbl(pap->fun)->type != BCO) {
+ goto defer_apply_to_sched;
+ }
+ Sp++;
+ arity = pap->arity;
+ ASSERT(arity > 0);
+ if (arity < n) {
+ // n must be greater than 1, and the only kinds of
+ // application we support with more than one argument
+ // are all pointers...
+ //
+ // Shuffle the args for this function down, and put
+ // the appropriate info table in the gap.
+ for (i = 0; i < arity; i++) {
+ Sp[i-1] = Sp[i];
+ }
+ Sp[arity-1] = app_ptrs_itbl[n-arity-1];
+ Sp--;
+ // unpack the PAP's arguments onto the stack
+ Sp -= pap->n_args;
+ for (i = 0; i < pap->n_args; i++) {
+ Sp[i] = (W_)pap->payload[i];
+ }
+ obj = pap->fun;
+ goto run_BCO_fun;
+ }
+ else if (arity == n) {
+ Sp -= pap->n_args;
+ for (i = 0; i < pap->n_args; i++) {
+ Sp[i] = (W_)pap->payload[i];
+ }
+ obj = pap->fun;
+ goto run_BCO_fun;
+ }
+ else /* arity > n */ {
+ // build a new PAP and return it.
+ StgPAP *new_pap;
+ nat size;
+ size = PAP_sizeW(pap->n_args + m);
+ new_pap = (StgPAP *)allocate(size);
+ SET_HDR(new_pap,&stg_PAP_info,CCCS);
+ new_pap->arity = pap->arity - n;
+ new_pap->n_args = pap->n_args + m;
+ new_pap->fun = pap->fun;
+ for (i = 0; i < pap->n_args; i++) {
+ new_pap->payload[i] = pap->payload[i];
+ }
+ for (i = 0; i < m; i++) {
+ new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i];
+ }
+ obj = (StgClosure *)new_pap;
+ Sp += m;
+ goto do_return;
+ }
+ }
+
+ case BCO: {
+ nat arity, i;
+
+ Sp++;
+ arity = BCO_ARITY(obj);
+ ASSERT(arity > 0);
+ if (arity < n) {
+ // n must be greater than 1, and the only kinds of
+ // application we support with more than one argument
+ // are all pointers...
+ //
+ // Shuffle the args for this function down, and put
+ // the appropriate info table in the gap.
+ for (i = 0; i < arity; i++) {
+ Sp[i-1] = Sp[i];
+ }
+ Sp[arity-1] = app_ptrs_itbl[n-arity-1];
+ Sp--;
+ goto run_BCO_fun;
+ }
+ else if (arity == n) {
+ goto run_BCO_fun;
+ }
+ else /* arity > n */ {
+ // build a PAP and return it.
+ StgPAP *pap;
+ nat size, i;
+ size = PAP_sizeW(m);
+ pap = (StgPAP *)allocate(size);
+ SET_HDR(pap, &stg_PAP_info,CCCS);
+ pap->arity = arity - n;
+ pap->fun = obj;
+ pap->n_args = m;
+ for (i = 0; i < m; i++) {
+ pap->payload[i] = (StgClosure *)Sp[i];
+ }
+ obj = (StgClosure *)pap;
+ Sp += m;
+ goto do_return;
+ }
+ }
+
+ // No point in us applying machine-code functions
+ default:
+ defer_apply_to_sched:
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+ }
+
+ // ------------------------------------------------------------------------
+ // Ok, we now have a bco (obj), and its arguments are all on the
+ // stack. We can start executing the byte codes.
+ //
+ // The stack is in one of two states. First, if this BCO is a
+ // function:
+ //
+ // | .... |
+ // +---------------+
+ // | arg2 |
+ // +---------------+
+ // | arg1 |
+ // +---------------+
+ //
+ // Second, if this BCO is a continuation:
+ //
+ // | .... |
+ // +---------------+
+ // | fv2 |
+ // +---------------+
+ // | fv1 |
+ // +---------------+
+ // | BCO |
+ // +---------------+
+ // | stg_ctoi_ret_ |
+ // +---------------+
+ // | retval |
+ // +---------------+
+ //
+ // where retval is the value being returned to this continuation.
+ // In the event of a stack check, heap check, or context switch,
+ // we need to leave the stack in a sane state so the garbage
+ // collector can find all the pointers.
+ //
+ // (1) BCO is a function: the BCO's bitmap describes the
+ // pointerhood of the arguments.
+ //
+ // (2) BCO is a continuation: BCO's bitmap describes the
+ // pointerhood of the free variables.
+ //
+ // Sadly we have three different kinds of stack/heap/cswitch check
+ // to do:
+
+run_BCO_return:
+ // Heap check
+ if (doYouWantToGC()) {
+ Sp--; Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
+ }
+
+ // "Standard" stack check
+ if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
+ Sp--; Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+ goto run_BCO;
+
+run_BCO_return_unboxed:
+ // Heap check
+ if (doYouWantToGC()) {
+ RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
+ }
+
+ // "Standard" stack check
+ if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+ goto run_BCO;
+
+run_BCO_fun:
+ IF_DEBUG(sanity,
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_apply_interp_info;
+ checkStackChunk(Sp,SpLim);
+ Sp += 2;
+ );
+
+ // Heap check
+ if (doYouWantToGC()) {
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
+ RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
+ }
+
+ // "Standard" stack check
+ if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+ goto run_BCO;
+
+ // Now, actually interpret the BCO... (no returning to the
+ // scheduler again until the stack is in an orderly state).
+run_BCO:
+ INTERP_TICK(it_BCO_entries);
+ {
+ register int bciPtr = 1; /* instruction pointer */
+ register StgBCO* bco = (StgBCO*)obj;
+ register StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco));
+ register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
+ register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
+ register StgInfoTable** itbls = (StgInfoTable**)
+ (&bco->itbls->payload[0]);
- switch ( get_itbl(obj)->type ) {
+#ifdef INTERP_STATS
+ it_lastopc = 0; /* no opcode */
+#endif
- case INVALID_OBJECT:
- barf("Invalid object %p",(StgPtr)obj);
-
-# ifndef REFERENCE_INTERPRETER
-
- case IND:
- case IND_OLDGEN:
- case IND_PERM:
- case IND_OLDGEN_PERM:
- case IND_STATIC:
- {
- obj = ((StgInd*)obj)->indirectee;
- goto nextEnter_obj;
- }
-
- case CONSTR:
- case CONSTR_1_0:
- case CONSTR_0_1:
- case CONSTR_2_0:
- case CONSTR_1_1:
- case CONSTR_0_2:
- case CONSTR_INTLIKE:
- case CONSTR_CHARLIKE:
- case CONSTR_STATIC:
- case CONSTR_NOCAF_STATIC:
- nextEnter_obj_CONSTR:
- {
- StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0);
- if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) {
-# ifdef INTERP_STATS
- it_retto_BCO++;
-# endif
- /* Returning this constr to a BCO. Push the constr on
- the stack and enter the return continuation BCO, which
- is immediately underneath ret_itbl. */
- StackWord(-1) = (W_)obj;
- obj = (StgClosure*)StackWord(1);
- iSp --;
- if (get_itbl(obj)->type == BCO)
- goto nextEnter_obj_BCO; /* fast-track common case */
- else
- goto nextEnter_obj; /* a safe fallback */
- } else
- if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) {
-# ifdef INTERP_STATS
- it_retto_UPDATE++;
-# endif
- /* Returning this constr to an update frame. Do the
- update and re-enter the constr. */
- ASSERT((W_*)iSu == iSp);
- UPD_IND(iSu->updatee, obj);
- iSu = iSu->link;
- iSp += sizeofW(StgUpdateFrame);
- goto nextEnter_obj_CONSTR;
- }
-# ifdef INTERP_STATS
- else it_retto_other++;
-# endif
- goto defer_to_sched;
- }
-
- case AP_UPD:
- /* Copied from stg_AP_UPD_entry. */
- {
- nat i, words;
- StgAP_UPD *ap = (StgAP_UPD*)obj;
- words = ap->n_args;
-
- /* Stack check. If a stack overflow might occur, don't enter
- the closure; let the scheduler handle it instead. */
- if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim)
- goto defer_to_sched;
-
- /* Ok; we're safe. Party on. Push an update frame. */
- iSp -= sizeofW(StgUpdateFrame);
- {
- StgUpdateFrame *__frame;
- __frame = (StgUpdateFrame *)iSp;
- SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info);
- __frame->link = iSu;
- __frame->updatee = (StgClosure *)(ap);
- iSu = __frame;
- }
-
- /* Reload the stack */
- iSp -= words;
- for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i];
-
- obj = (StgClosure*)ap->fun;
- goto nextEnter_obj;
- }
-
- case PAP:
- /* Copied from stg_PAP_entry. */
- {
- nat words, i;
- StgPAP* pap = (StgPAP *)obj;
-
- /*
- * remove any update frames on the top of the stack, by just
- * performing the update here.
- */
- while ((W_)iSu - (W_)iSp == 0) {
-
- switch (get_itbl(iSu)->type) {
-
- case UPDATE_FRAME:
- /* We're sitting on top of an update frame, so let's
- do the business. */
- UPD_IND(iSu->updatee, pap);
- iSu = iSu->link;
- iSp += sizeofW(StgUpdateFrame);
- continue;
-
- case SEQ_FRAME:
- /* Too complicated ... adopt the Usual Solution. */
- /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */
- goto defer_to_sched;
-
- case CATCH_FRAME:
- /* can't happen, see stg_update_PAP */
- barf("interpretBCO: PAP_entry: CATCH_FRAME");
-
- default:
- barf("interpretBCO: PAP_entry: strange activation record");
- }
- }
-
- words = pap->n_args;
-
- /* Stack check. If a stack overflow might occur, don't enter
- the closure; let the scheduler handle it instead. */
- if (iSp - words < iSpLim)
- goto defer_to_sched;
-
- /* Ok; safe. */
- iSp -= words;
- for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i];
-
- obj = (StgClosure*)pap->fun;
- goto nextEnter_obj;
- }
-
-# endif /* ndef REFERENCE_INTERPRETER */
-
- case BCO:
- /* ---------------------------------------------------- */
- /* Start of the bytecode interpreter */
- /* ---------------------------------------------------- */
- nextEnter_obj_BCO:
-# ifdef INTERP_STATS
- it_BCO_entries++;
-# endif
- {
- int do_print_stack = 1;
- register int bciPtr = 1; /* instruction pointer */
- register StgBCO* bco = (StgBCO*)obj;
- register UShort* instrs = (UShort*)(&bco->instrs->payload[0]);
- register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
- register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
- register StgInfoTable** itbls = (StgInfoTable**)
- (&bco->itbls->payload[0]);
-
- /* Heap check */
- if (doYouWantToGC()) {
- iSp--; StackWord(0) = (W_)bco;
- cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
- RETURN(HeapOverflow);
- }
-
- /* "Standard" stack check */
- if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) {
- iSp--;
- StackWord(0) = (W_)obj;
- cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
- RETURN(StackOverflow);
- }
-
- /* Context-switch check */
- if (context_switch) {
- iSp--;
- StackWord(0) = (W_)obj;
- cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
- RETURN(ThreadYielding);
- }
-
-
-# ifdef INTERP_STATS
- it_lastopc = 0; /* no opcode */
-# endif
-
- nextInsn:
-
- ASSERT(bciPtr <= instrs[0]);
- IF_DEBUG(evaluator,
- //if (do_print_stack) {
- //fprintf(stderr, "\n-- BEGIN stack\n");
- //printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
- //fprintf(stderr, "-- END stack\n\n");
- //}
- do_print_stack = 1;
- fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr);
- disInstr(bco,bciPtr);
- if (0) { int i;
- fprintf(stderr,"\n");
- for (i = 8; i >= 0; i--)
- fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i)));
- fprintf(stderr,"\n");
- }
- //if (do_print_stack) checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
- );
-
-# ifdef INTERP_STATS
- it_insns++;
- ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
- it_ofreq[ (int)instrs[bciPtr] ] ++;
- it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
- it_lastopc = (int)instrs[bciPtr];
-# endif
-
- switch (BCO_NEXT) {
-
- case bci_STKCHECK: {
- /* An explicit stack check; we hope these will be
- rare. */
- int stk_words_reqd = BCO_NEXT + 1;
- if (iSp - stk_words_reqd < iSpLim) {
- iSp--;
- StackWord(0) = (W_)obj;
- cap->r.rCurrentTSO->what_next = ThreadEnterInterp;
- RETURN(StackOverflow);
- }
- goto nextInsn;
- }
- case bci_ARGCHECK: {
- int i;
- StgPAP* pap;
- int arg_words_reqd = BCO_NEXT;
- int arg_words_avail = ((W_*)iSu) - ((W_*)iSp);
- if (arg_words_avail >= arg_words_reqd) goto nextInsn;
-
-# ifndef REFERENCE_INTERPRETER
-
- /* Optimisation: if there are no args avail and the
- t-o-s is an update frame, do the update, and
- re-enter the object. */
- if (arg_words_avail == 0
- && get_itbl(iSu)->type == UPDATE_FRAME) {
- UPD_IND(iSu->updatee, obj);
- iSu = iSu->link;
- iSp += sizeofW(StgUpdateFrame);
- goto nextEnter_obj_BCO;
+ nextInsn:
+ ASSERT(bciPtr <= instrs[0]);
+ IF_DEBUG(interpreter,
+ //if (do_print_stack) {
+ //fprintf(stderr, "\n-- BEGIN stack\n");
+ //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
+ //fprintf(stderr, "-- END stack\n\n");
+ //}
+ fprintf(stderr,"Sp = %p pc = %d ", Sp, bciPtr);
+ disInstr(bco,bciPtr);
+ if (0) { int i;
+ fprintf(stderr,"\n");
+ for (i = 8; i >= 0; i--) {
+ fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i)));
+ }
+ fprintf(stderr,"\n");
}
+ //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
+ );
-# endif /* ndef REFERENCE_INTERPRETER */
-
- /* Handle arg check failure. General case: copy the
- spare args into a PAP frame. */
- pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail));
- SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/);
- pap->n_args = arg_words_avail;
- pap->fun = obj;
- for (i = 0; i < arg_words_avail; i++)
- pap->payload[i] = (StgClosure*)StackWord(i);
-
- /* Push on the stack and defer to the scheduler. */
- iSp = (StgPtr)iSu;
- iSp --;
- StackWord(0) = (W_)pap;
- IF_DEBUG(evaluator,
- fprintf(stderr,"\tBuilt ");
- printObj((StgClosure*)pap);
- );
- cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
- RETURN(ThreadYielding);
- }
- case bci_PUSH_L: {
- int o1 = BCO_NEXT;
- ASSERT((W_*)iSp+o1 < (W_*)iSu);
- StackWord(-1) = StackWord(o1);
- iSp--;
- do_print_stack = 0;
- goto nextInsn;
- }
- case bci_PUSH_LL: {
- int o1 = BCO_NEXT;
- int o2 = BCO_NEXT;
- ASSERT((W_*)iSp+o1 < (W_*)iSu);
- ASSERT((W_*)iSp+o2 < (W_*)iSu);
- StackWord(-1) = StackWord(o1);
- StackWord(-2) = StackWord(o2);
- iSp -= 2;
- goto nextInsn;
- }
- case bci_PUSH_LLL: {
- int o1 = BCO_NEXT;
- int o2 = BCO_NEXT;
- int o3 = BCO_NEXT;
- ASSERT((W_*)iSp+o1 < (W_*)iSu);
- ASSERT((W_*)iSp+o2 < (W_*)iSu);
- ASSERT((W_*)iSp+o3 < (W_*)iSu);
- StackWord(-1) = StackWord(o1);
- StackWord(-2) = StackWord(o2);
- StackWord(-3) = StackWord(o3);
- iSp -= 3;
- goto nextInsn;
- }
- case bci_PUSH_G: {
- int o1 = BCO_NEXT;
- StackWord(-1) = BCO_PTR(o1);
- iSp -= 1;
- goto nextInsn;
- }
- case bci_PUSH_AS: {
- int o_bco = BCO_NEXT;
- int o_itbl = BCO_NEXT;
- StackWord(-2) = BCO_LIT(o_itbl);
- StackWord(-1) = BCO_PTR(o_bco);
- iSp -= 2;
- goto nextInsn;
- }
- case bci_PUSH_UBX: {
- int i;
- int o_lits = BCO_NEXT;
- int n_words = BCO_NEXT;
- iSp -= n_words;
- for (i = 0; i < n_words; i++)
- StackWord(i) = BCO_LIT(o_lits+i);
- do_print_stack = 0;
- goto nextInsn;
- }
- case bci_PUSH_TAG: {
- W_ tag = (W_)(BCO_NEXT);
- StackWord(-1) = tag;
- iSp --;
- goto nextInsn;
- }
- case bci_SLIDE: {
- int n = BCO_NEXT;
- int by = BCO_NEXT;
- ASSERT((W_*)iSp+n+by <= (W_*)iSu);
- /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
- while(--n >= 0) {
- StackWord(n+by) = StackWord(n);
- }
- iSp += by;
-# ifdef INTERP_STATS
- it_slides++;
-# endif
- goto nextInsn;
- }
- case bci_ALLOC: {
- StgAP_UPD* ap;
- int n_payload = BCO_NEXT - 1;
- int request = AP_sizeW(n_payload);
- ap = (StgAP_UPD*)allocate_UPD(request);
- StackWord(-1) = (W_)ap;
- ap->n_args = n_payload;
- SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/)
- iSp --;
- goto nextInsn;
- }
- case bci_MKAP: {
- int i;
- int stkoff = BCO_NEXT;
- int n_payload = BCO_NEXT - 1;
- StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff);
- ASSERT((int)ap->n_args == n_payload);
- ap->fun = (StgClosure*)StackWord(0);
- for (i = 0; i < n_payload; i++)
- ap->payload[i] = (StgClosure*)StackWord(i+1);
- iSp += n_payload+1;
- IF_DEBUG(evaluator,
- fprintf(stderr,"\tBuilt ");
- printObj((StgClosure*)ap);
- );
- goto nextInsn;
- }
- case bci_UNPACK: {
- /* Unpack N ptr words from t.o.s constructor */
- /* The common case ! */
- int i;
- int n_words = BCO_NEXT;
- StgClosure* con = (StgClosure*)StackWord(0);
- iSp -= n_words;
- for (i = 0; i < n_words; i++)
- StackWord(i) = (W_)con->payload[i];
- goto nextInsn;
- }
- case bci_UPK_TAG: {
- /* Unpack N (non-ptr) words from offset M in the
- constructor K words down the stack, and then push
- N as a tag, on top of it. Slow but general; we
- hope it will be the rare case. */
- int i;
- int n_words = BCO_NEXT;
- int con_off = BCO_NEXT;
- int stk_off = BCO_NEXT;
- StgClosure* con = (StgClosure*)StackWord(stk_off);
- iSp -= n_words;
- for (i = 0; i < n_words; i++)
- StackWord(i) = (W_)con->payload[con_off + i];
- iSp --;
- StackWord(0) = n_words;
- goto nextInsn;
- }
- case bci_PACK: {
- int i;
- int o_itbl = BCO_NEXT;
- int n_words = BCO_NEXT;
- StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
- int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
- itbl->layout.payload.nptrs );
- StgClosure* con = (StgClosure*)allocate_NONUPD(request);
- ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
- SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
- for (i = 0; i < n_words; i++)
- con->payload[i] = (StgClosure*)StackWord(i);
- iSp += n_words;
- iSp --;
- StackWord(0) = (W_)con;
- IF_DEBUG(evaluator,
- fprintf(stderr,"\tBuilt ");
- printObj((StgClosure*)con);
- );
- goto nextInsn;
- }
- case bci_TESTLT_P: {
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgClosure* con = (StgClosure*)StackWord(0);
- if (constrTag(con) >= discr)
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTEQ_P: {
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgClosure* con = (StgClosure*)StackWord(0);
- if (constrTag(con) != discr)
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTLT_I: {
- /* The top thing on the stack should be a tagged int. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- I_ stackInt = (I_)StackWord(1);
- ASSERT(1 == StackWord(0));
- if (stackInt >= (I_)BCO_LIT(discr))
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTEQ_I: {
- /* The top thing on the stack should be a tagged int. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- I_ stackInt = (I_)StackWord(1);
- ASSERT(1 == StackWord(0));
- if (stackInt != (I_)BCO_LIT(discr))
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTLT_D: {
- /* The top thing on the stack should be a tagged double. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgDouble stackDbl, discrDbl;
- ASSERT(sizeofW(StgDouble) == StackWord(0));
- stackDbl = PK_DBL( & StackWord(1) );
- discrDbl = PK_DBL( & BCO_LIT(discr) );
- if (stackDbl >= discrDbl)
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTEQ_D: {
- /* The top thing on the stack should be a tagged double. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgDouble stackDbl, discrDbl;
- ASSERT(sizeofW(StgDouble) == StackWord(0));
- stackDbl = PK_DBL( & StackWord(1) );
- discrDbl = PK_DBL( & BCO_LIT(discr) );
- if (stackDbl != discrDbl)
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTLT_F: {
- /* The top thing on the stack should be a tagged float. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgFloat stackFlt, discrFlt;
- ASSERT(sizeofW(StgFloat) == StackWord(0));
- stackFlt = PK_FLT( & StackWord(1) );
- discrFlt = PK_FLT( & BCO_LIT(discr) );
- if (stackFlt >= discrFlt)
- bciPtr = failto;
- goto nextInsn;
- }
- case bci_TESTEQ_F: {
- /* The top thing on the stack should be a tagged float. */
- int discr = BCO_NEXT;
- int failto = BCO_NEXT;
- StgFloat stackFlt, discrFlt;
- ASSERT(sizeofW(StgFloat) == StackWord(0));
- stackFlt = PK_FLT( & StackWord(1) );
- discrFlt = PK_FLT( & BCO_LIT(discr) );
- if (stackFlt != discrFlt)
- bciPtr = failto;
- goto nextInsn;
- }
-
- /* Control-flow ish things */
- case bci_ENTER: {
- goto nextEnter;
- }
- case bci_RETURN: {
- /* Figure out whether returning to interpreted or
- compiled code. */
- int o_itoc_itbl = BCO_NEXT;
- int tag = StackWord(0);
- StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1);
- ASSERT(tag <= 2); /* say ... */
- if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info
- || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info
- || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info
- || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info
- || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) {
- /* Returning to interpreted code. Interpret the BCO
- immediately underneath the itbl. */
- StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1);
- iSp --;
- StackWord(0) = (W_)ret_bco;
- goto nextEnter;
- } else {
- /* Returning (unboxed value) to compiled code.
- Replace tag with a suitable itbl and ask the
- scheduler to run it. The itbl code will copy
- the TOS value into R1/F1/D1 and do a standard
- compiled-code return. */
- StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl);
- if (magic_itbl != NULL) {
- StackWord(0) = (W_)magic_itbl;
- cap->r.rCurrentTSO->what_next = ThreadRunGHC;
- RETURN(ThreadYielding);
- } else {
- /* Special case -- returning a VoidRep to
- compiled code. T.O.S is the VoidRep tag,
- and underneath is the return itbl. Zap the
- tag and enter the itbl. */
- ASSERT(StackWord(0) == (W_)NULL);
- iSp ++;
- cap->r.rCurrentTSO->what_next = ThreadRunGHC;
- RETURN(ThreadYielding);
- }
- }
- }
- case bci_SWIZZLE: {
- int stkoff = BCO_NEXT;
- signed short n = (signed short)(BCO_NEXT);
- StackWord(stkoff) += (W_)n;
- goto nextInsn;
- }
- case bci_CCALL: {
- StgInt tok;
- int o_itbl = BCO_NEXT;
- void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
- SAVE_STACK_POINTERS;
- tok = suspendThread(&cap->r,rtsFalse);
- marshall_fn ( (void*)(& StackWord(0) ) );
- cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable));
- LOAD_STACK_POINTERS;
- goto nextInsn;
- }
- case bci_JMP: {
- /* BCO_NEXT modifies bciPtr, so be conservative. */
- int nextpc = BCO_NEXT;
- bciPtr = nextpc;
- goto nextInsn;
- }
- case bci_CASEFAIL:
- barf("interpretBCO: hit a CASEFAIL");
-
- /* Errors */
- default:
- barf("interpretBCO: unknown or unimplemented opcode");
-
- } /* switch on opcode */
-
- barf("interpretBCO: fell off end of insn loop");
-
- }
- /* ---------------------------------------------------- */
- /* End of the bytecode interpreter */
- /* ---------------------------------------------------- */
-
- defer_to_sched:
- default: {
-# ifdef INTERP_STATS
- { int j = get_itbl(obj)->type;
- ASSERT(j >= 0 && j < N_CLOSURE_TYPES);
- it_unknown_entries[j]++;
- it_total_unknown_entries++;
- }
-# endif
-
- /* Can't handle this object; yield to sched. */
- IF_DEBUG(evaluator,
- fprintf(stderr, "entering unknown closure -- yielding to sched\n");
- printObj(obj);
- );
- iSp--; StackWord(0) = (W_)obj;
- cap->r.rCurrentTSO->what_next = ThreadEnterGHC;
- RETURN(ThreadYielding);
- }
- } /* switch on object kind */
-
- barf("fallen off end of object-type switch in interpretBCO()");
+ INTERP_TICK(it_insns);
+
+#ifdef INTERP_STATS
+ ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
+ it_ofreq[ (int)instrs[bciPtr] ] ++;
+ it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
+ it_lastopc = (int)instrs[bciPtr];
+#endif
+
+ switch (BCO_NEXT) {
+
+ case bci_STKCHECK:
+ {
+ // An explicit stack check; we hope these will be rare.
+ int stk_words_reqd = BCO_NEXT + 1;
+ if (Sp - stk_words_reqd < SpLim) {
+ Sp--; Sp[0] = (W_)obj;
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+ goto nextInsn;
+ }
+
+ case bci_PUSH_L: {
+ int o1 = BCO_NEXT;
+ Sp[-1] = Sp[o1];
+ Sp--;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_LL: {
+ int o1 = BCO_NEXT;
+ int o2 = BCO_NEXT;
+ Sp[-1] = Sp[o1];
+ Sp[-2] = Sp[o2];
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_LLL: {
+ int o1 = BCO_NEXT;
+ int o2 = BCO_NEXT;
+ int o3 = BCO_NEXT;
+ Sp[-1] = Sp[o1];
+ Sp[-2] = Sp[o2];
+ Sp[-3] = Sp[o3];
+ Sp -= 3;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_G: {
+ int o1 = BCO_NEXT;
+ Sp[-1] = BCO_PTR(o1);
+ Sp -= 1;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_R1p_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_P: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_R1unpt_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_N: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_R1n_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_F: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_F1_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_D: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_D1_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_L: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_L1_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_ALTS_V: {
+ int o_bco = BCO_NEXT;
+ Sp[-2] = (W_)&stg_ctoi_ret_V_info;
+ Sp[-1] = BCO_PTR(o_bco);
+ Sp -= 2;
+ goto nextInsn;
+ }
+
+ case bci_PUSH_APPLY_N:
+ Sp--; Sp[0] = (W_)&stg_ap_n_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_V:
+ Sp--; Sp[0] = (W_)&stg_ap_v_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_F:
+ Sp--; Sp[0] = (W_)&stg_ap_f_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_D:
+ Sp--; Sp[0] = (W_)&stg_ap_d_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_L:
+ Sp--; Sp[0] = (W_)&stg_ap_l_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_P:
+ Sp--; Sp[0] = (W_)&stg_ap_p_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PP:
+ Sp--; Sp[0] = (W_)&stg_ap_pp_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PPP:
+ Sp--; Sp[0] = (W_)&stg_ap_ppp_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PPPP:
+ Sp--; Sp[0] = (W_)&stg_ap_pppp_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PPPPP:
+ Sp--; Sp[0] = (W_)&stg_ap_ppppp_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PPPPPP:
+ Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
+ goto nextInsn;
+ case bci_PUSH_APPLY_PPPPPPP:
+ Sp--; Sp[0] = (W_)&stg_ap_ppppppp_info;
+ goto nextInsn;
+
+ case bci_PUSH_UBX: {
+ int i;
+ int o_lits = BCO_NEXT;
+ int n_words = BCO_NEXT;
+ Sp -= n_words;
+ for (i = 0; i < n_words; i++) {
+ Sp[i] = BCO_LIT(o_lits+i);
+ }
+ goto nextInsn;
+ }
+
+ case bci_SLIDE: {
+ int n = BCO_NEXT;
+ int by = BCO_NEXT;
+ /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
+ while(--n >= 0) {
+ Sp[n+by] = Sp[n];
+ }
+ Sp += by;
+ INTERP_TICK(it_slides);
+ goto nextInsn;
+ }
+
+ case bci_ALLOC_AP: {
+ StgAP* ap;
+ int n_payload = BCO_NEXT - 1;
+ int request = PAP_sizeW(n_payload);
+ ap = (StgAP*)allocate_UPD(request);
+ Sp[-1] = (W_)ap;
+ ap->n_args = n_payload;
+ SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
+ Sp --;
+ goto nextInsn;
+ }
+
+ case bci_ALLOC_PAP: {
+ StgPAP* pap;
+ int arity = BCO_NEXT;
+ int n_payload = BCO_NEXT - 1;
+ int request = PAP_sizeW(n_payload);
+ pap = (StgPAP*)allocate_NONUPD(request);
+ Sp[-1] = (W_)pap;
+ pap->n_args = n_payload;
+ pap->arity = arity;
+ SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
+ Sp --;
+ goto nextInsn;
+ }
+
+ case bci_MKAP: {
+ int i;
+ int stkoff = BCO_NEXT;
+ int n_payload = BCO_NEXT - 1;
+ StgAP* ap = (StgAP*)Sp[stkoff];
+ ASSERT((int)ap->n_args == n_payload);
+ ap->fun = (StgClosure*)Sp[0];
+
+ // The function should be a BCO, and its bitmap should
+ // cover the payload of the AP correctly.
+ ASSERT(get_itbl(ap->fun)->type == BCO
+ && (get_itbl(ap)->type == PAP ||
+ BCO_BITMAP_SIZE(ap->fun) == ap->n_args));
+
+ for (i = 0; i < n_payload; i++)
+ ap->payload[i] = (StgClosure*)Sp[i+1];
+ Sp += n_payload+1;
+ IF_DEBUG(interpreter,
+ fprintf(stderr,"\tBuilt ");
+ printObj((StgClosure*)ap);
+ );
+ goto nextInsn;
+ }
+
+ case bci_UNPACK: {
+ /* Unpack N ptr words from t.o.s constructor */
+ int i;
+ int n_words = BCO_NEXT;
+ StgClosure* con = (StgClosure*)Sp[0];
+ Sp -= n_words;
+ for (i = 0; i < n_words; i++) {
+ Sp[i] = (W_)con->payload[i];
+ }
+ goto nextInsn;
+ }
+
+ case bci_PACK: {
+ int i;
+ int o_itbl = BCO_NEXT;
+ int n_words = BCO_NEXT;
+ StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl));
+ int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
+ itbl->layout.payload.nptrs );
+ StgClosure* con = (StgClosure*)allocate_NONUPD(request);
+ ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
+ SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/);
+ for (i = 0; i < n_words; i++) {
+ con->payload[i] = (StgClosure*)Sp[i];
+ }
+ Sp += n_words;
+ Sp --;
+ Sp[0] = (W_)con;
+ IF_DEBUG(interpreter,
+ fprintf(stderr,"\tBuilt ");
+ printObj((StgClosure*)con);
+ );
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_P: {
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgClosure* con = (StgClosure*)Sp[0];
+ if (constrTag(con) >= discr) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_P: {
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgClosure* con = (StgClosure*)Sp[0];
+ if (constrTag(con) != discr) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_I: {
+ // There should be an Int at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ I_ stackInt = (I_)Sp[1];
+ if (stackInt >= (I_)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_I: {
+ // There should be an Int at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ I_ stackInt = (I_)Sp[1];
+ if (stackInt != (I_)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_D: {
+ // There should be a Double at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgDouble stackDbl, discrDbl;
+ stackDbl = PK_DBL( & Sp[1] );
+ discrDbl = PK_DBL( & BCO_LIT(discr) );
+ if (stackDbl >= discrDbl) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_D: {
+ // There should be a Double at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgDouble stackDbl, discrDbl;
+ stackDbl = PK_DBL( & Sp[1] );
+ discrDbl = PK_DBL( & BCO_LIT(discr) );
+ if (stackDbl != discrDbl) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTLT_F: {
+ // There should be a Float at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgFloat stackFlt, discrFlt;
+ stackFlt = PK_FLT( & Sp[1] );
+ discrFlt = PK_FLT( & BCO_LIT(discr) );
+ if (stackFlt >= discrFlt) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_F: {
+ // There should be a Float at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_NEXT;
+ StgFloat stackFlt, discrFlt;
+ stackFlt = PK_FLT( & Sp[1] );
+ discrFlt = PK_FLT( & BCO_LIT(discr) );
+ if (stackFlt != discrFlt) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
+ // Control-flow ish things
+ case bci_ENTER:
+ // Context-switch check. We put it here to ensure that
+ // the interpreter has done at least *some* work before
+ // context switching: sometimes the scheduler can invoke
+ // the interpreter with context_switch == 1, particularly
+ // if the -C0 flag has been given on the cmd line.
+ if (context_switch) {
+ Sp--; Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
+ }
+ goto eval;
+
+ case bci_RETURN:
+ obj = (StgClosure *)Sp[0];
+ Sp++;
+ goto do_return;
+
+ case bci_RETURN_P:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_unpt_r1_info;
+ goto do_return_unboxed;
+ case bci_RETURN_N:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_unbx_r1_info;
+ goto do_return_unboxed;
+ case bci_RETURN_F:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_f1_info;
+ goto do_return_unboxed;
+ case bci_RETURN_D:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_d1_info;
+ goto do_return_unboxed;
+ case bci_RETURN_L:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_l1_info;
+ goto do_return_unboxed;
+ case bci_RETURN_V:
+ Sp--;
+ Sp[0] = (W_)&stg_gc_void_info;
+ goto do_return_unboxed;
+
+ case bci_SWIZZLE: {
+ int stkoff = BCO_NEXT;
+ signed short n = (signed short)(BCO_NEXT);
+ Sp[stkoff] += (W_)n;
+ goto nextInsn;
+ }
+
+ case bci_CCALL: {
+ StgInt tok;
+ int stk_offset = BCO_NEXT;
+ int o_itbl = BCO_NEXT;
+ void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
+
+ // Shift the stack pointer down to the next relevant stack
+ // frame during the call. See comment in ByteCodeGen.lhs.
+ Sp += stk_offset;
+ SAVE_STACK_POINTERS;
+ tok = suspendThread(&cap->r,rtsFalse);
+ marshall_fn ( (void*)(& Sp[-stk_offset] ) );
+ cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable));
+ LOAD_STACK_POINTERS;
+ Sp -= stk_offset;
+ goto nextInsn;
+ }
+
+ case bci_JMP: {
+ /* BCO_NEXT modifies bciPtr, so be conservative. */
+ int nextpc = BCO_NEXT;
+ bciPtr = nextpc;
+ goto nextInsn;
+ }
+
+ case bci_CASEFAIL:
+ barf("interpretBCO: hit a CASEFAIL");
+
+ // Errors
+ default:
+ barf("interpretBCO: unknown or unimplemented opcode");
+
+ } /* switch on opcode */
+ }
+ }
+
+ barf("interpretBCO: fell off end of the interpreter");
}
-
/* -----------------------------------------------------------------------------
- * $Id: Interpreter.h,v 1.3 2001/02/12 04:55:33 chak Exp $
+ * $Id: Interpreter.h,v 1.4 2002/12/11 15:36:42 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000.
+ * (c) The GHC Team, 1998-2002.
*
* Prototypes for functions in Interpreter.c
*
* ---------------------------------------------------------------------------*/
-extern StgThreadReturnCode interpretBCO ( Capability* cap );
-
-typedef unsigned short UShort;
-
-#if 0
-/* --------------------------------------------------------------------------
- * Sizes of objects it constructs
- * (used by Assembler)
- * ------------------------------------------------------------------------*/
-
-#define Izh_sizeW CONSTR_sizeW(0,sizeofW(StgInt))
-#define I64zh_sizeW CONSTR_sizeW(0,sizeofW(StgInt64))
-#define Wzh_sizeW CONSTR_sizeW(0,sizeofW(StgWord))
-#define Azh_sizeW CONSTR_sizeW(0,sizeofW(StgAddr))
-#define Czh_sizeW CONSTR_sizeW(0,sizeofW(StgWord))
-#define Fzh_sizeW CONSTR_sizeW(0,sizeofW(StgFloat))
-#define Dzh_sizeW CONSTR_sizeW(0,sizeofW(StgDouble))
-#define Stablezh_sizeW CONSTR_sizeW(0,sizeofW(StgStablePtr))
-#define Genericzh_sizeW CONSTR_sizeW(1,0)
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-
-extern nat marshall ( char arg_ty, void* arg );
-extern nat unmarshall ( char res_ty, void* res );
-extern nat argSize ( const char* ks );
-
-
-extern StgInt PopTaggedInt ( void ) ;
-extern StgWord PopTaggedWord ( void ) ;
-extern StgAddr PopTaggedAddr ( void ) ;
-extern StgStablePtr PopTaggedStablePtr ( void ) ;
-extern StgChar PopTaggedChar ( void ) ;
-extern StgFloat PopTaggedFloat ( void ) ;
-extern StgDouble PopTaggedDouble ( void ) ;
-
-extern void PushTaggedInt ( StgInt );
-extern void PushTaggedWord ( StgWord );
-extern void PushTaggedAddr ( StgAddr );
-extern void PushTaggedStablePtr ( StgStablePtr );
-extern void PushTaggedChar ( StgChar );
-extern void PushTaggedFloat ( StgFloat );
-extern void PushTaggedDouble ( StgDouble );
-
-extern void PushPtr ( StgPtr );
-extern StgPtr PopPtr ( void );
-
-extern int numEnters;
-
-/*-------------------------------------------------------------------------*/
-#ifdef XMLAMBDA
-
-#define MAX_CALL_VALUES 100
+#ifndef INTERPRETER_H
+#define INTERPRETER_H
-/* Self contained CallInfo structure for the i_ccall instruction */
-typedef struct _CallInfo {
- unsigned int argCount;
- unsigned int resultCount;
- char callConv; /* 's'=stdcall, 'c'=ccall */
-
-/* The strings arg_tys and result_tys reside here.
- This allows us to put the complete CallInfo in the nonptrwords of a BCO */
- char data[MAX_CALL_VALUES+2];
-} CallInfo;
+extern StgThreadReturnCode interpretBCO (Capability* cap);
-#endif
-#endif
+#endif // INTERPRETER_H
/* -----------------------------------------------------------------------------
- * $Id: LdvProfile.c,v 1.2 2001/11/26 16:54:21 simonmar Exp $
+ * $Id: LdvProfile.c,v 1.3 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team, 2001
* Author: Sungwoo Park
#include "RtsUtils.h"
#include "Schedule.h"
-// ldvTimeSave is set in LdvCensusKillAll(), and stores the final number of
-// times that LDV profiling was proformed.
-static nat ldvTimeSave;
-
/* --------------------------------------------------------------------------
* Fills in the slop when a *dynamic* closure changes its type.
* First calls LDV_recordDead() to declare the closure is dead, and then
void
LDV_recordDead_FILL_SLOP_DYNAMIC( StgClosure *p )
{
+ StgInfoTable *info;
+ nat nw, i;
+
if (era > 0) {
- StgInfoTable *inf = get_itbl((p));
- nat nw, i;
- switch (inf->type) {
+ info = get_itbl((p));
+ switch (info->type) {
case THUNK_1_0:
case THUNK_0_1:
case THUNK_2_0:
nw = MIN_UPD_SIZE;
break;
case THUNK:
- nw = inf->layout.payload.ptrs + inf->layout.payload.nptrs;
+ nw = info->layout.payload.ptrs + info->layout.payload.nptrs;
if (nw < MIN_UPD_SIZE)
nw = MIN_UPD_SIZE;
break;
- case AP_UPD:
+ case AP:
nw = sizeofW(StgPAP) - sizeofW(StgHeader) + ((StgPAP *)p)->n_args;
break;
+ case AP_STACK:
+ nw = sizeofW(StgAP_STACK) - sizeofW(StgHeader)
+ + ((StgAP_STACK *)p)->size;
+ break;
case CAF_BLACKHOLE:
case BLACKHOLE:
case SE_BLACKHOLE:
case SE_CAF_BLACKHOLE:
- nw = inf->layout.payload.ptrs + inf->layout.payload.nptrs;
+ nw = info->layout.payload.ptrs + info->layout.payload.nptrs;
break;
default:
- barf("Unexpected closure type %u in LDV_recordDead_FILL_SLOP_DYNAMIC()", inf->type);
+ barf("Unexpected closure type %u in LDV_recordDead_FILL_SLOP_DYNAMIC()", info->type);
break;
}
LDV_recordDead((StgClosure *)(p), nw + sizeofW(StgHeader));
size = sizeofW(StgHeader) + MIN_UPD_SIZE;
break;
- case AP_UPD:
+ case AP:
case PAP:
size = pap_sizeW((StgPAP *)c);
break;
+ case AP_STACK:
+ size = ap_stack_sizeW((StgAP_STACK *)c);
+ break;
+
case CONSTR:
case CONSTR_1_0:
case CONSTR_0_1:
case UPDATE_FRAME:
case CATCH_FRAME:
case STOP_FRAME:
- case SEQ_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
/* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.106 2002/10/23 08:52:26 simonmar Exp $
+ * $Id: Linker.c,v 1.107 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team, 2000, 2001
*
/* Hash table mapping symbol names to Symbol */
static /*Str*/HashTable *symhash;
+/* List of currently loaded objects */
+ObjectCode *objects = NULL; /* initially empty */
+
#if defined(OBJFORMAT_ELF)
static int ocVerifyImage_ELF ( ObjectCode* oc );
static int ocGetNames_ELF ( ObjectCode* oc );
Maybe_Stable_Names \
Sym(StgReturn) \
Sym(init_stack) \
- SymX(__stg_chk_0) \
- SymX(__stg_chk_1) \
- SymX(stg_chk_2) \
- SymX(stg_chk_3) \
- SymX(stg_chk_4) \
- SymX(stg_chk_5) \
- SymX(stg_chk_6) \
- SymX(stg_chk_7) \
- SymX(stg_chk_8) \
- Sym(stg_enterStackTop) \
- SymX(stg_gc_d1) \
- SymX(stg_gc_l1) \
+ SymX(stg_enter_info) \
+ SymX(stg_enter_ret) \
+ SymX(stg_gc_void_info) \
SymX(__stg_gc_enter_1) \
- SymX(stg_gc_enter_2) \
- SymX(stg_gc_enter_3) \
- SymX(stg_gc_enter_4) \
- SymX(stg_gc_enter_5) \
- SymX(stg_gc_enter_6) \
- SymX(stg_gc_enter_7) \
- SymX(stg_gc_enter_8) \
- SymX(stg_gc_f1) \
SymX(stg_gc_noregs) \
- SymX(stg_gc_seq_1) \
- SymX(stg_gc_unbx_r1) \
+ SymX(stg_gc_unpt_r1_info) \
SymX(stg_gc_unpt_r1) \
- SymX(stg_gc_ut_0_1) \
- SymX(stg_gc_ut_1_0) \
- SymX(stg_gen_chk) \
+ SymX(stg_gc_unbx_r1_info) \
+ SymX(stg_gc_unbx_r1) \
+ SymX(stg_gc_f1_info) \
+ SymX(stg_gc_f1) \
+ SymX(stg_gc_d1_info) \
+ SymX(stg_gc_d1) \
+ SymX(stg_gc_l1_info) \
+ SymX(stg_gc_l1) \
+ SymX(__stg_gc_fun) \
+ SymX(stg_gc_fun_info) \
+ SymX(stg_gc_fun_ret) \
+ SymX(stg_gc_gen) \
+ SymX(stg_gc_gen_info) \
+ SymX(stg_gc_gen_hp) \
+ SymX(stg_gc_ut) \
+ SymX(stg_gen_yield) \
+ SymX(stg_yield_noregs) \
SymX(stg_yield_to_interpreter) \
+ SymX(stg_gen_block) \
+ SymX(stg_block_noregs) \
+ SymX(stg_block_1) \
+ SymX(stg_block_takemvar) \
+ SymX(stg_block_putmvar) \
+ SymX(stg_seq_frame_info) \
SymX(ErrorHdrHook) \
MAIN_CAP_SYM \
SymX(MallocFailHook) \
SymX(stg_INTLIKE_closure) \
SymX(stg_MUT_ARR_PTRS_FROZEN_info) \
SymX(stg_WEAK_info) \
+ SymX(stg_ap_v_info) \
+ SymX(stg_ap_f_info) \
+ SymX(stg_ap_d_info) \
+ SymX(stg_ap_l_info) \
+ SymX(stg_ap_n_info) \
+ SymX(stg_ap_p_info) \
+ SymX(stg_ap_pv_info) \
+ SymX(stg_ap_pp_info) \
+ SymX(stg_ap_ppv_info) \
+ SymX(stg_ap_ppp_info) \
+ SymX(stg_ap_pppp_info) \
+ SymX(stg_ap_ppppp_info) \
+ SymX(stg_ap_pppppp_info) \
+ SymX(stg_ap_ppppppp_info) \
+ SymX(stg_ap_0_ret) \
+ SymX(stg_ap_v_ret) \
+ SymX(stg_ap_f_ret) \
+ SymX(stg_ap_d_ret) \
+ SymX(stg_ap_l_ret) \
+ SymX(stg_ap_n_ret) \
+ SymX(stg_ap_p_ret) \
+ SymX(stg_ap_pv_ret) \
+ SymX(stg_ap_pp_ret) \
+ SymX(stg_ap_ppv_ret) \
+ SymX(stg_ap_ppp_ret) \
+ SymX(stg_ap_pppp_ret) \
+ SymX(stg_ap_ppppp_ret) \
+ SymX(stg_ap_pppppp_ret) \
+ SymX(stg_ap_ppppppp_ret) \
SymX(stg_ap_1_upd_info) \
SymX(stg_ap_2_upd_info) \
SymX(stg_ap_3_upd_info) \
SymX(stg_sel_7_upd_info) \
SymX(stg_sel_8_upd_info) \
SymX(stg_sel_9_upd_info) \
- SymX(stg_seq_frame_info) \
SymX(stg_upd_frame_info) \
- SymX(__stg_update_PAP) \
SymX(suspendThread) \
SymX(takeMVarzh_fast) \
SymX(timesIntegerzh_fast) \
for (i = 0; i < oc->n_symbols; i++) {
sym = oc->symbols[i];
if (sym == NULL) continue;
- /* fprintf(stderr, "enquire %p %p\n", sym, oc->lochash); */
+ // fprintf(stderr, "enquire %p %p\n", sym, oc->lochash);
a = NULL;
- if (oc->lochash != NULL)
+ if (oc->lochash != NULL) {
a = lookupStrHashTable(oc->lochash, sym);
- if (a == NULL)
+ }
+ if (a == NULL) {
a = lookupStrHashTable(symhash, sym);
+ }
if (a == NULL) {
- /* fprintf(stderr, "ghci_enquire: can't find %s\n", sym); */
+ // fprintf(stderr, "ghci_enquire: can't find %s\n", sym);
}
else if (addr-DELTA <= a && a <= addr+DELTA) {
fprintf(stderr, "%p + %3d == `%s'\n", addr, a - addr, sym);
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: LinkerBasic.c,v 1.6 2002/11/21 10:04:21 simonmar Exp $
- *
- * (c) The GHC Team, 2000
- *
- * RTS Object Linker
- *
- * ---------------------------------------------------------------------------*/
-
-#include "PosixSource.h"
-#include "Rts.h"
-#include "Hash.h"
-#include "StoragePriv.h"
-#include "LinkerInternals.h"
-
-/* List of currently loaded objects */
-ObjectCode *objects = NULL; /* initially empty */
-
-/* -----------------------------------------------------------------------------
- * Look up an address to discover whether it is in text or data space.
- *
- * Used by the garbage collector when walking the stack.
- * -------------------------------------------------------------------------- */
-
-static __inline__ SectionKind
-lookupSection ( void* addr )
-{
- Section* se;
- ObjectCode* oc;
-
- for (oc=objects; oc; oc=oc->next) {
- for (se=oc->sections; se; se=se->next) {
- if (se->start <= addr && addr <= se->end)
- return se->kind;
- }
- }
- return SECTIONKIND_OTHER;
-}
-
-int
-is_dynamically_loaded_code_or_rodata_ptr ( void* p )
-{
- SectionKind sk = lookupSection(p);
- ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
- return (sk == SECTIONKIND_CODE_OR_RODATA);
-}
-
-
-int
-is_dynamically_loaded_rwdata_ptr ( void* p )
-{
- SectionKind sk = lookupSection(p);
- ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
- return (sk == SECTIONKIND_RWDATA);
-}
-
-
-int
-is_not_dynamically_loaded_ptr ( void* p )
-{
- SectionKind sk = lookupSection(p);
- ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
- return (sk == SECTIONKIND_OTHER);
-}
/* -----------------------------------------------------------------------------
- * $Id: MBlock.c,v 1.41 2002/11/26 07:02:04 mthomas Exp $
+ * $Id: MBlock.c,v 1.42 2002/12/11 15:36:42 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
if (((W_)ret & MBLOCK_MASK) != 0) {
// misaligned block!
-#ifdef DEBUG
+#if 0 // defined(DEBUG)
belch("warning: getMBlock: misaligned block %p returned when allocating %d megablock(s) at %p", ret, n, next_request);
#endif
-
+
// unmap this block...
if (munmap(ret, size) == -1) {
barf("getMBlock: munmap failed");
SRC_MKDEPENDC_OPTS += -I. -I../includes
# -----------------------------------------------------------------------------
+# The auto-generated apply code
+
+AUTO_APPLY = AutoApply.hc
+
+gen_apply : GenApply.hs
+ $(GHC) -o $@ -I$(GHC_INCLUDE_DIR) GenApply.hs
+
+$(AUTO_APPLY): $(GHC_GENAPPLY)
+ @$(RM) $@
+ $(GHC_GENAPPLY) >$@
+
+EXTRA_SRCS += $(AUTO_APPLY)
+
+# -----------------------------------------------------------------------------
#
# Building DLLs is only supported on mingw32 at the moment.
#
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.102 2002/10/22 11:01:19 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.103 2002/12/11 15:36:45 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2002
*
* Primitive functions / data
*
* We only define the cases actually used, to avoid having too much
* garbage in this section. Warning: any bugs in here will be hard to
* track down.
+ *
+ * The return convention for an unboxed tuple is as follows:
+ * - fit as many fields as possible in registers (as per the
+ * function fast-entry point calling convention).
+ * - sort the rest of the fields into pointers and non-pointers.
+ * push the pointers on the stack, followed by the non-pointers.
+ * (so the pointers have higher addresses).
*/
/*------ All Regs available */
-#if defined(REG_R8)
+#if MAX_REAL_VANILLA_REG == 8
# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
# define RET_N(a) RET_P(a)
R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
JMP_(ENTRY_CODE(Sp[0]));
-# define RET_NNPNNP(a,b,c,d,e,f) \
- R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
- R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
- JMP_(ENTRY_CODE(Sp[0]));
-
-#elif defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
- defined(REG_R4) || defined(REG_R3)
+#elif MAX_REAL_VANILLA_REG > 2 && MAX_REAL_VANILLA_REG < 8
# error RET_n macros not defined for this setup.
/*------ 2 Registers available */
-#elif defined(REG_R2)
+#elif MAX_REAL_VANILLA_REG == 2
# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
# define RET_N(a) RET_P(a)
# define RET_NN(a,b) RET_PP(a,b)
# define RET_NP(a,b) RET_PP(a,b)
-# define RET_PPP(a,b,c) \
- R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
+# define RET_PPP(a,b,c) \
+ R1.w = (W_)(a); \
+ R2.w = (W_)(b); \
+ Sp[-1] = (W_)(c); \
+ Sp -= 1; \
JMP_(ENTRY_CODE(Sp[1]));
-# define RET_NNP(a,b,c) \
- R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
+
+# define RET_NNP(a,b,c) \
+ R1.w = (W_)(a); \
+ R2.w = (W_)(b); \
+ Sp[-1] = (W_)(c); \
+ Sp -= 1; \
JMP_(ENTRY_CODE(Sp[1]));
# define RET_NNNP(a,b,c,d) \
R1.w = (W_)(a); \
R2.w = (W_)(b); \
- /* Sp[-3] = ARGTAG(1); */ \
Sp[-2] = (W_)(c); \
Sp[-1] = (W_)(d); \
- Sp -= 3; \
- JMP_(ENTRY_CODE(Sp[3]));
+ Sp -= 2; \
+ JMP_(ENTRY_CODE(Sp[2]));
# define RET_NPNP(a,b,c,d) \
R1.w = (W_)(a); \
R2.w = (W_)(b); \
- /* Sp[-3] = ARGTAG(1); */ \
Sp[-2] = (W_)(c); \
Sp[-1] = (W_)(d); \
- Sp -= 3; \
- JMP_(ENTRY_CODE(Sp[3]));
-
-# define RET_NNPNNP(a,b,c,d,e,f) \
- R1.w = (W_)(a); \
- R2.w = (W_)(b); \
- Sp[-6] = (W_)(c); \
- /* Sp[-5] = ARGTAG(1); */ \
- Sp[-4] = (W_)(d); \
- /* Sp[-3] = ARGTAG(1); */ \
- Sp[-2] = (W_)(e); \
- Sp[-1] = (W_)(f); \
- Sp -= 6; \
- JMP_(ENTRY_CODE(Sp[6]));
+ Sp -= 2; \
+ JMP_(ENTRY_CODE(Sp[2]));
/*------ 1 Register available */
-#elif defined(REG_R1)
+#elif MAX_REAL_VANILLA_REG == 1
# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
# define RET_N(a) RET_P(a)
JMP_(ENTRY_CODE(Sp[2]));
# define RET_NP(a,b) RET_PP(a,b)
-# define RET_PPP(a,b,c) \
- R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
+# define RET_PPP(a,b,c) \
+ R1.w = (W_)(a); \
+ Sp[-2] = (W_)(b); \
+ Sp[-1] = (W_)(c); \
+ Sp -= 2; \
+ JMP_(ENTRY_CODE(Sp[2]));
+
+# define RET_NNP(a,b,c) \
+ R1.w = (W_)(a); \
+ Sp[-2] = (W_)(b); \
+ Sp[-1] = (W_)(c); \
+ Sp -= 2; \
JMP_(ENTRY_CODE(Sp[2]));
-# define RET_NNP(a,b,c) \
- R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
- JMP_(ENTRY_CODE(Sp[3]));
# define RET_NNNP(a,b,c,d) \
R1.w = (W_)(a); \
- /* Sp[-5] = ARGTAG(1); */ \
- Sp[-4] = (W_)(b); \
- /* Sp[-3] = ARGTAG(1); */ \
+ Sp[-3] = (W_)(b); \
Sp[-2] = (W_)(c); \
Sp[-1] = (W_)(d); \
- Sp -= 5; \
- JMP_(ENTRY_CODE(Sp[5]));
+ Sp -= 3; \
+ JMP_(ENTRY_CODE(Sp[3]));
# define RET_NPNP(a,b,c,d) \
R1.w = (W_)(a); \
- Sp[-4] = (W_)(b); \
- /* Sp[-3] = ARGTAG(1); */ \
- Sp[-2] = (W_)(c); \
+ Sp[-3] = (W_)(c); \
+ Sp[-2] = (W_)(b); \
Sp[-1] = (W_)(d); \
- Sp -= 4; \
- JMP_(ENTRY_CODE(Sp[4]));
-
-# define RET_NNPNNP(a,b,c,d,e,f) \
- R1.w = (W_)(a); \
- Sp[-1] = (W_)(f); \
- Sp[-2] = (W_)(e); \
- /* Sp[-3] = ARGTAG(1); */ \
- Sp[-4] = (W_)(d); \
- /* Sp[-5] = ARGTAG(1); */ \
- Sp[-6] = (W_)(c); \
- Sp[-7] = (W_)(b); \
- /* Sp[-8] = ARGTAG(1); */ \
- Sp -= 8; \
- JMP_(ENTRY_CODE(Sp[8]));
+ Sp -= 3; \
+ JMP_(ENTRY_CODE(Sp[3]));
#else /* 0 Regs available */
-#define PUSH_P(o,x) Sp[-o] = (W_)(x)
-
-#ifdef DEBUG
-#define PUSH_N(o,x) Sp[1-o] = (W_)(x); Sp[-o] = ARG_TAG(1);
-#else
-#define PUSH_N(o,x) Sp[1-o] = (W_)(x);
-#endif
+#define PUSH(o,x) Sp[-o] = (W_)(x)
#define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
-/* Here's how to construct these macros:
- *
- * N = number of N's in the name;
- * P = number of P's in the name;
- * s = N * 2 + P;
- * while (nonNull(name)) {
- * if (nextChar == 'P') {
- * PUSH_P(s,_);
- * s -= 1;
- * } else {
- * PUSH_N(s,_);
- * s -= 2
- * }
- * }
- * PUSHED(N * 2 + P);
- */
-
-# define RET_P(a) PUSH_P(1,a); PUSHED(1)
-# define RET_N(a) PUSH_N(2,a); PUSHED(2)
-
-# define RET_PP(a,b) PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
-# define RET_NN(a,b) PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
-# define RET_NP(a,b) PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
+# define RET_P(a) PUSH(1,a); PUSHED(1)
+# define RET_N(a) PUSH(1,a); PUSHED(2)
-# define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
-# define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
+# define RET_PP(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
+# define RET_NN(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
+# define RET_NP(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
-# define RET_NNNP(a,b,c,d) PUSH_N(7,a); PUSH_N(5,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(7)
-# define RET_NPNP(a,b,c,d) PUSH_N(6,a); PUSH_P(4,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(6)
-# define RET_NNPNNP(a,b,c,d,e,f) PUSH_N(10,a); PUSH_N(8,b); PUSH_P(6,c); PUSH_N(5,d); PUSH_N(3,e); PUSH_P(1,f); PUSHED(10)
+# define RET_PPP(a,b,c) PUSH(3,a); PUSH(2,b); PUSH(1,c); PUSHED(3)
+# define RET_NNP(a,b,c) PUSH(3,a); PUSH(2,b); PUSH(1,c); PUSHED(3)
+# define RET_NNNP(a,b,c,d) PUSH(4,a); PUSH(3,b); PUSH(2,c); PUSH(1,d); PUSHED(4)
+# define RET_NPNP(a,b,c,d) PUSH(4,a); PUSH(3,c); PUSH(2,b); PUSH(1,d); PUSHED(4)
#endif
/*-----------------------------------------------------------------------------
/* Args: R1.p = initialisation value */
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
CCS_ALLOC(CCCS,sizeofW(StgMutVar));
#define THUNK_SIZE(n) (sizeofW(StgHeader) + stg_max((n), MIN_UPD_SIZE))
#define SIZE (THUNK_SIZE(2) + THUNK_SIZE(1) + THUNK_SIZE(1))
- HP_CHK_GEN_TICKY(SIZE, R1_PTR|R2_PTR, atomicModifyMutVarzh_fast,);
+ HP_CHK_GEN_TICKY(SIZE, R1_PTR|R2_PTR, atomicModifyMutVarzh_fast);
CCS_ALLOC(CCCS,SIZE);
x = ((StgMutVar *)R1.cl)->var;
TICK_ALLOC_UP_THK(2,0); // XXX
z = (StgClosure *) Hp - THUNK_SIZE(2) + 1;
- SET_HDR(z, &stg_ap_2_upd_info, CCCS);
+ SET_HDR(z, (StgInfoTable *)&stg_ap_2_upd_info, CCCS);
z->payload[0] = R2.cl;
z->payload[1] = x;
StgForeignObj *result;
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgHeader),
sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
R3.cl = &stg_NO_FINALIZER_closure;
}
- HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
FB_
val = R1.i;
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
FB_
val = R1.w;
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
/* minimum is one word */
words_needed = 1;
}
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
} else {
words_needed = 1;
}
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
/* arguments: F1 = Float# */
arg = F1;
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
/* arguments: D1 = Double# */
arg = D1;
- HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
+ HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast);
TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
FB_
/* args: none */
- HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
1, 0);
CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
#define PerformPut(tso) ({ \
StgClosure *val = (StgClosure *)(tso)->sp[2]; \
- (tso)->sp[2] = (W_)&stg_gc_noregs_info; \
- (tso)->sp += 2; \
+ (tso)->sp += 3; \
val; \
})
StgStableName *sn_obj;
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast);
TICK_ALLOC_PRIM(sizeofW(StgHeader),
sizeofW(StgStableName)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
StgBCO *bco;
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast);
TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
- SET_HDR(bco, &stg_BCO_info, CCCS);
+ SET_HDR(bco, (const StgInfoTable *)&stg_BCO_info, CCCS);
bco->instrs = (StgArrWords*)R1.cl;
bco->literals = (StgArrWords*)R2.cl;
FN_(mkApUpd0zh_fast)
{
- /* R1.p = the fn for the AP_UPD
- */
- StgAP_UPD* ap;
+ // R1.p = the BCO# for the AP
+ //
+ StgPAP* ap;
FB_
- HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
- TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
- CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
- ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
- SET_HDR(ap, &stg_AP_UPD_info, CCCS);
+
+ // This function is *only* used to wrap zero-arity BCOs in an
+ // updatable wrapper (see ByteCodeLink.lhs). An AP thunk is always
+ // saturated and always points directly to a FUN or BCO.
+ ASSERT(get_itbl(R1.cl)->type == BCO && BCO_ARITY(R1.p) == 0);
+
+ HP_CHK_GEN_TICKY(PAP_sizeW(0), R1_PTR, mkApUpd0zh_fast);
+ TICK_ALLOC_PRIM(sizeofW(StgHeader), PAP_sizeW(0)-sizeofW(StgHeader), 0);
+ CCS_ALLOC(CCCS,PAP_sizeW(0)); /* ccs prof */
+ ap = (StgPAP *) (Hp + 1 - PAP_sizeW(0));
+ SET_HDR(ap, &stg_AP_info, CCCS);
ap->n_args = 0;
ap->fun = R1.cl;
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.53 2002/07/24 18:18:13 sof Exp $
+ * $Id: Printer.c,v 1.54 2002/12/11 15:36:45 simonmar Exp $
*
* (c) The GHC Team, 1994-2000.
*
#if defined(GRAN) || defined(PAR)
// HWL: explicit fixed header size to make debugging easier
int fixed_hs = FIXED_HS, itbl_sz = sizeofW(StgInfoTable),
- uf_sz=sizeofW(StgUpdateFrame), sf_sz=sizeofW(StgSeqFrame);
+ uf_sz=sizeofW(StgUpdateFrame);
#endif
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
static void printStdObject( StgClosure *obj, char* tag );
+static void printStdObjPayload( StgClosure *obj );
static void reset_table ( int size );
static void prepare_table ( void );
static void insert ( unsigned value, const char *name );
if (raw != NULL) {
printZcoded(raw);
} else {
- fprintf(stdout, "%p", p);
+ fprintf(stderr, "%p", p);
}
}
void printObj( StgClosure *obj )
{
- fprintf(stdout,"Object "); printPtr((StgPtr)obj); fprintf(stdout," = ");
+ fprintf(stderr,"Object "); printPtr((StgPtr)obj); fprintf(stderr," = ");
printClosure(obj);
}
static inline void
printStdObjHdr( StgClosure *obj, char* tag )
{
- fprintf(stdout,"%s(",tag);
+ fprintf(stderr,"%s(",tag);
printPtr((StgPtr)obj->header.info);
#ifdef PROFILING
- fprintf(stdout,", %s", obj->header.prof.ccs->cc->label);
+ fprintf(stderr,", %s", obj->header.prof.ccs->cc->label);
#endif
}
static void
-printStdObject( StgClosure *obj, char* tag )
+printStdObjPayload( StgClosure *obj )
{
StgWord i, j;
const StgInfoTable* info;
- printStdObjHdr( obj, tag );
-
info = get_itbl(obj);
for (i = 0; i < info->layout.payload.ptrs; ++i) {
- fprintf(stdout,", ");
+ fprintf(stderr,", ");
printPtr((StgPtr)obj->payload[i]);
}
for (j = 0; j < info->layout.payload.nptrs; ++j) {
- fprintf(stdout,", %pd#",obj->payload[i+j]);
+ fprintf(stderr,", %pd#",obj->payload[i+j]);
}
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
+}
+
+static void
+printStdObject( StgClosure *obj, char* tag )
+{
+ printStdObjHdr( obj, tag );
+ printStdObjPayload( obj );
}
void
case MUT_VAR:
{
StgMutVar* mv = (StgMutVar*)obj;
- fprintf(stdout,"MUT_VAR(var=%p, link=%p)\n", mv->var, mv->mut_link);
+ fprintf(stderr,"MUT_VAR(var=%p, link=%p)\n", mv->var, mv->mut_link);
break;
}
- case AP_UPD:
+ case AP_STACK:
+ {
+ StgAP_STACK* ap = stgCast(StgAP_STACK*,obj);
+ StgWord i;
+ fprintf(stderr,"AP_STACK("); printPtr((StgPtr)ap->fun);
+ for (i = 0; i < ap->size; ++i) {
+ fprintf(stderr,", ");
+ printPtr((P_)ap->payload[i]);
+ }
+ fprintf(stderr,")\n");
+ break;
+ }
+
+ case AP:
{
- StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
+ StgPAP* ap = stgCast(StgPAP*,obj);
StgWord i;
- fprintf(stdout,"AP_UPD("); printPtr((StgPtr)ap->fun);
+ fprintf(stderr,"AP("); printPtr((StgPtr)ap->fun);
for (i = 0; i < ap->n_args; ++i) {
- fprintf(stdout,", ");
+ fprintf(stderr,", ");
printPtr((P_)ap->payload[i]);
}
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
{
StgPAP* pap = stgCast(StgPAP*,obj);
StgWord i;
- fprintf(stdout,"PAP("); printPtr((StgPtr)pap->fun);
+ fprintf(stderr,"PAP/%d(",pap->arity);
+ printPtr((StgPtr)pap->fun);
for (i = 0; i < pap->n_args; ++i) {
- fprintf(stdout,", ");
+ fprintf(stderr,", ");
printPtr((StgPtr)pap->payload[i]);
}
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
case FOREIGN:
- fprintf(stdout,"FOREIGN(");
+ fprintf(stderr,"FOREIGN(");
printPtr((StgPtr)( ((StgForeignObj*)obj)->data ));
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case IND:
- fprintf(stdout,"IND(");
+ fprintf(stderr,"IND(");
printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
+ break;
+
+ case IND_PERM:
+ fprintf(stderr,"IND(");
+ printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
+ fprintf(stderr,")\n");
break;
case IND_STATIC:
- fprintf(stdout,"IND_STATIC(");
+ fprintf(stderr,"IND_STATIC(");
printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case IND_OLDGEN:
- fprintf(stdout,"IND_OLDGEN(");
+ fprintf(stderr,"IND_OLDGEN(");
printPtr((StgPtr)stgCast(StgInd*,obj)->indirectee);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case CAF_BLACKHOLE:
- fprintf(stdout,"CAF_BH(");
+ fprintf(stderr,"CAF_BH(");
printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case SE_BLACKHOLE:
- fprintf(stdout,"SE_BH\n");
+ fprintf(stderr,"SE_BH\n");
break;
case SE_CAF_BLACKHOLE:
- fprintf(stdout,"SE_CAF_BH\n");
+ fprintf(stderr,"SE_CAF_BH\n");
break;
case BLACKHOLE:
- fprintf(stdout,"BH\n");
+ fprintf(stderr,"BH\n");
break;
case BLACKHOLE_BQ:
- fprintf(stdout,"BQ(");
+ fprintf(stderr,"BQ(");
printPtr((StgPtr)stgCast(StgBlockingQueue*,obj)->blocking_queue);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case TSO:
- fprintf(stdout,"TSO(");
- fprintf(stdout,"%d (%p)",((StgTSO*)obj)->id, (StgTSO*)obj);
- fprintf(stdout,")\n");
+ fprintf(stderr,"TSO(");
+ fprintf(stderr,"%d (%p)",((StgTSO*)obj)->id, (StgTSO*)obj);
+ fprintf(stderr,")\n");
break;
#if defined(PAR)
case BLOCKED_FETCH:
- fprintf(stdout,"BLOCKED_FETCH(");
+ fprintf(stderr,"BLOCKED_FETCH(");
printGA(&(stgCast(StgBlockedFetch*,obj)->ga));
printPtr((StgPtr)(stgCast(StgBlockedFetch*,obj)->node));
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
case FETCH_ME:
- fprintf(stdout,"FETCH_ME(");
+ fprintf(stderr,"FETCH_ME(");
printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
#ifdef DIST
case REMOTE_REF:
- fprintf(stdout,"REMOTE_REF(");
+ fprintf(stderr,"REMOTE_REF(");
printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
#endif
case FETCH_ME_BQ:
- fprintf(stdout,"FETCH_ME_BQ(");
+ fprintf(stderr,"FETCH_ME_BQ(");
// printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
printPtr((StgPtr)stgCast(StgFetchMeBlockingQueue*,obj)->blocking_queue);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
#endif
#if defined(GRAN) || defined(PAR)
case RBH:
- fprintf(stdout,"RBH(");
+ fprintf(stderr,"RBH(");
printPtr((StgPtr)stgCast(StgRBH*,obj)->blocking_queue);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
#endif
*/
StgWord i, j;
#ifdef PROFILING
- fprintf(stdout,"%s(", info->prof.closure_desc);
- fprintf(stdout,"%s", obj->header.prof.ccs->cc->label);
+ fprintf(stderr,"%s(", info->prof.closure_desc);
+ fprintf(stderr,"%s", obj->header.prof.ccs->cc->label);
#else
- fprintf(stdout,"CONSTR(");
+ fprintf(stderr,"CONSTR(");
printPtr((StgPtr)obj->header.info);
- fprintf(stdout,"(tag=%d)",info->srt_len);
+ fprintf(stderr,"(tag=%d)",info->srt_len);
#endif
for (i = 0; i < info->layout.payload.ptrs; ++i) {
- fprintf(stdout,", ");
+ fprintf(stderr,", ");
printPtr((StgPtr)obj->payload[i]);
}
for (j = 0; j < info->layout.payload.nptrs; ++j) {
- fprintf(stdout,", %p#", obj->payload[i+j]);
+ fprintf(stderr,", %p#", obj->payload[i+j]);
}
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
StgWord i;
StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,obj);
- fprintf(stdout,"Row<%i>(",p->ptrs);
+ fprintf(stderr,"Row<%i>(",p->ptrs);
for (i = 0; i < p->ptrs; ++i) {
- if (i > 0) fprintf(stdout,", ");
+ if (i > 0) fprintf(stderr,", ");
printPtr((StgPtr)(p->payload[i]));
}
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
#endif
case FUN_1_0: case FUN_0_1:
case FUN_1_1: case FUN_0_2: case FUN_2_0:
case FUN_STATIC:
- printStdObject(obj,"FUN");
- break;
+ fprintf(stderr,"FUN/%d(",itbl_to_fun_itbl(info)->arity);
+ printPtr((StgPtr)obj->header.info);
+#ifdef PROFILING
+ fprintf(stderr,", %s", obj->header.prof.ccs->cc->label);
+#endif
+ printStdObjPayload(obj);
+ break;
case THUNK:
case THUNK_1_0: case THUNK_0_1:
case THUNK_SELECTOR:
printStdObjHdr(obj, "THUNK_SELECTOR");
- fprintf(stdout, ", %p)\n", ((StgSelector *)obj)->selectee);
+ fprintf(stderr, ", %p)\n", ((StgSelector *)obj)->selectee);
+ break;
+
+ case MUT_ARR_PTRS:
+ fprintf(stderr,"MUT_ARR_PTRS(size=%d)\n", ((StgMutArrPtrs *)obj)->ptrs);
+ break;
+ case MUT_ARR_PTRS_FROZEN:
+ fprintf(stderr,"MUT_ARR_PTRS_FROZEN(size=%d)\n", ((StgMutArrPtrs *)obj)->ptrs);
break;
case ARR_WORDS:
{
StgWord i;
- fprintf(stdout,"ARR_WORDS(\"");
+ fprintf(stderr,"ARR_WORDS(\"");
/* ToDo: we can't safely assume that this is a string!
for (i = 0; arrWordsGetChar(obj,i); ++i) {
putchar(arrWordsGetChar(obj,i));
} */
for (i=0; i<((StgArrWords *)obj)->words; i++)
- fprintf(stdout, "%u", ((StgArrWords *)obj)->payload[i]);
- fprintf(stdout,"\")\n");
+ fprintf(stderr, "%u", ((StgArrWords *)obj)->payload[i]);
+ fprintf(stderr,"\")\n");
break;
}
case UPDATE_FRAME:
{
StgUpdateFrame* u = stgCast(StgUpdateFrame*,obj);
- fprintf(stdout,"UpdateFrame(");
+ fprintf(stderr,"UPDATE_FRAME(");
printPtr((StgPtr)GET_INFO(u));
- fprintf(stdout,",");
+ fprintf(stderr,",");
printPtr((StgPtr)u->updatee);
- fprintf(stdout,",");
- printPtr((StgPtr)u->link);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
case CATCH_FRAME:
{
StgCatchFrame* u = stgCast(StgCatchFrame*,obj);
- fprintf(stdout,"CatchFrame(");
+ fprintf(stderr,"CATCH_FRAME(");
printPtr((StgPtr)GET_INFO(u));
- fprintf(stdout,",");
+ fprintf(stderr,",");
printPtr((StgPtr)u->handler);
- fprintf(stdout,",");
- printPtr((StgPtr)u->link);
- fprintf(stdout,")\n");
- break;
- }
-
- case SEQ_FRAME:
- {
- StgSeqFrame* u = stgCast(StgSeqFrame*,obj);
- fprintf(stdout,"SeqFrame(");
- printPtr((StgPtr)GET_INFO(u));
- fprintf(stdout,",");
- printPtr((StgPtr)u->link);
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
case STOP_FRAME:
{
StgStopFrame* u = stgCast(StgStopFrame*,obj);
- fprintf(stdout,"StopFrame(");
+ fprintf(stderr,"STOP_FRAME(");
printPtr((StgPtr)GET_INFO(u));
- fprintf(stdout,")\n");
+ fprintf(stderr,")\n");
break;
}
default:
//barf("printClosure %d",get_itbl(obj)->type);
- fprintf(stdout, "*** printClosure: unknown type %d ****\n",
+ fprintf(stderr, "*** printClosure: unknown type %d ****\n",
get_itbl(obj)->type );
barf("printClosure %d",get_itbl(obj)->type);
return;
}
*/
-StgPtr printStackObj( StgPtr sp )
+StgPtr
+printStackObj( StgPtr sp )
{
- /*fprintf(stdout,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
-
- if (IS_ARG_TAG(*sp)) {
- nat i;
- StgWord tag = *sp++;
- fprintf(stdout,"Tagged{");
- for (i = 0; i < tag; i++) {
- fprintf(stdout,"0x%x#", (unsigned)(*sp++));
- if (i < tag-1) fprintf(stdout, ", ");
- }
- fprintf(stdout, "}\n");
- } else {
+ /*fprintf(stderr,"Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
+
StgClosure* c = (StgClosure*)(*sp);
printPtr((StgPtr)*sp);
if (c == (StgClosure*)&stg_ctoi_ret_R1p_info) {
- fprintf(stdout, "\t\t\tstg_ctoi_ret_R1p_info\n" );
+ fprintf(stderr, "\t\t\tstg_ctoi_ret_R1p_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_ret_R1n_info) {
- fprintf(stdout, "\t\t\tstg_ctoi_ret_R1n_info\n" );
+ fprintf(stderr, "\t\t\tstg_ctoi_ret_R1n_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_ret_F1_info) {
- fprintf(stdout, "\t\t\tstg_ctoi_ret_F1_info\n" );
+ fprintf(stderr, "\t\t\tstg_ctoi_ret_F1_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_ret_D1_info) {
- fprintf(stdout, "\t\t\tstg_ctoi_ret_D1_info\n" );
+ fprintf(stderr, "\t\t\tstg_ctoi_ret_D1_info\n" );
} else
if (c == (StgClosure*)&stg_ctoi_ret_V_info) {
- fprintf(stdout, "\t\t\tstg_ctoi_ret_V_info\n" );
+ fprintf(stderr, "\t\t\tstg_ctoi_ret_V_info\n" );
} else
if (get_itbl(c)->type == BCO) {
- fprintf(stdout, "\t\t\t");
- fprintf(stdout, "BCO(...)\n");
+ fprintf(stderr, "\t\t\t");
+ fprintf(stderr, "BCO(...)\n");
}
else {
- fprintf(stdout, "\t\t\t");
+ fprintf(stderr, "\t\t\t");
printClosure ( (StgClosure*)(*sp));
}
sp += 1;
- }
+
return sp;
}
-void printStackChunk( StgPtr sp, StgPtr spBottom )
+static void
+printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
+{
+ StgPtr p;
+ nat i;
+
+ p = payload;
+ for(i = 0; i < size; i++, bitmap >>= 1 ) {
+ fprintf(stderr," stk[%d] (%p) = ", spBottom-(payload+i), payload+i);
+ if ((bitmap & 1) == 0) {
+ printPtr((P_)payload[i]);
+ fprintf(stderr,"\n");
+ } else {
+ fprintf(stderr,"Word# %d\n", payload[i]);
+ }
+ }
+}
+
+static void
+printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
+{
+ StgWord bmp;
+ nat i, j;
+
+ i = 0;
+ for (bmp=0; i < size; bmp++) {
+ StgWord bitmap = large_bitmap->bitmap[bmp];
+ j = 0;
+ for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
+ fprintf(stderr," stk[%d] (%p) = ", spBottom-(payload+i), payload+i);
+ if ((bitmap & 1) == 0) {
+ printPtr((P_)payload[i]);
+ fprintf(stderr,"\n");
+ } else {
+ fprintf(stderr,"Word# %d\n", payload[i]);
+ }
+ }
+ }
+}
+
+void
+printStackChunk( StgPtr sp, StgPtr spBottom )
{
StgWord bitmap;
const StgInfoTable *info;
ASSERT(sp <= spBottom);
- while (sp < spBottom) {
- if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) {
+ for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
+
info = get_itbl((StgClosure *)sp);
- switch (info->type) {
+ switch (info->type) {
+
case UPDATE_FRAME:
- printObj( stgCast(StgClosure*,sp) );
- sp += sizeofW(StgUpdateFrame);
- continue;
-
- case SEQ_FRAME:
- printObj( stgCast(StgClosure*,sp) );
- sp += sizeofW(StgSeqFrame);
- continue;
-
case CATCH_FRAME:
- printObj( stgCast(StgClosure*,sp) );
- sp += sizeofW(StgCatchFrame);
- continue;
-
case STOP_FRAME:
- /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
- printObj( stgCast(StgClosure*,sp) );
+ printObj((StgClosure*)sp);
continue;
case RET_DYN:
- fprintf(stdout, "RET_DYN (%p)\n", sp);
- bitmap = *++sp;
- ++sp;
- fprintf(stdout, "Bitmap: 0x%x\n", bitmap);
- goto small_bitmap;
+ {
+ StgRetDyn* r;
+ StgPtr p;
+ StgWord dyn;
+ nat size;
+
+ r = (StgRetDyn *)sp;
+ dyn = r->liveness;
+ fprintf(stderr, "RET_DYN (%p)\n", r);
+
+ p = (P_)(r->payload);
+ printSmallBitmap(spBottom, sp,
+ GET_LIVENESS(r->liveness), RET_DYN_SIZE);
+ p += RET_DYN_SIZE;
+
+ for (size = GET_NONPTRS(dyn); size > 0; size--) {
+ fprintf(stderr," stk[%ld] (%p) = ", spBottom-p, p);
+ fprintf(stderr,"Word# %ld\n", *p);
+ p++;
+ }
+
+ for (size = GET_PTRS(dyn); size > 0; size--) {
+ fprintf(stderr," stk[%ld] (%p) = ", spBottom-p, p);
+ printPtr(p);
+ p++;
+ }
+ continue;
+ }
case RET_SMALL:
case RET_VEC_SMALL:
- fprintf(stdout, "RET_SMALL (%p)\n", sp);
- bitmap = info->layout.bitmap;
- sp++;
- small_bitmap:
- while (bitmap != 0) {
- fprintf(stdout," stk[%ld] (%p) = ", spBottom-sp, sp);
- if ((bitmap & 1) == 0) {
- printPtr((P_)*sp);
- fprintf(stdout,"\n");
- } else {
- fprintf(stdout,"Word# %ld\n", *sp);
- }
- sp++;
- bitmap = bitmap >> 1;
- }
- continue;
+ fprintf(stderr, "RET_SMALL (%p)\n", sp);
+ bitmap = info->layout.bitmap;
+ printSmallBitmap(spBottom, sp+1,
+ BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
+ continue;
- case RET_BIG:
- case RET_VEC_BIG:
- barf("todo");
+ case RET_BCO: {
+ StgBCO *bco;
+
+ bco = ((StgBCO *)sp[1]);
- default:
- break;
+ fprintf(stderr, "RET_BCO (%p)\n", sp);
+ printLargeBitmap(spBottom, sp+2,
+ BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
+ continue;
}
- }
- fprintf(stdout,"Stack[%ld] (%p) = ", spBottom-sp, sp);
- sp = printStackObj(sp);
- }
-}
-void printStack( StgPtr sp, StgPtr spBottom, StgUpdateFrame* su )
-{
- /* check everything down to the first update frame */
- printStackChunk( sp, stgCast(StgPtr,su) );
- while ( stgCast(StgPtr,su) < spBottom) {
- sp = stgCast(StgPtr,su);
- switch (get_itbl(su)->type) {
- case UPDATE_FRAME:
- printObj( stgCast(StgClosure*,su) );
- sp += sizeofW(StgUpdateFrame);
- su = su->link;
- break;
- case SEQ_FRAME:
- printObj( stgCast(StgClosure*,su) );
- sp += sizeofW(StgSeqFrame);
- su = stgCast(StgSeqFrame*,su)->link;
- break;
- case CATCH_FRAME:
- printObj( stgCast(StgClosure*,su) );
- sp += sizeofW(StgCatchFrame);
- su = stgCast(StgCatchFrame*,su)->link;
- break;
- case STOP_FRAME:
- /* not quite: ASSERT(stgCast(StgPtr,su) == spBottom); */
- printObj( stgCast(StgClosure*,su) );
- return;
+ case RET_BIG:
+ case RET_VEC_BIG:
+ barf("todo");
+
default:
- barf("printStack: weird record found on update frame list.");
+ barf("printStackChunk");
}
- printStackChunk( sp, stgCast(StgPtr,su) );
}
- ASSERT(stgCast(StgPtr,su) == spBottom);
}
void printTSO( StgTSO *tso )
{
- printStack( tso->sp, tso->stack+tso->stack_size,tso->su);
- /* printStackChunk( tso->sp, tso->stack+tso->stack_size); */
+ printStackChunk( tso->sp, tso->stack+tso->stack_size);
}
/* -----------------------------------------------------------------------------
-------------------------------------------------------------------------- */
static char *closure_type_names[] = {
- "INVALID_OBJECT", /* 0 */
- "CONSTR", /* 1 */
- "CONSTR_1_0", /* 2 */
- "CONSTR_0_1", /* 3 */
- "CONSTR_2_0", /* 4 */
- "CONSTR_1_1", /* 5 */
- "CONSTR_0_2", /* 6 */
- "CONSTR_INTLIKE", /* 7 */
- "CONSTR_CHARLIKE", /* 8 */
- "CONSTR_STATIC", /* 9 */
- "CONSTR_NOCAF_STATIC", /* 10 */
- "FUN", /* 11 */
- "FUN_1_0", /* 12 */
- "FUN_0_1", /* 13 */
- "FUN_2_0", /* 14 */
- "FUN_1_1", /* 15 */
- "FUN_0_2", /* 16 */
- "FUN_STATIC", /* 17 */
- "THUNK", /* 18 */
- "THUNK_1_0", /* 19 */
- "THUNK_0_1", /* 20 */
- "THUNK_2_0", /* 21 */
- "THUNK_1_1", /* 22 */
- "THUNK_0_2", /* 23 */
- "THUNK_STATIC", /* 24 */
- "THUNK_SELECTOR", /* 25 */
- "BCO", /* 26 */
- "AP_UPD", /* 27 */
- "PAP", /* 28 */
- "IND", /* 29 */
- "IND_OLDGEN", /* 30 */
- "IND_PERM", /* 31 */
- "IND_OLDGEN_PERM", /* 32 */
- "IND_STATIC", /* 33 */
- "CAF_BLACKHOLE", /* 36 */
- "RET_BCO", /* 37 */
- "RET_SMALL", /* 38 */
- "RET_VEC_SMALL", /* 39 */
- "RET_BIG", /* 40 */
- "RET_VEC_BIG", /* 41 */
- "RET_DYN", /* 42 */
- "UPDATE_FRAME", /* 43 */
- "CATCH_FRAME", /* 44 */
- "STOP_FRAME", /* 45 */
- "SEQ_FRAME", /* 46 */
- "BLACKHOLE", /* 47 */
- "BLACKHOLE_BQ", /* 48 */
- "SE_BLACKHOLE", /* 49 */
- "SE_CAF_BLACKHOLE", /* 50 */
- "MVAR", /* 51 */
- "ARR_WORDS", /* 52 */
- "MUT_ARR_PTRS", /* 53 */
- "MUT_ARR_PTRS_FROZEN", /* 54 */
- "MUT_VAR", /* 55 */
- "WEAK", /* 56 */
- "FOREIGN", /* 57 */
- "STABLE_NAME", /* 58 */
- "TSO", /* 59 */
- "BLOCKED_FETCH", /* 60 */
- "FETCH_ME", /* 61 */
- "FETCH_ME_BQ", /* 62 */
- "RBH", /* 63 */
- "EVACUATED", /* 64 */
- "REMOTE_REF", /* 65 */
- "N_CLOSURE_TYPES" /* 66 */
+ "INVALID_OBJECT",
+ "CONSTR",
+ "CONSTR_1",
+ "CONSTR_0",
+ "CONSTR_2",
+ "CONSTR_1",
+ "CONSTR_0",
+ "CONSTR_INTLIKE",
+ "CONSTR_CHARLIKE",
+ "CONSTR_STATIC",
+ "CONSTR_NOCAF_STATIC",
+ "FUN",
+ "FUN_1_0",
+ "FUN_0_1",
+ "FUN_2_0",
+ "FUN_1_1",
+ "FUN_0",
+ "FUN_STATIC",
+ "THUNK",
+ "THUNK_1_0",
+ "THUNK_0_1",
+ "THUNK_2_0",
+ "THUNK_1_1",
+ "THUNK_0",
+ "THUNK_STATIC",
+ "THUNK_SELECTOR",
+ "BCO",
+ "AP_UPD",
+ "PAP",
+ "IND",
+ "IND_OLDGEN",
+ "IND_PERM",
+ "IND_OLDGEN_PERM",
+ "IND_STATIC",
+ "RET_BCO",
+ "RET_SMALL",
+ "RET_VEC_SMALL",
+ "RET_BIG",
+ "RET_VEC_BIG",
+ "RET_DYN",
+ "RET_FUN",
+ "UPDATE_FRAME",
+ "CATCH_FRAME",
+ "STOP_FRAME",
+ "CAF_BLACKHOLE",
+ "BLACKHOLE",
+ "BLACKHOLE_BQ",
+ "SE_BLACKHOLE",
+ "SE_CAF_BLACKHOLE",
+ "MVAR",
+ "ARR_WORDS",
+ "MUT_ARR_PTRS",
+ "MUT_ARR_PTRS_FROZEN",
+ "MUT_VAR",
+ "MUT_CONS",
+ "WEAK",
+ "FOREIGN",
+ "STABLE_NAME",
+ "TSO",
+ "BLOCKED_FETCH",
+ "FETCH_ME",
+ "FETCH_ME_BQ",
+ "RBH",
+ "EVACUATED",
+ "REMOTE_REF"
};
+
char *
info_type(StgClosure *closure){
return closure_type_names[get_itbl(closure)->type];
while ( raw[j] != '\0' ) {
if (raw[j] == 'Z') {
- fputc(unZcode(raw[j+1]),stdout);
+ fputc(unZcode(raw[j+1]),stderr);
j = j + 2;
} else {
- fputc(raw[j],stdout);
+ fputc(raw[j],stderr);
j = j + 1;
}
}
for( i = 0; i != number_of_symbols; ++i ) {
symbol_info info;
bfd_get_symbol_info(abfd,symbol_table[i],&info);
- /*fprintf(stdout,"\t%c\t0x%x \t%s\n",info.type,(nat)info.value,info.name); */
+ /*fprintf(stderr,"\t%c\t0x%x \t%s\n",info.type,(nat)info.value,info.name); */
if (isReal(info.type, info.name)) {
num_real_syms += 1;
}
}
- IF_DEBUG(evaluator,
- fprintf(stdout,"Loaded %ld symbols. Of which %ld are real symbols\n",
+ IF_DEBUG(interpreter,
+ fprintf(stderr,"Loaded %ld symbols. Of which %ld are real symbols\n",
number_of_symbols, num_real_syms)
);
insert( info.value, info.name );
}
}
-
+
free(symbol_table);
}
prepare_table();
if (*q == (W_)p) {
if (i < arr_size) {
r = q;
- while (!LOOKS_LIKE_GHC_INFO(*r) || (P_)*r == NULL) {
+ while (!LOOKS_LIKE_INFO_PTR(*r) || (P_)*r == NULL) {
r--;
}
- fprintf(stdout, "%p = ", r);
+ fprintf(stderr, "%p = ", r);
printClosure((StgClosure *)r);
arr[i++] = r;
} else {
}
}
if (follow && i == 1) {
- fprintf(stdout, "-->\n");
+ fprintf(stderr, "-->\n");
findPtr(arr[0], 1);
}
}
#else /* DEBUG */
void printPtr( StgPtr p )
{
- fprintf(stdout, "ptr 0x%p (enable -DDEBUG for more info) " , p );
+ fprintf(stderr, "ptr 0x%p (enable -DDEBUG for more info) " , p );
}
void printObj( StgClosure *obj )
{
- fprintf(stdout, "obj 0x%p (enable -DDEBUG for more info) " , obj );
+ fprintf(stderr, "obj 0x%p (enable -DDEBUG for more info) " , obj );
}
#endif /* DEBUG */
/* -----------------------------------------------------------------------------
- * $Id: Printer.h,v 1.6 2001/11/28 15:43:23 simonmar Exp $
+ * $Id: Printer.h,v 1.7 2002/12/11 15:36:45 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
extern void printClosure ( StgClosure *obj );
extern StgStackPtr printStackObj ( StgStackPtr sp );
extern void printStackChunk ( StgStackPtr sp, StgStackPtr spLim );
-extern void printStack ( StgStackPtr sp, StgStackPtr spLim,
- StgUpdateFrame* su );
extern void printTSO ( StgTSO *tso );
void info_hdr_type ( StgClosure *closure, char *res );
/* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.39 2002/11/01 11:05:46 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.40 2002/12/11 15:36:47 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#include "Printer.h"
#include <string.h>
+#include <stdlib.h>
/* -----------------------------------------------------------------------------
* era stores the current time period. It is the same as the
, "THUNK_SELECTOR"
, "BCO"
- , "AP_UPD"
+ , "AP_STACK"
+ , "AP"
, "PAP"
, "UPDATE_FRAME"
, "CATCH_FRAME"
, "STOP_FRAME"
- , "SEQ_FRAME"
, "BLACKHOLE"
, "BLACKHOLE_BQ"
era++;
if (era == max_era) {
- barf("maximum number of censuses reached; use +RTS -i to reduce");
+ prog_belch("maximum number of censuses reached; use +RTS -i to reduce");
+ stg_exit(EXIT_FAILURE);
}
if (era == n_censuses) {
}
}
#endif // PROFILING
-
+
initEra( &censuses[era] );
}
size = sizeofW(StgHeader) + MIN_UPD_SIZE;
break;
+ case AP:
case PAP:
- case AP_UPD:
size = pap_sizeW((StgPAP *)p);
break;
+
+ case AP_STACK:
+ size = ap_stack_sizeW((StgAP_STACK *)p);
+ break;
case ARR_WORDS:
prim = rtsTrue;
/* -----------------------------------------------------------------------------
- * $Id: Proftimer.c,v 1.10 2002/07/18 09:12:34 simonmar Exp $
+ * $Id: Proftimer.c,v 1.11 2002/12/11 15:36:47 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
void
startHeapProfTimer( void )
{
- if (RtsFlags.ProfFlags.doHeapProfile) {
+ if (RtsFlags.ProfFlags.doHeapProfile &&
+ RtsFlags.ProfFlags.profileIntervalTicks > 0) {
do_heap_prof_ticks = rtsTrue;
}
}
/* -----------------------------------------------------------------------------
- * $Id: RetainerProfile.c,v 1.5 2002/07/18 09:12:35 simonmar Exp $
+ * $Id: RetainerProfile.c,v 1.6 2002/12/11 15:36:47 simonmar Exp $
*
* (c) The GHC Team, 2001
* Author: Sungwoo Park
#include "Itimer.h"
#include "Proftimer.h"
#include "ProfHeap.h"
+#include "Apply.h"
/*
Note: what to change in order to plug-in a new retainer profiling scheme?
#define setRetainerSetToNull(c) \
(c)->header.prof.hp.rs = (RetainerSet *)((StgWord)NULL | flip)
-static void retainStack(StgClosure *, retainer, StgClosure *, StgPtr, StgPtr);
+static void retainStack(StgClosure *, retainer, StgPtr, StgPtr);
static void retainClosure(StgClosure *, StgClosure *, retainer);
#ifdef DEBUG_RETAINER
static void belongToHeap(StgPtr p);
* Initializes *info from SRT information stored in *infoTable.
* -------------------------------------------------------------------------- */
static inline void
-init_srt( stackPos *info, StgInfoTable *infoTable )
+init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
{
info->type = posTypeSRT;
info->next.srt.srt = (StgClosure **)(infoTable->srt);
- info->next.srt.srt_end = info->next.srt.srt + infoTable->srt_len;
+ info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
+}
+
+static inline void
+init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
+{
+ info->type = posTypeSRT;
+ info->next.srt.srt = (StgClosure **)(infoTable->srt);
+ info->next.srt.srt_end = info->next.srt.srt + infoTable->i.srt_len;
}
/* -----------------------------------------------------------------------------
* Invariants:
* *c_child_r is the most recent retainer of *c's children.
- * *c is not any of TSO, PAP, or AP_UPD, which means that
+ * *c is not any of TSO, AP, PAP, AP_STACK, which means that
* there cannot be any stack objects.
* Note: SRTs are considered to be children as well.
* -------------------------------------------------------------------------- */
#endif
ASSERT(get_itbl(c)->type != TSO);
- ASSERT(get_itbl(c)->type != PAP);
- ASSERT(get_itbl(c)->type != AP_UPD);
+ ASSERT(get_itbl(c)->type != AP_STACK);
//
// fill in se
// layout.payload.ptrs, SRT
case FUN: // *c is a heap object.
case FUN_2_0:
+ init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
+ *first_child = find_ptrs(&se.info);
+ if (*first_child == NULL)
+ // no child from ptrs, so check SRT
+ goto fun_srt_only;
+ break;
+
case THUNK:
case THUNK_2_0:
init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
*first_child = find_ptrs(&se.info);
if (*first_child == NULL)
// no child from ptrs, so check SRT
- goto srt_only;
+ goto thunk_srt_only;
break;
// 1 fixed child, SRT
case FUN_1_0:
case FUN_1_1:
+ *first_child = c->payload[0];
+ ASSERT(*first_child != NULL);
+ init_srt_fun(&se.info, get_fun_itbl(c));
+ break;
+
case THUNK_1_0:
case THUNK_1_1:
*first_child = c->payload[0];
ASSERT(*first_child != NULL);
- init_srt(&se.info, get_itbl(c));
+ init_srt_thunk(&se.info, get_thunk_itbl(c));
break;
- // SRT only
- case THUNK_STATIC:
case FUN_STATIC: // *c is a heap object.
ASSERT(get_itbl(c)->srt_len != 0);
case FUN_0_1:
case FUN_0_2:
+ fun_srt_only:
+ init_srt_fun(&se.info, get_fun_itbl(c));
+ *first_child = find_srt(&se.info);
+ if (*first_child == NULL)
+ return; // no child
+ break;
+
+ // SRT only
+ case THUNK_STATIC:
+ ASSERT(get_itbl(c)->srt_len != 0);
case THUNK_0_1:
case THUNK_0_2:
- srt_only:
- init_srt(&se.info, get_itbl(c));
+ thunk_srt_only:
+ init_srt_thunk(&se.info, get_thunk_itbl(c));
*first_child = find_srt(&se.info);
if (*first_child == NULL)
return; // no child
// cannot appear
case PAP:
- case AP_UPD:
+ case AP:
+ case AP_STACK:
case TSO:
case IND_STATIC:
case CONSTR_INTLIKE:
case UPDATE_FRAME:
case CATCH_FRAME:
case STOP_FRAME:
- case SEQ_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
// layout.payload.ptrs, SRT
case FUN: // always a heap object
case FUN_2_0:
+ if (se->info.type == posTypePtrs) {
+ *c = find_ptrs(&se->info);
+ if (*c != NULL) {
+ *cp = se->c;
+ *r = se->c_child_r;
+ return;
+ }
+ init_srt_fun(&se->info, get_fun_itbl(se->c));
+ }
+ goto do_srt;
+
case THUNK:
case THUNK_2_0:
if (se->info.type == posTypePtrs) {
*r = se->c_child_r;
return;
}
- init_srt(&se->info, get_itbl(se->c));
+ init_srt_thunk(&se->info, get_thunk_itbl(se->c));
}
- // fall through
+ goto do_srt;
// SRT
+ do_srt:
case THUNK_STATIC:
case FUN_STATIC:
case FUN_0_1:
case CONSTR_1_1:
// cannot appear
case PAP:
- case AP_UPD:
+ case AP:
+ case AP_STACK:
case TSO:
case IND_STATIC:
case CONSTR_INTLIKE:
case UPDATE_FRAME:
case CATCH_FRAME:
case STOP_FRAME:
- case SEQ_FRAME:
case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
case THUNK_1_1:
case THUNK_0_2:
case THUNK_SELECTOR:
- case AP_UPD:
+ case AP:
+ case AP_STACK:
// Static thunks, or CAFS, are obviously retainers.
case THUNK_STATIC:
case UPDATE_FRAME:
case CATCH_FRAME:
case STOP_FRAME:
- case SEQ_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
}
/* -----------------------------------------------------------------------------
+ * Call retainClosure for each of the closures in an SRT.
+ * ------------------------------------------------------------------------- */
+
+static inline void
+retainSRT (StgClosure **srt, nat srt_len, StgClosure *c, retainer c_child_r)
+{
+ StgClosure **srt_end;
+
+ srt_end = srt + srt_len;
+
+ for (; srt < srt_end; srt++) {
+ /* Special-case to handle references to closures hiding out in DLLs, since
+ double indirections required to get at those. The code generator knows
+ which is which when generating the SRT, so it stores the (indirect)
+ reference to the DLL closure in the table by first adding one to it.
+ We check for this here, and undo the addition before evacuating it.
+
+ If the SRT entry hasn't got bit 0 set, the SRT entry points to a
+ closure that's fixed at link-time, and no extra magic is required.
+ */
+#ifdef ENABLE_WIN32_DLL_SUPPORT
+ if ( (unsigned long)(*srt) & 0x1 ) {
+ retainClosure(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)),
+ c, c_child_r);
+ } else {
+ retainClosure(*srt,c,c_child_r);
+ }
+#else
+ retainClosure(*srt,c,c_child_r);
+#endif
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Call retainClosure for each of the closures covered by a large bitmap.
+ -------------------------------------------------------------------------- */
+
+static void
+retain_large_bitmap (StgPtr p, StgLargeBitmap *large_bitmap, nat size,
+ StgClosure *c, retainer c_child_r)
+{
+ nat i, b;
+ StgWord bitmap;
+
+ b = 0;
+ bitmap = large_bitmap->bitmap[b];
+ for (i = 0; i < size; ) {
+ if ((bitmap & 1) == 0) {
+ retainClosure((StgClosure *)*p, c, c_child_r);
+ }
+ i++;
+ p++;
+ if (i % BITS_IN(W_) == 0) {
+ b++;
+ bitmap = large_bitmap->bitmap[b];
+ } else {
+ bitmap = bitmap >> 1;
+ }
+ }
+}
+
+static inline StgPtr
+retain_small_bitmap (StgPtr p, nat size, StgWord bitmap,
+ StgClosure *c, retainer c_child_r)
+{
+ while (size > 0) {
+ if ((bitmap & 1) == 0) {
+ retainClosure((StgClosure *)*p, c, c_child_r);
+ }
+ p++;
+ bitmap = bitmap >> 1;
+ size--;
+ }
+ return p;
+}
+
+/* -----------------------------------------------------------------------------
* Process all the objects in the stack chunk from stackStart to stackEnd
* with *c and *c_child_r being their parent and their most recent retainer,
* respectively. Treat stackOptionalFun as another child of *c if it is
* not NULL.
* Invariants:
- * *c is one of the following: TSO, PAP, and AP_UPD.
- * If *c is AP_UPD or PAP, stackOptionalFun is not NULL. Otherwise,
- * it is NULL.
+ * *c is one of the following: TSO, AP_STACK.
* If *c is TSO, c == c_child_r.
* stackStart < stackEnd.
* RSET(c) and RSET(c_child_r) are valid, i.e., their
* -------------------------------------------------------------------------- */
static void
retainStack( StgClosure *c, retainer c_child_r,
- StgClosure *stackOptionalFun, StgPtr stackStart,
- StgPtr stackEnd )
+ StgPtr stackStart, StgPtr stackEnd )
{
stackElement *oldStackBoundary;
- StgPtr p, q;
- StgInfoTable *info;
+ StgPtr p;
+ StgRetInfoTable *info;
StgWord32 bitmap;
+ nat size;
#ifdef DEBUG_RETAINER
cStackSize++;
// fprintf(stderr, "retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
#endif
- if (stackOptionalFun != NULL) {
- ASSERT(get_itbl(c)->type == AP_UPD || get_itbl(c)->type == PAP);
- retainClosure(stackOptionalFun, c, c_child_r);
- } else {
- ASSERT(get_itbl(c)->type == TSO);
- ASSERT(((StgTSO *)c)->what_next != ThreadRelocated &&
- ((StgTSO *)c)->what_next != ThreadComplete &&
- ((StgTSO *)c)->what_next != ThreadKilled);
- }
-
+ ASSERT(get_itbl(c)->type != TSO ||
+ (((StgTSO *)c)->what_next != ThreadRelocated &&
+ ((StgTSO *)c)->what_next != ThreadComplete &&
+ ((StgTSO *)c)->what_next != ThreadKilled));
+
p = stackStart;
while (p < stackEnd) {
- q = *(StgPtr *)p;
+ info = get_ret_itbl((StgClosure *)p);
- //
- // Note & Todo:
- // The correctness of retainer profiling is subject to the
- // correctness of the two macros IS_ARG_TAG() and
- // LOOKS_LIKE_GHC_INFO(). Since LOOKS_LIKE_GHC_INFO() is a bit
- // precarious macro, so I believe that the current
- // implementation may not be quite safe. Also, scavenge_stack()
- // in GC.c also exploits this macro in order to identify shallow
- // pointers. I am not sure whether scavenge_stack() takes
- // further measurements to discern real shallow pointers.
- //
- // I think this can be a serious problem if a stack chunk
- // contains some word which looks like a pointer but is
- // actually, say, a word constituting a floating number.
- //
-
- // skip tagged words
- if (IS_ARG_TAG((StgWord)q)) {
- p += 1 + ARG_SIZE(q);
- continue;
- }
-
- // check if *p is a shallow closure pointer
- if (!LOOKS_LIKE_GHC_INFO(q)) {
- retainClosure((StgClosure *)q, c, c_child_r);
- p++;
- continue;
- }
-
- // regular stack objects
- info = get_itbl((StgClosure *)p);
- switch(info->type) {
- case RET_DYN:
- bitmap = ((StgRetDyn *)p)->liveness;
- p = ((StgRetDyn *)p)->payload;
- goto small_bitmap;
-
- // FUN and FUN_STATIC keep only their info pointer.
- case FUN:
- case FUN_STATIC:
- p++;
- goto follow_srt;
+ switch(info->i.type) {
case UPDATE_FRAME:
retainClosure(((StgUpdateFrame *)p)->updatee, c, c_child_r);
case STOP_FRAME:
case CATCH_FRAME:
- case SEQ_FRAME:
- case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
- bitmap = info->layout.bitmap;
+ bitmap = BITMAP_BITS(info->i.layout.bitmap);
+ size = BITMAP_SIZE(info->i.layout.bitmap);
p++;
- small_bitmap:
- while (bitmap != 0) {
- if ((bitmap & 1) == 0)
- retainClosure((StgClosure *)*p, c, c_child_r);
- p++;
- bitmap = bitmap >> 1;
- }
+ p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+
follow_srt:
- {
- StgClosure **srt, **srt_end;
+ retainSRT((StgClosure **)info->srt, info->i.srt_len, c, c_child_r);
+ continue;
- srt = (StgClosure **)(info->srt);
- srt_end = srt + info->srt_len;
- for (; srt < srt_end; srt++) {
- // See scavenge_srt() in GC.c for details.
-#ifdef ENABLE_WIN32_DLL_SUPPORT
- if ((unsigned long)(*srt) & 0x1)
- retainClosure(*(StgClosure **)(((unsigned long)*srt & ~0x1)), c, c_child_r);
- else
- retainClosure(*srt, c, c_child_r);
-#else
- retainClosure(*srt, c, c_child_r);
-#endif
- }
- }
+ case RET_BCO: {
+ StgBCO *bco;
+
+ p++;
+ retainClosure((StgClosure *)*p, c, c_child_r);
+ bco = (StgBCO *)*p;
+ p++;
+ size = BCO_BITMAP_SIZE(bco);
+ retain_large_bitmap(p, BCO_BITMAP(bco), size, c, c_child_r);
+ p += size;
continue;
+ }
+ // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
- {
- StgPtr q;
- StgLargeBitmap *large_bitmap;
- nat i;
-
- large_bitmap = info->layout.large_bitmap;
+ size = info->i.layout.large_bitmap->size;
p++;
+ retain_large_bitmap(p, info->i.layout.large_bitmap,
+ size, c, c_child_r);
+ p += size;
+ // and don't forget to follow the SRT
+ goto follow_srt;
- for (i = 0; i < large_bitmap->size; i++) {
- bitmap = large_bitmap->bitmap[i];
- q = p + sizeofW(StgWord) * 8;
- while (bitmap != 0) {
- if ((bitmap & 1) == 0)
- retainClosure((StgClosure *)*p, c, c_child_r);
- p++;
- bitmap = bitmap >> 1;
- }
- if (i + 1 < large_bitmap->size) {
- while (p < q) {
- retainClosure((StgClosure *)*p, c, c_child_r);
- p++;
- }
- }
+ // Dynamic bitmap: the mask is stored on the stack
+ case RET_DYN: {
+ StgWord dyn;
+ dyn = ((StgRetDyn *)p)->liveness;
+
+ // traverse the bitmap first
+ bitmap = GET_LIVENESS(dyn);
+ p = (P_)&((StgRetDyn *)p)->payload[0];
+ size = RET_DYN_SIZE;
+ p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+
+ // skip over the non-ptr words
+ p += GET_NONPTRS(dyn);
+
+ // follow the ptr words
+ for (size = GET_PTRS(dyn); size > 0; size--) {
+ retainClosure((StgClosure *)*p, c, c_child_r);
+ p++;
+ }
+ continue;
+ }
+
+ case RET_FUN: {
+ StgRetFun *ret_fun = (StgRetFun *)p;
+ StgFunInfoTable *fun_info;
+
+ retainClosure(ret_fun->fun, c, c_child_r);
+ fun_info = get_fun_itbl(ret_fun->fun);
+
+ p = (P_)&ret_fun->payload;
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ size = BITMAP_SIZE(fun_info->bitmap);
+ p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+ break;
+ case ARG_GEN_BIG:
+ size = ((StgLargeBitmap *)fun_info->bitmap)->size;
+ retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ size, c, c_child_r);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
+ break;
}
+ goto follow_srt;
}
- goto follow_srt;
+
default:
barf("Invalid object found in retainStack(): %d",
- (int)(info->type));
+ (int)(info->i.type));
}
}
#endif
}
+/* ----------------------------------------------------------------------------
+ * Call retainClosure for each of the children of a PAP/AP
+ * ------------------------------------------------------------------------- */
+
+static inline StgPtr
+retain_PAP (StgPAP *pap, retainer c_child_r)
+{
+ StgPtr p;
+ StgWord bitmap, size;
+ StgFunInfoTable *fun_info;
+
+ retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
+ fun_info = get_fun_itbl(pap->fun);
+ ASSERT(fun_info->i.type != PAP);
+
+ p = (StgPtr)pap->payload;
+ size = pap->n_args;
+
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ bitmap = BITMAP_BITS(fun_info->bitmap);
+ p = retain_small_bitmap(p, pap->n_args, bitmap,
+ (StgClosure *)pap, c_child_r);
+ break;
+ case ARG_GEN_BIG:
+ retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ size, (StgClosure *)pap, c_child_r);
+ p += size;
+ break;
+ case ARG_BCO:
+ retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
+ size, (StgClosure *)pap, c_child_r);
+ p += size;
+ break;
+ default:
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ p = retain_small_bitmap(p, pap->n_args, bitmap,
+ (StgClosure *)pap, c_child_r);
+ break;
+ }
+ return p;
+}
+
/* -----------------------------------------------------------------------------
* Compute the retainer set of *c0 and all its desecents by traversing.
* *cp0 is the parent of *c0, and *r0 is the most recent retainer of *c0.
* its descendants.
* Note:
* stackTop must be the same at the beginning and the exit of this function.
- * *c0 can be TSO (as well as PAP and AP_UPD).
+ * *c0 can be TSO (as well as AP_STACK).
* -------------------------------------------------------------------------- */
static void
retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
// process child
- if (typeOfc == TSO) {
+ // Special case closures: we process these all in one go rather
+ // than attempting to save the current position, because doing so
+ // would be hard.
+ switch (typeOfc) {
+ case TSO:
retainStack(c, c_child_r,
- NULL,
((StgTSO *)c)->sp,
((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
- // no more children
goto loop;
- } else if (typeOfc == PAP) {
- retainStack(c, c_child_r,
- ((StgPAP *)c)->fun,
- (StgPtr)((StgPAP *)c)->payload,
- (StgPtr)((StgPAP *)c)->payload + ((StgPAP *)c)->n_args);
- // no more children
+
+ case PAP:
+ case AP:
+ retain_PAP((StgPAP *)c, c_child_r);
goto loop;
- } else if (typeOfc == AP_UPD) {
+
+ case AP_STACK:
+ retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
retainStack(c, c_child_r,
- ((StgAP_UPD *)c)->fun,
- (StgPtr)((StgAP_UPD *)c)->payload,
- (StgPtr)((StgAP_UPD *)c)->payload +
- ((StgAP_UPD *)c)->n_args);
- // no more children
+ (StgPtr)((StgAP_STACK *)c)->payload,
+ (StgPtr)((StgAP_STACK *)c)->payload +
+ ((StgAP_STACK *)c)->size);
goto loop;
}
case MUT_ARR_PTRS_FROZEN:
return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
- case AP_UPD:
+ case AP:
case PAP:
return pap_sizeW((StgPAP *)c);
+ case AP:
+ return ap_stack_sizeW((StgAP_STACK *)c);
+
case ARR_WORDS:
return arr_words_sizeW((StgArrWords *)c);
case UPDATE_FRAME:
case CATCH_FRAME:
case STOP_FRAME:
- case SEQ_FRAME:
case RET_DYN:
case RET_BCO:
case RET_SMALL:
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.19 2002/07/18 06:07:37 sof Exp $
+ * $Id$
*
* (c) The GHC Team, 1998-1999
*
#define IF_DEBUG(c,s) doNothing()
#endif
+#ifdef DEBUG
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) doNothing()
+#endif
+
#if defined(GRAN) && defined(DEBUG)
#define IF_GRAN_DEBUG(c,s) if (RtsFlags.GranFlags.Debug.c) { s; }
#else
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.37 2002/12/02 14:33:10 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.38 2002/12/11 15:36:47 simonmar Exp $
*
* (c) The GHC Team, 1998-2001
*
#include "OSThreads.h"
#include "Schedule.h"
+#include <stdlib.h>
+
#if defined(RTS_SUPPORTS_THREADS)
/* Cheesy locking scheme while waiting for the
* RTS API to change.
case Success:
return;
case Killed:
- barf("%s: uncaught exception",site);
+ prog_belch("%s: uncaught exception",site);
+ stg_exit(EXIT_FAILURE);
case Interrupted:
- barf("%s: interrupted", site);
+ prog_belch("%s: interrupted", site);
+ stg_exit(EXIT_FAILURE);
default:
- barf("%s: Return code (%d) not ok",(site),(rc));
+ prog_belch("%s: Return code (%d) not ok",(site),(rc));
+ stg_exit(EXIT_FAILURE);
}
}
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.61 2002/10/05 22:18:45 panne Exp $
+ * $Id: RtsFlags.c,v 1.62 2002/12/11 15:36:47 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
char *debug_opts_prefix[] = {
"_-", /* scheduler */
- "_.", /* evaluator */
+ "_.", /* interpreter */
"_,", /* codegen */
"_;", /* weak */
"_~", /* gccafs */
#ifdef DEBUG
RtsFlags.DebugFlags.scheduler = rtsFalse;
- RtsFlags.DebugFlags.evaluator = rtsFalse;
+ RtsFlags.DebugFlags.interpreter = rtsFalse;
RtsFlags.DebugFlags.codegen = rtsFalse;
RtsFlags.DebugFlags.weak = rtsFalse;
RtsFlags.DebugFlags.gccafs = rtsFalse;
"",
#if defined(DEBUG)
" -Ds DEBUG: scheduler",
-" -De DEBUG: evaluator",
+" -Di DEBUG: interpreter",
" -Dc DEBUG: codegen",
" -Dw DEBUG: weak",
" -DG DEBUG: gccafs",
case 's':
RtsFlags.DebugFlags.scheduler = rtsTrue;
break;
- case 'e':
- RtsFlags.DebugFlags.evaluator = rtsTrue;
+ case 'i':
+ RtsFlags.DebugFlags.interpreter = rtsTrue;
break;
case 'c':
RtsFlags.DebugFlags.codegen = rtsTrue;
case 'l':
RtsFlags.DebugFlags.linker = rtsTrue;
break;
+ case 'a':
+ RtsFlags.DebugFlags.apply = rtsTrue;
+ break;
default:
bad_option( rts_argv[arg] );
}
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.66 2002/08/16 13:29:06 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.67 2002/12/11 15:36:48 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
bd = allocGroup(INIT_STACK_BLOCKS);
init_stack = (F_ *)bd->start;
init_stack[init_sp++] = (F_)stg_init_ret;
- init_stack[init_sp++] = (F_)__stginit_Prelude;
+// init_stack[init_sp++] = (F_)__stginit_Prelude;
if (init_root != NULL) {
init_stack[init_sp++] = (F_)init_root;
}
#endif
void
-stg_exit(I_ n)
+stg_exit(int n)
{
#ifdef PAR
/* HACK: avoid a loop when exiting due to a stupid error */
/* -----------------------------------------------------------------------------
- * $Id: RtsUtils.c,v 1.28 2002/10/05 22:31:04 panne Exp $
+ * $Id: RtsUtils.c,v 1.29 2002/12/11 15:36:48 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* General utility functions used in the RTS.
*
#include <string.h>
#include <stdarg.h>
-/* variable-argument error function. */
+/* variable-argument internal error function. */
-void barf(char *s, ...)
+void
+barf(char *s, ...)
{
va_list ap;
va_start(ap,s);
/* don't fflush(stdout); WORKAROUND bug in Linux glibc */
if (prog_argv != NULL && prog_argv[0] != NULL) {
- fprintf(stderr, "%s: fatal error: ", prog_argv[0]);
+ fprintf(stderr, "%s: internal error: ", prog_argv[0]);
} else {
- fprintf(stderr, "fatal error: ");
+ fprintf(stderr, "internal error: ");
}
vfprintf(stderr, s, ap);
fprintf(stderr, "\n");
+ fprintf(stderr, " Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n or http://www.sourceforge.net/projects/ghc/\n");
fflush(stderr);
stg_exit(EXIT_INTERNAL_ERROR);
va_end(ap);
}
-void prog_belch(char *s, ...)
+void
+prog_belch(char *s, ...)
{
va_list ap;
va_start(ap,s);
va_end(ap);
}
-void belch(char *s, ...)
+void
+belch(char *s, ...)
{
va_list ap;
va_start(ap,s);
(lnat)((x)%(ullong)1000));
return s;
}
+
+
+// Can be used as a breakpoint to set on every heap check failure.
+#ifdef DEBUG
+void
+heapCheckFail( void )
+{
+}
+#endif
+
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.30 2001/08/14 13:40:09 sewardj Exp $
+ * $Id: Sanity.c,v 1.31 2002/12/11 15:36:48 simonmar Exp $
*
* (c) The GHC Team, 1998-2001
*
#include "Storage.h"
#include "Schedule.h"
#include "StoragePriv.h" // for END_OF_STATIC_LIST
-
-/* -----------------------------------------------------------------------------
- A valid pointer is either:
-
- - a pointer to a static closure, or
- - a pointer into the heap, and
- - the block is not free
- - either: - the object is large, or
- - it is not after the free pointer in the block
- - the contents of the pointer is not 0xaaaaaaaa
-
- -------------------------------------------------------------------------- */
-
-#define LOOKS_LIKE_PTR(r) \
- ({ bdescr *bd = Bdescr((P_)r); \
- LOOKS_LIKE_STATIC_CLOSURE(r) || \
- (HEAP_ALLOCED(r) \
- && bd != (void *)-1 \
- && ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa) \
- ); \
- })
-
-// NOT always true, but can be useful for spotting bugs: (generally
-// true after GC, but not for things just allocated using allocate(),
-// for example):
-// (bd->flags & BF_LARGE || bd->free > (P_)r)
+#include "Apply.h"
/* -----------------------------------------------------------------------------
Forward decls.
-------------------------------------------------------------------------- */
-static StgOffset checkStackClosure ( StgClosure* c );
-static StgOffset checkStackObject ( StgPtr sp );
-static StgOffset checkSmallBitmap ( StgPtr payload, StgWord bitmap );
-static StgOffset checkLargeBitmap ( StgPtr payload, StgLargeBitmap* );
-static void checkClosureShallow ( StgClosure* p );
+static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, nat );
+static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, nat );
+static void checkClosureShallow ( StgClosure * );
/* -----------------------------------------------------------------------------
Check stack sanity
-------------------------------------------------------------------------- */
-static StgOffset
-checkSmallBitmap( StgPtr payload, StgWord bitmap )
+static void
+checkSmallBitmap( StgPtr payload, StgWord bitmap, nat size )
{
- StgOffset i;
+ StgPtr p;
+ nat i;
- i = 0;
- for(; bitmap != 0; ++i, bitmap >>= 1 ) {
+ p = payload;
+ for(i = 0; i < size; i++, bitmap >>= 1 ) {
if ((bitmap & 1) == 0) {
- checkClosure((StgClosure *)payload[i]);
+ checkClosureShallow((StgClosure *)payload[i]);
}
}
- return i;
}
-static StgOffset
-checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
+static void
+checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, nat size )
{
StgWord bmp;
- StgOffset i;
+ nat i, j;
i = 0;
- for (bmp=0; bmp<large_bitmap->size; bmp++) {
+ for (bmp=0; i < size; bmp++) {
StgWord bitmap = large_bitmap->bitmap[bmp];
- for(; bitmap != 0; ++i, bitmap >>= 1 ) {
+ j = 0;
+ for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
if ((bitmap & 1) == 0) {
- checkClosure((StgClosure *)payload[i]);
+ checkClosureShallow((StgClosure *)payload[i]);
}
}
}
- return i;
-}
-
-static StgOffset
-checkStackClosure( StgClosure* c )
-{
- const StgInfoTable* info = get_itbl(c);
-
- /* All activation records have 'bitmap' style layout info. */
- switch (info->type) {
- case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
- {
- StgRetDyn* r = (StgRetDyn *)c;
- return sizeofW(StgRetDyn) +
- checkSmallBitmap(r->payload,r->liveness);
- }
- case RET_BCO: /* small bitmap (<= 32 entries) */
- case RET_SMALL:
- case RET_VEC_SMALL:
- return 1 + checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
-
- case UPDATE_FRAME:
- ASSERT(LOOKS_LIKE_PTR(((StgUpdateFrame*)c)->updatee));
- case CATCH_FRAME:
- case SEQ_FRAME:
- /* check that the link field points to another stack frame */
- ASSERT(get_itbl(((StgFrame*)c)->link)->type == UPDATE_FRAME ||
- get_itbl(((StgFrame*)c)->link)->type == CATCH_FRAME ||
- get_itbl(((StgFrame*)c)->link)->type == STOP_FRAME ||
- get_itbl(((StgFrame*)c)->link)->type == SEQ_FRAME);
- /* fall through */
- case STOP_FRAME:
-#if defined(GRAN)
- return 2 +
-#else
- return 1 +
-#endif
- checkSmallBitmap((StgPtr)c + 1,info->layout.bitmap);
- case RET_BIG: /* large bitmap (> 32 entries) */
- case RET_VEC_BIG:
- return 1 + checkLargeBitmap((StgPtr)c + 1,info->layout.large_bitmap);
- case FUN:
- case FUN_STATIC: /* probably a slow-entry point return address: */
-#if 0 && defined(GRAN)
- return 2;
-#else
- return 1;
-#endif
- default:
- /* if none of the above, maybe it's a closure which looks a
- * little like an infotable
- */
- checkClosureShallow(*(StgClosure **)c);
- return 1;
- /* barf("checkStackClosure: weird activation record found on stack (%p).",c); */
- }
}
/*
* chunks.
*/
-void
+static void
checkClosureShallow( StgClosure* p )
{
- ASSERT(p);
- ASSERT(LOOKS_LIKE_GHC_INFO(GET_INFO(p))
- || IS_HUGS_CONSTR_INFO(GET_INFO(p)));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
- /* Is it a static closure (i.e. in the data segment)? */
- if (LOOKS_LIKE_STATIC(p)) {
+ /* Is it a static closure? */
+ if (!HEAP_ALLOCED(p)) {
ASSERT(closure_STATIC(p));
} else {
ASSERT(!closure_STATIC(p));
- ASSERT(LOOKS_LIKE_PTR(p));
}
}
// check an individual stack object
StgOffset
-checkStackObject( StgPtr sp )
+checkStackFrame( StgPtr c )
{
- if (IS_ARG_TAG(*sp)) {
- // Tagged words might be "stubbed" pointers, so there's no
- // point checking to see whether they look like pointers or
- // not (some of them will).
- return ARG_SIZE(*sp) + 1;
- } else if (LOOKS_LIKE_GHC_INFO(*(StgPtr *)sp)) {
- return checkStackClosure((StgClosure *)sp);
- } else { // must be an untagged closure pointer in the stack
- checkClosureShallow(*(StgClosure **)sp);
- return 1;
+ nat size;
+ const StgRetInfoTable* info;
+
+ info = get_ret_itbl((StgClosure *)c);
+
+ /* All activation records have 'bitmap' style layout info. */
+ switch (info->i.type) {
+ case RET_DYN: /* Dynamic bitmap: the mask is stored on the stack */
+ {
+ StgWord dyn;
+ StgPtr p;
+ StgRetDyn* r;
+
+ r = (StgRetDyn *)c;
+ dyn = r->liveness;
+
+ p = (P_)(r->payload);
+ checkSmallBitmap(p,GET_LIVENESS(r->liveness),RET_DYN_SIZE);
+ p += RET_DYN_SIZE;
+
+ // skip over the non-pointers
+ p += GET_NONPTRS(dyn);
+
+ // follow the ptr words
+ for (size = GET_PTRS(dyn); size > 0; size--) {
+ checkClosureShallow((StgClosure *)*p);
+ p++;
+ }
+
+ return sizeofW(StgRetDyn) + RET_DYN_SIZE +
+ GET_NONPTRS(dyn) + GET_PTRS(dyn);
+ }
+
+ case UPDATE_FRAME:
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgUpdateFrame*)c)->updatee));
+ case CATCH_FRAME:
+ // small bitmap cases (<= 32 entries)
+ case STOP_FRAME:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ size = BITMAP_SIZE(info->i.layout.bitmap);
+ checkSmallBitmap((StgPtr)c + 1,
+ BITMAP_BITS(info->i.layout.bitmap), size);
+ return 1 + size;
+
+ case RET_BCO: {
+ StgBCO *bco;
+ nat size;
+ bco = (StgBCO *)*(c+1);
+ size = BCO_BITMAP_SIZE(bco);
+ checkLargeBitmap((StgPtr)c + 2, BCO_BITMAP(bco), size);
+ return 2 + size;
+ }
+
+ case RET_BIG: // large bitmap (> 32 entries)
+ case RET_VEC_BIG:
+ size = info->i.layout.large_bitmap->size;
+ checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size);
+ return 1 + size;
+
+ case RET_FUN:
+ {
+ StgFunInfoTable *fun_info;
+ StgRetFun *ret_fun;
+
+ ret_fun = (StgRetFun *)c;
+ fun_info = get_fun_itbl(ret_fun->fun);
+ size = ret_fun->size;
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ checkSmallBitmap((StgPtr)ret_fun->payload,
+ BITMAP_BITS(fun_info->bitmap), size);
+ break;
+ case ARG_GEN_BIG:
+ checkLargeBitmap((StgPtr)ret_fun->payload,
+ (StgLargeBitmap *)fun_info->bitmap, size);
+ break;
+ default:
+ checkSmallBitmap((StgPtr)ret_fun->payload,
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
+ size);
+ break;
+ }
+ return sizeofW(StgRetFun) + size;
+ }
+
+ default:
+ barf("checkStackFrame: weird activation record found on stack (%p).",c);
}
}
p = sp;
while (p < stack_end) {
- p += checkStackObject( p );
+ p += checkStackFrame( p );
}
// ASSERT( p == stack_end ); -- HWL
}
{
const StgInfoTable *info;
- ASSERT(LOOKS_LIKE_GHC_INFO(p->header.info));
+ ASSERT(LOOKS_LIKE_INFO_PTR(p->header.info));
/* Is it a static closure (i.e. in the data segment)? */
- if (LOOKS_LIKE_STATIC(p)) {
+ if (!HEAP_ALLOCED(p)) {
ASSERT(closure_STATIC(p));
} else {
ASSERT(!closure_STATIC(p));
- ASSERT(LOOKS_LIKE_PTR(p));
}
info = get_itbl(p);
case MVAR:
{
StgMVar *mvar = (StgMVar *)p;
- ASSERT(LOOKS_LIKE_PTR(mvar->head));
- ASSERT(LOOKS_LIKE_PTR(mvar->tail));
- ASSERT(LOOKS_LIKE_PTR(mvar->value));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
#if 0
#if defined(PAR)
checkBQ((StgBlockingQueueElement *)mvar->head, p);
{
nat i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
- ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
}
return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
}
{
nat i;
for (i = 0; i < info->layout.payload.ptrs; i++) {
- ASSERT(LOOKS_LIKE_PTR(p->payload[i]));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
}
return sizeW_fromITBL(info);
}
case IND_STATIC: /* (1, 0) closure */
- ASSERT(LOOKS_LIKE_PTR(((StgIndStatic*)p)->indirectee));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgIndStatic*)p)->indirectee));
return sizeW_fromITBL(info);
case WEAK:
* representative of the actual layout.
*/
{ StgWeak *w = (StgWeak *)p;
- ASSERT(LOOKS_LIKE_PTR(w->key));
- ASSERT(LOOKS_LIKE_PTR(w->value));
- ASSERT(LOOKS_LIKE_PTR(w->finalizer));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->key));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->value));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->finalizer));
if (w->link) {
- ASSERT(LOOKS_LIKE_PTR(w->link));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(w->link));
}
return sizeW_fromITBL(info);
}
case THUNK_SELECTOR:
- ASSERT(LOOKS_LIKE_PTR(((StgSelector *)p)->selectee));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgSelector *)p)->selectee));
return sizeofW(StgHeader) + MIN_UPD_SIZE;
case IND:
*/
P_ q;
StgInd *ind = (StgInd *)p;
- ASSERT(LOOKS_LIKE_PTR(ind->indirectee));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
q = (P_)p + sizeofW(StgInd);
while (!*q) { q++; }; /* skip padding words (see GC.c: evacuate())*/
return q - (P_)p;
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
- case SEQ_FRAME:
barf("checkClosure: stack frame");
- case AP_UPD: /* we can treat this as being the same as a PAP */
+ case AP: /* we can treat this as being the same as a PAP */
case PAP:
{
- StgPAP *pap = (StgPAP *)p;
- ASSERT(LOOKS_LIKE_PTR(pap->fun));
- checkStackChunk((StgPtr)pap->payload,
- (StgPtr)pap->payload + pap->n_args
- );
+ StgFunInfoTable *fun_info;
+ StgPAP* pap = (StgPAP *)p;
+
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(pap->fun));
+ fun_info = get_fun_itbl(pap->fun);
+
+ p = (StgClosure *)pap->payload;
+ switch (fun_info->fun_type) {
+ case ARG_GEN:
+ checkSmallBitmap( (StgPtr)pap->payload,
+ BITMAP_BITS(fun_info->bitmap), pap->n_args );
+ break;
+ case ARG_GEN_BIG:
+ checkLargeBitmap( (StgPtr)pap->payload,
+ (StgLargeBitmap *)fun_info->bitmap,
+ pap->n_args );
+ break;
+ case ARG_BCO:
+ checkLargeBitmap( (StgPtr)pap->payload,
+ BCO_BITMAP(pap->fun),
+ pap->n_args );
+ break;
+ default:
+ checkSmallBitmap( (StgPtr)pap->payload,
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
+ pap->n_args );
+ break;
+ }
return pap_sizeW(pap);
}
+ case AP_STACK:
+ {
+ StgAP_STACK *ap = (StgAP_STACK *)p;
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ap->fun));
+ checkStackChunk((StgPtr)ap->payload, (StgPtr)ap->payload + ap->size);
+ return ap_stack_sizeW(ap);
+ }
+
case ARR_WORDS:
return arr_words_sizeW((StgArrWords *)p);
StgMutArrPtrs* a = (StgMutArrPtrs *)p;
nat i;
for (i = 0; i < a->ptrs; i++) {
- ASSERT(LOOKS_LIKE_PTR(a->payload[i]));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
}
return mut_arr_ptrs_sizeW(a);
}
case BLOCKED_FETCH:
ASSERT(LOOKS_LIKE_GA(&(((StgBlockedFetch *)p)->ga)));
- ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR((((StgBlockedFetch *)p)->node)));
return sizeofW(StgBlockedFetch); // see size used in evacuate()
#ifdef DIST
ASSERT(((StgRBH *)p)->blocking_queue!=NULL);
if (((StgRBH *)p)->blocking_queue!=END_BQ_QUEUE)
checkBQ(((StgRBH *)p)->blocking_queue, p);
- ASSERT(LOOKS_LIKE_GHC_INFO(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
+ ASSERT(LOOKS_LIKE_INFO_PTR(REVERT_INFOPTR(get_itbl((StgClosure *)p))));
return BLACKHOLE_sizeW(); // see size used in evacuate()
// sizeW_fromITBL(REVERT_INFOPTR(get_itbl((StgClosure *)p)));
/* skip over slop */
while (p < bd->free &&
- (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
+ (*p < 0x1000 || !LOOKS_LIKE_INFO_PTR((void*)*p))) { p++; }
}
}
}
nat size;
for (p=start; p<end; p+=size) {
- ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
+ ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
*(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
/* if it's a FM created during unpack and commoned up, it's not global */
nat size;
for (p=start; p<end; p+=size) {
- ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
+ ASSERT(LOOKS_LIKE_INFO_PTR((void*)*p));
size = checkClosure((StgClosure *)p);
/* This is the smallest size of closure that can live in the heap. */
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
}
}
-/* check stack - making sure that update frames are linked correctly */
-void
-checkStack(StgPtr sp, StgPtr stack_end, StgUpdateFrame* su )
-{
- /* check everything down to the first update frame */
- checkStackChunk( sp, (StgPtr)su );
- while ( (StgPtr)su < stack_end) {
- sp = (StgPtr)su;
- switch (get_itbl(su)->type) {
- case UPDATE_FRAME:
- su = su->link;
- break;
- case SEQ_FRAME:
- su = ((StgSeqFrame *)su)->link;
- break;
- case CATCH_FRAME:
- su = ((StgCatchFrame *)su)->link;
- break;
- case STOP_FRAME:
- /* not quite: ASSERT((StgPtr)su == stack_end); */
- return;
- default:
- barf("checkStack: weird record found on update frame list.");
- }
- checkStackChunk( sp, (StgPtr)su );
- }
- ASSERT((StgPtr)su == stack_end);
-}
-
-
void
checkTSO(StgTSO *tso)
{
StgPtr sp = tso->sp;
StgPtr stack = tso->stack;
- StgUpdateFrame* su = tso->su;
StgOffset stack_size = tso->stack_size;
StgPtr stack_end = stack + stack_size;
return;
}
- if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
+ if (tso->what_next == ThreadKilled) {
/* The garbage collector doesn't bother following any pointers
* from dead threads, so don't check sanity here.
*/
}
ASSERT(stack <= sp && sp < stack_end);
- ASSERT(sp <= (StgPtr)su);
#if defined(PAR)
ASSERT(tso->par.magic==TSO_MAGIC);
get_itbl(tso->link)->type == CONSTR);
#endif
- checkStack(sp, stack_end, su);
+ checkStackChunk(sp, stack_end);
}
#if defined(GRAN)
extern StgTSO *all_threads;
StgTSO *tso;
for (tso=all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
- ASSERT(LOOKS_LIKE_PTR(tso));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso));
ASSERT(get_itbl(tso)->type == TSO);
if (checkTSOs)
checkTSO(tso);
bd = Bdescr((P_)p);
ASSERT(closure_MUTABLE(p));
ASSERT(bd->gen_no == gen);
- ASSERT(LOOKS_LIKE_PTR(p->mut_link));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
}
}
ASSERT(!closure_MUTABLE(p));
ASSERT(ip_STATIC(info) || bd->gen_no == gen);
- ASSERT(LOOKS_LIKE_PTR(p->mut_link));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->mut_link));
switch (info->type) {
case IND_STATIC:
}
}
-/* -----------------------------------------------------------------------------
- Check Blackhole Sanity
-
- Test whether an object is already on the update list.
- It isn't necessarily an rts error if it is - it might be a programming
- error.
-
- Future versions might be able to test for a blackhole without traversing
- the update frame list.
-
- -------------------------------------------------------------------------- */
-rtsBool
-isBlackhole( StgTSO* tso, StgClosure* p )
-{
- StgUpdateFrame* su = tso->su;
- do {
- switch (get_itbl(su)->type) {
- case UPDATE_FRAME:
- if (su->updatee == p) {
- return rtsTrue;
- } else {
- su = su->link;
- }
- break;
- case SEQ_FRAME:
- su = ((StgSeqFrame *)su)->link;
- break;
- case CATCH_FRAME:
- su = ((StgCatchFrame *)su)->link;
- break;
- case STOP_FRAME:
- return rtsFalse;
- default:
- barf("isBlackhole: weird record found on update frame list.");
- }
- } while (1);
-}
-
/*
Check the static objects list.
*/
{
StgClosure *indirectee = ((StgIndStatic *)p)->indirectee;
- ASSERT(LOOKS_LIKE_PTR(indirectee));
- ASSERT(LOOKS_LIKE_GHC_INFO(indirectee->header.info));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(indirectee));
+ ASSERT(LOOKS_LIKE_INFO_PTR(indirectee->header.info));
p = IND_STATIC_LINK((StgClosure *)p);
break;
}
n++;
gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
ASSERT(!gala->preferred || gala == gala0);
- ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
+ ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
ASSERT(gala->next!=gala); // detect direct loops
if ( check_closures ) {
checkClosure((StgClosure *)gala->la);
m++;
gala0 = lookupHashTable(LAtoGALAtable, (StgWord) gala->la);
ASSERT(!gala->preferred || gala == gala0);
- ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
+ ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)gala->la)->header.info));
ASSERT(gala->next!=gala); // detect direct loops
/*
if ( check_closures ) {
/* -----------------------------------------------------------------------------
- * $Id: Sanity.h,v 1.9 2001/07/23 17:23:19 simonmar Exp $
+ * $Id: Sanity.h,v 1.10 2002/12/11 15:36:50 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void checkHeap ( bdescr *bd );
extern void checkHeapChunk ( StgPtr start, StgPtr end );
extern void checkChain ( bdescr *bd );
-extern void checkStack ( StgPtr sp, StgPtr stack_end, StgUpdateFrame* su );
extern void checkTSO ( StgTSO* tso );
extern void checkGlobalTSOList ( rtsBool checkTSOs );
extern void checkStaticObjects ( StgClosure* static_objects );
extern void checkStackChunk ( StgPtr sp, StgPtr stack_end );
+extern StgOffset checkStackFrame ( StgPtr sp );
extern StgOffset checkClosure ( StgClosure* p );
extern void checkMutableList ( StgMutClosure *p, nat gen );
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.158 2002/12/10 13:38:40 wolfgang Exp $
+ * $Id: Schedule.c,v 1.159 2002/12/11 15:36:50 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#if DEBUG
static char *whatNext_strs[] = {
- "ThreadEnterGHC",
"ThreadRunGHC",
- "ThreadEnterInterp",
+ "ThreadInterpret",
"ThreadKilled",
+ "ThreadRelocated",
"ThreadComplete"
};
#endif
# endif
#endif
rtsBool was_interrupted = rtsFalse;
+ StgTSOWhatNext prev_what_next;
ACQUIRE_LOCK(&sched_mutex);
switch (m->tso->what_next) {
case ThreadComplete:
if (m->ret) {
- *(m->ret) = (StgClosure *)m->tso->sp[0];
+ // NOTE: return val is tso->sp[1] (see StgStartup.hc)
+ *(m->ret) = (StgClosure *)m->tso->sp[1];
}
*prev = m->link;
m->stat = Success;
#endif
main_threads = main_threads->link;
if (m->tso->what_next == ThreadComplete) {
- /* we finished successfully, fill in the return value */
- if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
- m->stat = Success;
- return;
+ // We finished successfully, fill in the return value
+ // NOTE: return val is tso->sp[1] (see StgStartup.hc)
+ if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[1]; };
+ m->stat = Success;
+ return;
} else {
if (m->ret) { *(m->ret) = NULL; };
if (was_interrupted) {
* the user specified "context switch as often as possible", with
* +RTS -C0
*/
- if (
-#ifdef PROFILING
- RtsFlags.ProfFlags.profileInterval == 0 ||
-#endif
- (RtsFlags.ConcFlags.ctxtSwitchTicks == 0
+ if ((RtsFlags.ConcFlags.ctxtSwitchTicks == 0
&& (run_queue_hd != END_TSO_QUEUE
|| blocked_queue_hd != END_TSO_QUEUE
|| sleeping_queue != END_TSO_QUEUE)))
RELEASE_LOCK(&sched_mutex);
- IF_DEBUG(scheduler, sched_belch("-->> Running TSO %ld (%p) %s ...",
- t->id, t, whatNext_strs[t->what_next]));
+ IF_DEBUG(scheduler, sched_belch("-->> running thread %ld %s ...",
+ t->id, whatNext_strs[t->what_next]));
#ifdef PROFILING
startHeapProfTimer();
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* Run the current thread
*/
- switch (cap->r.rCurrentTSO->what_next) {
+ prev_what_next = t->what_next;
+ switch (prev_what_next) {
case ThreadKilled:
case ThreadComplete:
/* Thread already finished, return to scheduler. */
ret = ThreadFinished;
break;
- case ThreadEnterGHC:
- ret = StgRun((StgFunPtr) stg_enterStackTop, &cap->r);
- break;
case ThreadRunGHC:
ret = StgRun((StgFunPtr) stg_returnToStackTop, &cap->r);
break;
- case ThreadEnterInterp:
+ case ThreadInterpret:
ret = interpretBCO(cap);
break;
default:
blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc * sizeof(W_)) / BLOCK_SIZE;
- IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped: requesting a large block (size %d)",
- t->id, t,
- whatNext_strs[t->what_next], blocks));
+ IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: requesting a large block (size %d)",
+ t->id, whatNext_strs[t->what_next], blocks));
// don't do this if it would push us over the
// alloc_blocks_lim limit; we'll GC first.
x->step = g0s0;
x->gen_no = 0;
x->flags = 0;
- x->free = x->start;
}
}
// don't forget to update the block count in g0s0.
g0s0->n_blocks += blocks;
+ // This assert can be a killer if the app is doing lots
+ // of large block allocations.
ASSERT(countBlocks(g0s0->blocks) == g0s0->n_blocks);
// now update the nursery to point to the new block
* maybe set context_switch and wait till they all pile in,
* then have them wait on a GC condition variable.
*/
- IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped: HeapOverflow",
- t->id, t, whatNext_strs[t->what_next]));
+ IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: HeapOverflow",
+ t->id, whatNext_strs[t->what_next]));
threadPaused(t);
#if defined(GRAN)
ASSERT(!is_on_queue(t,CurrentProc));
// DumpGranEvent(GR_DESCHEDULE, t);
globalParStats.tot_stackover++;
#endif
- IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped, StackOverflow",
- t->id, t, whatNext_strs[t->what_next]));
+ IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped, StackOverflow",
+ t->id, whatNext_strs[t->what_next]));
/* just adjust the stack for this thread, then pop it back
* on the run queue.
*/
* GC is finished.
*/
IF_DEBUG(scheduler,
- if (t->what_next == ThreadEnterInterp) {
+ if (t->what_next != prev_what_next) {
/* ToDo: or maybe a timer expired when we were in Hugs?
* or maybe someone hit ctrl-C
*/
- belch("--<< thread %ld (%p; %s) stopped to switch to Hugs",
- t->id, t, whatNext_strs[t->what_next]);
+ belch("--<< thread %ld (%s) stopped to switch evaluators",
+ t->id, whatNext_strs[t->what_next]);
} else {
- belch("--<< thread %ld (%p; %s) stopped, yielding",
- t->id, t, whatNext_strs[t->what_next]);
+ belch("--<< thread %ld (%s) stopped, yielding",
+ t->id, whatNext_strs[t->what_next]);
}
);
PUSH_ON_RUN_QUEUE(t);
}
#else
- /* this does round-robin scheduling; good for concurrency */
- APPEND_TO_RUN_QUEUE(t);
+ if (t->what_next != prev_what_next) {
+ // switching evaluators; don't context-switch
+ PUSH_ON_RUN_QUEUE(t);
+ } else {
+ // this does round-robin scheduling; good for concurrency
+ APPEND_TO_RUN_QUEUE(t);
+ }
#endif
#if defined(GRAN)
/* add a ContinueThread event to actually process the thread */
G_CURR_THREADQ(0));
#endif /* GRAN */
break;
-
+
case ThreadBlocked:
#if defined(GRAN)
IF_DEBUG(scheduler,
* case it'll be on the relevant queue already.
*/
IF_DEBUG(scheduler,
- fprintf(stderr, "--<< thread %d (%p) stopped: ", t->id, t);
+ fprintf(stderr, "--<< thread %d (%s) stopped: ",
+ t->id, whatNext_strs[t->what_next]);
printThreadBlockage(t);
fprintf(stderr, "\n"));
/* We also end up here if the thread kills itself with an
* uncaught exception, see Exception.hc.
*/
- IF_DEBUG(scheduler,belch("--++ thread %d (%p) finished", t->id, t));
+ IF_DEBUG(scheduler,belch("--++ thread %d (%s) finished",
+ t->id, whatNext_strs[t->what_next]));
#if defined(GRAN)
endThread(t, CurrentProc); // clean-up the thread
#elif defined(PAR)
}
#ifdef PROFILING
- if (RtsFlags.ProfFlags.profileInterval==0 || performHeapProfile) {
+ // When we have +RTS -i0 and we're heap profiling, do a census at
+ // every GC. This lets us get repeatable runs for debugging.
+ if (performHeapProfile ||
+ (RtsFlags.ProfFlags.profileInterval==0 &&
+ RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) {
GarbageCollect(GetRoots, rtsTrue);
heapCensus();
performHeapProfile = rtsFalse;
IF_DEBUG(scheduler,
sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
+ // XXX this might not be necessary --SDM
+ cap->r.rCurrentTSO->what_next = ThreadRunGHC;
+
threadPaused(cap->r.rCurrentTSO);
cap->r.rCurrentTSO->link = suspended_ccalling_threads;
suspended_ccalling_threads = cap->r.rCurrentTSO;
#if defined(GRAN)
SET_GRAN_HDR(tso, ThisPE);
#endif
- tso->what_next = ThreadEnterGHC;
+
+ // Always start with the compiled code evaluator
+ tso->what_next = ThreadRunGHC;
/* tso->id needs to be unique. For now we use a heavyweight mutex to
* protect the increment operation on next_thread_id.
/* put a stop frame on the stack */
tso->sp -= sizeofW(StgStopFrame);
SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
- tso->su = (StgUpdateFrame*)tso->sp;
-
// ToDo: check this
#if defined(GRAN)
tso->link = END_TSO_QUEUE;
see (==> it got stuck waiting.) -- sof 6/02.
*/
ACQUIRE_LOCK(&sched_mutex);
- IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+ IF_DEBUG(scheduler, sched_belch("waiting for thread (%d)\n", tso->id));
m->link = main_threads;
main_threads = m;
/* see scheduleWaitThread() comment */
ACQUIRE_LOCK(&sched_mutex);
- IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
m->link = main_threads;
main_threads = m;
- IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+ IF_DEBUG(scheduler, sched_belch("waiting for thread %d", tso->id));
#if defined(THREADED_RTS)
return waitThread_(m, rtsFalse); // waitThread_ releases sched_mutex
#else
/* relocate the stack pointers... */
diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
- dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
dest->sp = new_sp;
dest->stack_size = new_stack_size;
- /* and relocate the update frame list */
- relocate_stack(dest, diff);
-
/* Mark the old TSO as relocated. We have to check for relocated
* TSOs in the garbage collector and any primops that deal with TSOs.
*
- * It's important to set the sp and su values to just beyond the end
+ * It's important to set the sp value to just beyond the end
* of the stack, so we don't attempt to scavenge any part of the
* dead TSO's stack.
*/
tso->what_next = ThreadRelocated;
tso->link = dest;
tso->sp = (P_)&(tso->stack[tso->stack_size]);
- tso->su = (StgUpdateFrame *)tso->sp;
tso->why_blocked = NotBlocked;
dest->mut_link = NULL;
* the top of the stack.
*
* How exactly do we save all the active computations? We create an
- * AP_UPD for every UpdateFrame on the stack. Entering one of these
- * AP_UPDs pushes everything from the corresponding update frame
+ * AP_STACK for every UpdateFrame on the stack. Entering one of these
+ * AP_STACKs pushes everything from the corresponding update frame
* upwards onto the stack. (Actually, it pushes everything up to the
- * next update frame plus a pointer to the next AP_UPD object.
- * Entering the next AP_UPD object pushes more onto the stack until we
- * reach the last AP_UPD object - at which point the stack should look
+ * next update frame plus a pointer to the next AP_STACK object.
+ * Entering the next AP_STACK object pushes more onto the stack until we
+ * reach the last AP_STACK object - at which point the stack should look
* exactly as it did when we killed the TSO and we can continue
* execution by entering the closure on top of the stack.
*
void
raiseAsync(StgTSO *tso, StgClosure *exception)
{
- StgUpdateFrame* su = tso->su;
- StgPtr sp = tso->sp;
+ StgRetInfoTable *info;
+ StgPtr sp;
- /* Thread already dead? */
- if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
- return;
- }
-
- IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
-
- /* Remove it from any blocking queues */
- unblockThread(tso);
-
- /* The stack freezing code assumes there's a closure pointer on
- * the top of the stack. This isn't always the case with compiled
- * code, so we have to push a dummy closure on the top which just
- * returns to the next return address on the stack.
- */
- if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
- *(--sp) = (W_)&stg_dummy_ret_closure;
- }
-
- while (1) {
- nat words = ((P_)su - (P_)sp) - 1;
- nat i;
- StgAP_UPD * ap;
+ // Thread already dead?
+ if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
+ return;
+ }
- ASSERT((P_)su > (P_)sp);
+ IF_DEBUG(scheduler,
+ sched_belch("raising exception in thread %ld.", tso->id));
- /* If we find a CATCH_FRAME, and we've got an exception to raise,
- * then build the THUNK raise(exception), and leave it on
- * top of the CATCH_FRAME ready to enter.
- */
- if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
-#ifdef PROFILING
- StgCatchFrame *cf = (StgCatchFrame *)su;
-#endif
- StgClosure *raise;
-
- /* we've got an exception to raise, so let's pass it to the
- * handler in this frame.
- */
- raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
- TICK_ALLOC_SE_THK(1,0);
- SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
- raise->payload[0] = exception;
-
- /* throw away the stack from Sp up to the CATCH_FRAME.
- */
- sp = (P_)su - 1;
+ // Remove it from any blocking queues
+ unblockThread(tso);
- /* Ensure that async excpetions are blocked now, so we don't get
- * a surprise exception before we get around to executing the
- * handler.
- */
- if (tso->blocked_exceptions == NULL) {
- tso->blocked_exceptions = END_TSO_QUEUE;
- }
-
- /* Put the newly-built THUNK on top of the stack, ready to execute
- * when the thread restarts.
- */
- sp[0] = (W_)raise;
- tso->sp = sp;
- tso->su = su;
- tso->what_next = ThreadEnterGHC;
- IF_DEBUG(sanity, checkTSO(tso));
- return;
- }
-
- /* First build an AP_UPD consisting of the stack chunk above the
- * current update frame, with the top word on the stack as the
- * fun field.
- */
- ap = (StgAP_UPD *)allocate(AP_sizeW(words));
+ sp = tso->sp;
- ap->n_args = words;
- ap->fun = (StgClosure *)sp[0];
- sp++;
- for(i=0; i < (nat)words; ++i) {
- ap->payload[i] = (StgClosure *)*sp++;
+ // The stack freezing code assumes there's a closure pointer on
+ // the top of the stack, so we have to arrange that this is the case...
+ //
+ if (sp[0] == (W_)&stg_enter_info) {
+ sp++;
+ } else {
+ sp--;
+ sp[0] = (W_)&stg_dummy_ret_closure;
}
-
- switch (get_itbl(su)->type) {
-
- case UPDATE_FRAME:
- {
- SET_HDR(ap,&stg_AP_UPD_info,su->header.prof.ccs /* ToDo */);
- TICK_ALLOC_UP_THK(words+1,0);
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "scheduler: Updating ");
- printPtr((P_)su->updatee);
- fprintf(stderr, " with ");
- printObj((StgClosure *)ap);
- );
-
- /* Replace the updatee with an indirection - happily
- * this will also wake up any threads currently
- * waiting on the result.
- *
- * Warning: if we're in a loop, more than one update frame on
- * the stack may point to the same object. Be careful not to
- * overwrite an IND_OLDGEN in this case, because we'll screw
- * up the mutable lists. To be on the safe side, don't
- * overwrite any kind of indirection at all. See also
- * threadSqueezeStack in GC.c, where we have to make a similar
- * check.
- */
- if (!closure_IND(su->updatee)) {
- UPD_IND_NOLOCK(su->updatee,ap); /* revert the black hole */
- }
- su = su->link;
- sp += sizeofW(StgUpdateFrame) -1;
- sp[0] = (W_)ap; /* push onto stack */
- break;
- }
- case CATCH_FRAME:
- {
- StgCatchFrame *cf = (StgCatchFrame *)su;
- StgClosure* o;
+ while (1) {
+ nat i;
+
+ // 1. Let the top of the stack be the "current closure"
+ //
+ // 2. Walk up the stack until we find either an UPDATE_FRAME or a
+ // CATCH_FRAME.
+ //
+ // 3. If it's an UPDATE_FRAME, then make an AP_STACK containing the
+ // current closure applied to the chunk of stack up to (but not
+ // including) the update frame. This closure becomes the "current
+ // closure". Go back to step 2.
+ //
+ // 4. If it's a CATCH_FRAME, then leave the exception handler on
+ // top of the stack applied to the exception.
+ //
+ // 5. If it's a STOP_FRAME, then kill the thread.
- /* We want a PAP, not an AP_UPD. Fortunately, the
- * layout's the same.
- */
- SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
- TICK_ALLOC_UPD_PAP(words+1,0);
-
- /* now build o = FUN(catch,ap,handler) */
- o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
- TICK_ALLOC_FUN(2,0);
- SET_HDR(o,&stg_catch_info,su->header.prof.ccs /* ToDo */);
- o->payload[0] = (StgClosure *)ap;
- o->payload[1] = cf->handler;
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "scheduler: Built ");
- printObj((StgClosure *)o);
- );
+ StgPtr frame;
- /* pop the old handler and put o on the stack */
- su = cf->link;
- sp += sizeofW(StgCatchFrame) - 1;
- sp[0] = (W_)o;
- break;
- }
-
- case SEQ_FRAME:
- {
- StgSeqFrame *sf = (StgSeqFrame *)su;
- StgClosure* o;
+ frame = sp + 1;
+ info = get_ret_itbl((StgClosure *)frame);
- SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
- TICK_ALLOC_UPD_PAP(words+1,0);
+ while (info->i.type != UPDATE_FRAME
+ && (info->i.type != CATCH_FRAME || exception == NULL)
+ && info->i.type != STOP_FRAME) {
+ frame += stack_frame_sizeW((StgClosure *)frame);
+ info = get_ret_itbl((StgClosure *)frame);
+ }
- /* now build o = FUN(seq,ap) */
- o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
- TICK_ALLOC_SE_THK(1,0);
- SET_HDR(o,&stg_seq_info,su->header.prof.ccs /* ToDo */);
- o->payload[0] = (StgClosure *)ap;
+ switch (info->i.type) {
+
+ case CATCH_FRAME:
+ // If we find a CATCH_FRAME, and we've got an exception to raise,
+ // then build the THUNK raise(exception), and leave it on
+ // top of the CATCH_FRAME ready to enter.
+ //
+ {
+#ifdef PROFILING
+ StgCatchFrame *cf = (StgCatchFrame *)frame;
+#endif
+ StgClosure *raise;
+
+ // we've got an exception to raise, so let's pass it to the
+ // handler in this frame.
+ //
+ raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+ TICK_ALLOC_SE_THK(1,0);
+ SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
+ raise->payload[0] = exception;
+
+ // throw away the stack from Sp up to the CATCH_FRAME.
+ //
+ sp = frame - 1;
+
+ /* Ensure that async excpetions are blocked now, so we don't get
+ * a surprise exception before we get around to executing the
+ * handler.
+ */
+ if (tso->blocked_exceptions == NULL) {
+ tso->blocked_exceptions = END_TSO_QUEUE;
+ }
+
+ /* Put the newly-built THUNK on top of the stack, ready to execute
+ * when the thread restarts.
+ */
+ sp[0] = (W_)raise;
+ sp[-1] = (W_)&stg_enter_info;
+ tso->sp = sp-1;
+ tso->what_next = ThreadRunGHC;
+ IF_DEBUG(sanity, checkTSO(tso));
+ return;
+ }
- IF_DEBUG(scheduler,
- fprintf(stderr, "scheduler: Built ");
- printObj((StgClosure *)o);
- );
+ case UPDATE_FRAME:
+ {
+ StgAP_STACK * ap;
+ nat words;
+
+ // First build an AP_STACK consisting of the stack chunk above the
+ // current update frame, with the top word on the stack as the
+ // fun field.
+ //
+ words = frame - sp - 1;
+ ap = (StgAP_STACK *)allocate(PAP_sizeW(words));
+
+ ap->size = words;
+ ap->fun = (StgClosure *)sp[0];
+ sp++;
+ for(i=0; i < (nat)words; ++i) {
+ ap->payload[i] = (StgClosure *)*sp++;
+ }
+
+ SET_HDR(ap,&stg_AP_STACK_info,
+ ((StgClosure *)frame)->header.prof.ccs /* ToDo */);
+ TICK_ALLOC_UP_THK(words+1,0);
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "scheduler: Updating ");
+ printPtr((P_)((StgUpdateFrame *)frame)->updatee);
+ fprintf(stderr, " with ");
+ printObj((StgClosure *)ap);
+ );
+
+ // Replace the updatee with an indirection - happily
+ // this will also wake up any threads currently
+ // waiting on the result.
+ //
+ // Warning: if we're in a loop, more than one update frame on
+ // the stack may point to the same object. Be careful not to
+ // overwrite an IND_OLDGEN in this case, because we'll screw
+ // up the mutable lists. To be on the safe side, don't
+ // overwrite any kind of indirection at all. See also
+ // threadSqueezeStack in GC.c, where we have to make a similar
+ // check.
+ //
+ if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
+ // revert the black hole
+ UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,ap);
+ }
+ sp += sizeofW(StgUpdateFrame) - 1;
+ sp[0] = (W_)ap; // push onto stack
+ break;
+ }
- /* pop the old handler and put o on the stack */
- su = sf->link;
- sp += sizeofW(StgSeqFrame) - 1;
- sp[0] = (W_)o;
- break;
- }
-
- case STOP_FRAME:
- /* We've stripped the entire stack, the thread is now dead. */
- sp += sizeofW(StgStopFrame) - 1;
- sp[0] = (W_)exception; /* save the exception */
- tso->what_next = ThreadKilled;
- tso->su = (StgUpdateFrame *)(sp+1);
- tso->sp = sp;
- return;
-
- default:
- barf("raiseAsync");
+ case STOP_FRAME:
+ // We've stripped the entire stack, the thread is now dead.
+ sp += sizeofW(StgStopFrame);
+ tso->what_next = ThreadKilled;
+ tso->sp = sp;
+ return;
+
+ default:
+ barf("raiseAsync");
+ }
}
- }
- barf("raiseAsync");
+ barf("raiseAsync");
}
/* -----------------------------------------------------------------------------
static void
detectBlackHoles( void )
{
- StgTSO *t = all_threads;
- StgUpdateFrame *frame;
+ StgTSO *tso = all_threads;
+ StgClosure *frame;
StgClosure *blocked_on;
+ StgRetInfoTable *info;
- for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+ for (tso = all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
- while (t->what_next == ThreadRelocated) {
- t = t->link;
- ASSERT(get_itbl(t)->type == TSO);
+ while (tso->what_next == ThreadRelocated) {
+ tso = tso->link;
+ ASSERT(get_itbl(tso)->type == TSO);
}
- if (t->why_blocked != BlockedOnBlackHole) {
+ if (tso->why_blocked != BlockedOnBlackHole) {
continue;
}
- blocked_on = t->block_info.closure;
+ blocked_on = tso->block_info.closure;
+
+ frame = (StgClosure *)tso->sp;
- for (frame = t->su; ; frame = frame->link) {
- switch (get_itbl(frame)->type) {
+ while(1) {
+ info = get_ret_itbl(frame);
+ switch (info->i.type) {
case UPDATE_FRAME:
- if (frame->updatee == blocked_on) {
+ if (((StgUpdateFrame *)frame)->updatee == blocked_on) {
/* We are blocking on one of our own computations, so
* send this thread the NonTermination exception.
*/
IF_DEBUG(scheduler,
- sched_belch("thread %d is blocked on itself", t->id));
- raiseAsync(t, (StgClosure *)NonTermination_closure);
+ sched_belch("thread %d is blocked on itself", tso->id));
+ raiseAsync(tso, (StgClosure *)NonTermination_closure);
goto done;
}
- else {
- continue;
- }
-
- case CATCH_FRAME:
- case SEQ_FRAME:
- continue;
+ frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
+ continue;
+
case STOP_FRAME:
- break;
- }
- break;
- }
+ goto done;
- done: ;
- }
+ // normal stack frames; do nothing except advance the pointer
+ default:
+ (StgPtr)frame += stack_frame_sizeW(frame);
+ }
+ }
+ done: ;
+ }
}
//@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
/* -----------------------------------------------------------------------------
- * $Id: Signals.c,v 1.30 2002/12/05 14:20:55 stolz Exp $
+ * $Id: Signals.c,v 1.31 2002/12/11 15:36:51 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
// stack full?
if (next_pending_handler == &pending_handler_buf[N_PENDING_HANDLERS]) {
- barf("too many pending signals");
+ prog_belch("too many pending signals");
+ stg_exit(EXIT_FAILURE);
}
// re-establish the signal handler, and carry on
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.36 2002/06/13 21:14:51 wolfgang Exp $
+ * $Id: StgCRun.c,v 1.37 2002/12/11 15:36:51 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg STG_UNUSED)
{
while (f) {
- IF_DEBUG(evaluator,
+ IF_DEBUG(interpreter,
fprintf(stderr,"Jumping to ");
printPtr((P_)f); fflush(stdout);
fprintf(stderr,"\n");
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.80 2002/09/17 12:34:31 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.81 2002/12/11 15:36:51 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2002
*
* Entry code for various built-in closure types.
*
*/
#define NON_ENTERABLE_ENTRY_CODE(type) \
-STGFUN(stg_##type##_entry) \
+IF_(stg_##type##_entry) \
{ \
FB_ \
- STGCALL1(barf, #type " object entered!\n"); \
+ STGCALL1(barf, #type " object entered!"); \
FE_ \
}
haven't got a good story about that yet.
*/
-/* When the returned value is in R1 and it is a pointer, so doesn't
- need tagging ... */
-#define STG_CtoI_RET_R1p_Template(label) \
- IFN_(label) \
- { \
- StgPtr bco; \
- FB_ \
- bco = ((StgPtr*)Sp)[1]; \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = R1.p; \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = bco; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
+// When the returned value is a pointer in R1...
+#define STG_CtoI_RET_R1p_Template(label) \
+ IF_(label) \
+ { \
+ FB_ \
+ Sp -= 2; \
+ Sp[1] = R1.w; \
+ Sp[0] = (W_)&stg_enter_info; \
+ JMP_(stg_yield_to_interpreter); \
+ FE_ \
}
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_0_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_1_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_2_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_3_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_4_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_5_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_6_entry);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_entry);
-
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1p,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
-
-
-
-/* When the returned value is in R1 and it isn't a pointer. */
-#define STG_CtoI_RET_R1n_Template(label) \
- IFN_(label) \
- { \
- StgPtr bco; \
- FB_ \
- bco = ((StgPtr*)Sp)[1]; \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = (StgPtr)R1.i; \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = (StgPtr)1; /* tag */ \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = bco; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
- }
-
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_0_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_1_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_2_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_3_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_4_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_5_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_6_entry);
-STG_CtoI_RET_R1n_Template(stg_ctoi_ret_R1n_7_entry);
-
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_R1n,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
-
-
-
-/* When the returned value is in F1 ... */
-#define STG_CtoI_RET_F1_Template(label) \
- IFN_(label) \
- { \
- StgPtr bco; \
- FB_ \
- bco = ((StgPtr*)Sp)[1]; \
- Sp -= sizeofW(StgFloat); \
- ASSIGN_FLT((W_*)Sp, F1); \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = (StgPtr)sizeofW(StgFloat); \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = bco; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
- }
-
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_0_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_1_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_2_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_3_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_4_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_5_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_6_entry);
-STG_CtoI_RET_F1_Template(stg_ctoi_ret_F1_7_entry);
-
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_F1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
-
-
-/* When the returned value is in D1 ... */
-#define STG_CtoI_RET_D1_Template(label) \
- IFN_(label) \
- { \
- StgPtr bco; \
- FB_ \
- bco = ((StgPtr*)Sp)[1]; \
- Sp -= sizeofW(StgDouble); \
- ASSIGN_DBL((W_*)Sp, D1); \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = (StgPtr)sizeofW(StgDouble); \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = bco; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
- }
-
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_0_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_1_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_2_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_3_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_4_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_5_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_6_entry);
-STG_CtoI_RET_D1_Template(stg_ctoi_ret_D1_7_entry);
-
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_D1,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
-
-
-/* When the returned value a VoidRep ... */
-#define STG_CtoI_RET_V_Template(label) \
- IFN_(label) \
- { \
- StgPtr bco; \
- FB_ \
- bco = ((StgPtr*)Sp)[1]; \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = 0; /* VoidRep tag */ \
- Sp -= 1; \
- ((StgPtr*)Sp)[0] = bco; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
- }
-
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_0_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_1_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_2_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_3_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_4_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_5_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_6_entry);
-STG_CtoI_RET_V_Template(stg_ctoi_ret_V_7_entry);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_0_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_1_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_2_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_3_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_4_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_5_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_6_ret);
+STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_ret);
+
+VEC_POLY_INFO_TABLE( stg_ctoi_ret_R1p, 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ RET_BCO,, EF_);
+
+// When the returned value is a pointer, but unlifted, in R1 ...
+INFO_TABLE_RET( stg_ctoi_ret_R1unpt_info, stg_ctoi_ret_R1unpt_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_R1unpt_entry)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_gc_unpt_r1_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
-VEC_POLY_INFO_TABLE(stg_ctoi_ret_V,0, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, EF_);
+// When the returned value is a non-pointer in R1 ...
+INFO_TABLE_RET( stg_ctoi_ret_R1n_info, stg_ctoi_ret_R1n_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_R1n_entry)
+{
+ FB_
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_gc_unbx_r1_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
-/* The other way round: when the interpreter returns a value to
- compiled code. The stack looks like this:
+// When the returned value is in F1 ...
+INFO_TABLE_RET( stg_ctoi_ret_F1_info, stg_ctoi_ret_F1_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_F1_entry)
+{
+ FB_
+ Sp -= 2;
+ ASSIGN_FLT(Sp+1, F1);
+ Sp[0] = (W_)&stg_gc_f1_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
- return info table (pushed by compiled code)
- return value (pushed by interpreter)
+// When the returned value is in D1 ...
+INFO_TABLE_RET( stg_ctoi_ret_D1_info, stg_ctoi_ret_D1_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_D1_entry)
+{
+ FB_
+ Sp -= 1 + sizeofW(StgDouble);
+ ASSIGN_DBL(Sp+1, D1);
+ Sp[0] = (W_)&stg_gc_d1_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
- If the value is ptr-rep'd, the interpreter simply returns to the
- scheduler, instructing it to ThreadEnterGHC.
+// When the returned value is in L1 ...
+INFO_TABLE_RET( stg_ctoi_ret_L1_info, stg_ctoi_ret_L1_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_L1_entry)
+{
+ FB_
+ Sp -= 1 + sizeofW(StgInt64);
+ ASSIGN_Word64(Sp+1, L1);
+ Sp[0] = (W_)&stg_gc_l1_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
- Otherwise (unboxed return value), we replace the top stack word,
- which must be the tag, with stg_gc_unbx_r1_info (or f1_info or d1_info),
- and return to the scheduler, instructing it to ThreadRunGHC.
+// When the returned value a VoidRep ...
+INFO_TABLE_RET( stg_ctoi_ret_V_info, stg_ctoi_ret_V_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_ctoi_ret_V_entry)
+{
+ FB_
+ Sp--;
+ Sp[0] = (W_)&stg_gc_void_info;
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
- No supporting code needed!
-*/
+// Dummy info table pushed on the top of the stack when the interpreter
+// should apply the BCO on the stack to its arguments, also on the stack.
+INFO_TABLE_RET( stg_apply_interp_info, stg_apply_interp_entry,
+ 0/* special layout */,
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/, RET_BCO,, IF_, 0, 0);
+IF_(stg_apply_interp_entry)
+{
+ FB_
+ // Just in case we end up in here... (we shouldn't)
+ JMP_(stg_yield_to_interpreter);
+ FE_
+}
+/* -----------------------------------------------------------------------------
+ Entry code for a BCO
+ -------------------------------------------------------------------------- */
-/* Entering a BCO. Heave it on the stack and defer to the
- scheduler. */
-INFO_TABLE(stg_BCO_info,stg_BCO_entry,4,0,BCO,,EF_,"BCO","BCO");
-STGFUN(stg_BCO_entry) {
+INFO_TABLE_FUN_GEN(stg_BCO_info,stg_BCO_entry,4,0,
+ 0,0,0, /* no SRT */
+ ARG_BCO, 0/*dummy arity*/, 0/*dummy bitmap*/, NULL/*slow_apply*/,
+ BCO,,IF_,"BCO","BCO");
+IF_(stg_BCO_entry) {
FB_
- Sp -= 1;
- Sp[0] = R1.w;
- JMP_(stg_yield_to_interpreter);
+ // entering a BCO means "apply it", same as a function
+ Sp -= 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_apply_interp_info;
+ JMP_(stg_yield_to_interpreter);
FE_
}
-
/* -----------------------------------------------------------------------------
Entry code for an indirection.
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_IND_info,stg_IND_entry,1,0,IND,,EF_,"IND","IND");
-STGFUN(stg_IND_entry)
+INFO_TABLE(stg_IND_info,stg_IND_entry,1,0,IND,,IF_,"IND","IND");
+IF_(stg_IND_entry)
{
FB_
TICK_ENT_DYN_IND(Node); /* tick */
FE_
}
-INFO_TABLE(stg_IND_STATIC_info,stg_IND_STATIC_entry,1,0,IND_STATIC,,EF_,"IND_STATIC","IND_STATIC");
-STGFUN(stg_IND_STATIC_entry)
+INFO_TABLE(stg_IND_STATIC_info,stg_IND_STATIC_entry,1,0,IND_STATIC,,IF_,"IND_STATIC","IND_STATIC");
+IF_(stg_IND_STATIC_entry)
{
FB_
TICK_ENT_STATIC_IND(Node); /* tick */
FE_
}
-INFO_TABLE(stg_IND_PERM_info,stg_IND_PERM_entry,1,1,IND_PERM,,EF_,"IND_PERM","IND_PERM");
-STGFUN(stg_IND_PERM_entry)
+INFO_TABLE(stg_IND_PERM_info,stg_IND_PERM_entry,1,1,IND_PERM,,IF_,"IND_PERM","IND_PERM");
+IF_(stg_IND_PERM_entry)
{
FB_
/* Don't add INDs to granularity cost */
FE_
}
-INFO_TABLE(stg_IND_OLDGEN_info,stg_IND_OLDGEN_entry,1,1,IND_OLDGEN,,EF_,"IND_OLDGEN","IND_OLDGEN");
-STGFUN(stg_IND_OLDGEN_entry)
+INFO_TABLE(stg_IND_OLDGEN_info,stg_IND_OLDGEN_entry,1,1,IND_OLDGEN,,IF_,"IND_OLDGEN","IND_OLDGEN");
+IF_(stg_IND_OLDGEN_entry)
{
FB_
TICK_ENT_STATIC_IND(Node); /* tick */
FE_
}
-INFO_TABLE(stg_IND_OLDGEN_PERM_info,stg_IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,,EF_,"IND_OLDGEN_PERM","IND_OLDGEN_PERM");
-STGFUN(stg_IND_OLDGEN_PERM_entry)
+INFO_TABLE(stg_IND_OLDGEN_PERM_info,stg_IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,,IF_,"IND_OLDGEN_PERM","IND_OLDGEN_PERM");
+IF_(stg_IND_OLDGEN_PERM_entry)
{
FB_
/* Dont: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is here only to help profiling */
* old-generation indirection.
*/
-INFO_TABLE(stg_BLACKHOLE_info, stg_BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,"BLACKHOLE","BLACKHOLE");
-STGFUN(stg_BLACKHOLE_entry)
+INFO_TABLE(stg_BLACKHOLE_info, stg_BLACKHOLE_entry,0,2,BLACKHOLE,,IF_,"BLACKHOLE","BLACKHOLE");
+IF_(stg_BLACKHOLE_entry)
{
FB_
#if defined(GRAN)
FE_
}
-INFO_TABLE(stg_BLACKHOLE_BQ_info, stg_BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,EF_,"BLACKHOLE","BLACKHOLE");
-STGFUN(stg_BLACKHOLE_BQ_entry)
+INFO_TABLE(stg_BLACKHOLE_BQ_info, stg_BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,IF_,"BLACKHOLE","BLACKHOLE");
+IF_(stg_BLACKHOLE_BQ_entry)
{
FB_
#if defined(GRAN)
#if defined(PAR) || defined(GRAN)
-INFO_TABLE(stg_RBH_info, stg_RBH_entry,1,1,RBH,,EF_,"RBH","RBH");
-STGFUN(stg_RBH_entry)
+INFO_TABLE(stg_RBH_info, stg_RBH_entry,1,1,RBH,,IF_,"RBH","RBH");
+IF_(stg_RBH_entry)
{
FB_
# if defined(GRAN)
FE_
}
-INFO_TABLE(stg_RBH_Save_0_info, stg_RBH_Save_0_entry,0,2,CONSTR,,EF_,"RBH_Save_0","RBH_Save_0");
+INFO_TABLE(stg_RBH_Save_0_info, stg_RBH_Save_0_entry,0,2,CONSTR,,IF_,"RBH_Save_0","RBH_Save_0");
NON_ENTERABLE_ENTRY_CODE(RBH_Save_0);
-INFO_TABLE(stg_RBH_Save_1_info, stg_RBH_Save_1_entry,1,1,CONSTR,,EF_,"RBH_Save_1","RBH_Save_1");
+INFO_TABLE(stg_RBH_Save_1_info, stg_RBH_Save_1_entry,1,1,CONSTR,,IF_,"RBH_Save_1","RBH_Save_1");
NON_ENTERABLE_ENTRY_CODE(RBH_Save_1);
-INFO_TABLE(stg_RBH_Save_2_info, stg_RBH_Save_2_entry,2,0,CONSTR,,EF_,"RBH_Save_2","RBH_Save_2");
+INFO_TABLE(stg_RBH_Save_2_info, stg_RBH_Save_2_entry,2,0,CONSTR,,IF_,"RBH_Save_2","RBH_Save_2");
NON_ENTERABLE_ENTRY_CODE(RBH_Save_2);
#endif /* defined(PAR) || defined(GRAN) */
/* identical to BLACKHOLEs except for the infotag */
-INFO_TABLE(stg_CAF_BLACKHOLE_info, stg_CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,EF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
-STGFUN(stg_CAF_BLACKHOLE_entry)
+INFO_TABLE(stg_CAF_BLACKHOLE_info, stg_CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,IF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
+IF_(stg_CAF_BLACKHOLE_entry)
{
FB_
#if defined(GRAN)
}
#ifdef TICKY_TICKY
-INFO_TABLE(stg_SE_BLACKHOLE_info, stg_SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,EF_,"SE_BLACKHOLE","SE_BLACKHOLE");
-STGFUN(stg_SE_BLACKHOLE_entry)
+INFO_TABLE(stg_SE_BLACKHOLE_info, stg_SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,IF_,"SE_BLACKHOLE","SE_BLACKHOLE");
+IF_(stg_SE_BLACKHOLE_entry)
{
FB_
STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
FE_
}
-INFO_TABLE(stg_SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,EF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
-STGFUN(stg_SE_CAF_BLACKHOLE_entry)
+INFO_TABLE(stg_SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,IF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
+IF_(stg_SE_CAF_BLACKHOLE_entry)
{
FB_
STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
#endif
#ifdef SMP
-INFO_TABLE(stg_WHITEHOLE_info, stg_WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,EF_,"WHITEHOLE","WHITEHOLE");
-STGFUN(stg_WHITEHOLE_entry)
+INFO_TABLE(stg_WHITEHOLE_info, stg_WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,IF_,"WHITEHOLE","WHITEHOLE");
+IF_(stg_WHITEHOLE_entry)
{
FB_
- JMP_(GET_ENTRY(R1.cl));
+ JMP_(GET_ENTRY(R1.cl));
FE_
}
#endif
NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_TSO_info, stg_TSO_entry, 0,0,TSO,,EF_,"TSO","TSO");
+INFO_TABLE(stg_TSO_info, stg_TSO_entry, 0,0,TSO,,IF_,"TSO","TSO");
NON_ENTERABLE_ENTRY_CODE(TSO);
/* -----------------------------------------------------------------------------
one is a real bug.
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_EVACUATED_info,stg_EVACUATED_entry,1,0,EVACUATED,,EF_,"EVACUATED","EVACUATED");
+INFO_TABLE(stg_EVACUATED_info,stg_EVACUATED_entry,1,0,EVACUATED,,IF_,"EVACUATED","EVACUATED");
NON_ENTERABLE_ENTRY_CODE(EVACUATED);
/* -----------------------------------------------------------------------------
live weak pointers with dead ones).
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_WEAK_info,stg_WEAK_entry,0,4,WEAK,,EF_,"WEAK","WEAK");
+INFO_TABLE(stg_WEAK_info,stg_WEAK_entry,0,4,WEAK,,IF_,"WEAK","WEAK");
NON_ENTERABLE_ENTRY_CODE(WEAK);
// It's important when turning an existing WEAK into a DEAD_WEAK
// field and break the linked list of weak pointers. Hence, we give
// DEAD_WEAK 4 non-pointer fields, the same as WEAK.
-INFO_TABLE_CONSTR(stg_DEAD_WEAK_info,stg_DEAD_WEAK_entry,0,4,0,CONSTR,,EF_,"DEAD_WEAK","DEAD_WEAK");
+INFO_TABLE_CONSTR(stg_DEAD_WEAK_info,stg_DEAD_WEAK_entry,0,4,0,CONSTR,,IF_,"DEAD_WEAK","DEAD_WEAK");
NON_ENTERABLE_ENTRY_CODE(DEAD_WEAK);
/* -----------------------------------------------------------------------------
finalizer in a weak pointer object.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(stg_NO_FINALIZER_info,stg_NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,"NO_FINALIZER","NO_FINALIZER");
+INFO_TABLE_CONSTR(stg_NO_FINALIZER_info,stg_NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"NO_FINALIZER","NO_FINALIZER");
NON_ENTERABLE_ENTRY_CODE(NO_FINALIZER);
-SET_STATIC_HDR(stg_NO_FINALIZER_closure,stg_NO_FINALIZER_info,0/*CC*/,,EI_)
+SET_STATIC_HDR(stg_NO_FINALIZER_closure,stg_NO_FINALIZER_info,0/*CC*/,,extern StgInfoTable)
, /*payload*/{} };
/* -----------------------------------------------------------------------------
Foreign Objects are unlifted and therefore never entered.
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_FOREIGN_info,stg_FOREIGN_entry,0,1,FOREIGN,,EF_,"FOREIGN","FOREIGN");
+INFO_TABLE(stg_FOREIGN_info,stg_FOREIGN_entry,0,1,FOREIGN,,IF_,"FOREIGN","FOREIGN");
NON_ENTERABLE_ENTRY_CODE(FOREIGN);
/* -----------------------------------------------------------------------------
Stable Names are unlifted too.
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_STABLE_NAME_info,stg_STABLE_NAME_entry,0,1,STABLE_NAME,,EF_,"STABLE_NAME","STABLE_NAME");
+INFO_TABLE(stg_STABLE_NAME_info,stg_STABLE_NAME_entry,0,1,STABLE_NAME,,IF_,"STABLE_NAME","STABLE_NAME");
NON_ENTERABLE_ENTRY_CODE(STABLE_NAME);
/* -----------------------------------------------------------------------------
and entry code for each type.
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_FULL_MVAR_info,stg_FULL_MVAR_entry,4,0,MVAR,,EF_,"MVAR","MVAR");
+INFO_TABLE(stg_FULL_MVAR_info,stg_FULL_MVAR_entry,4,0,MVAR,,IF_,"MVAR","MVAR");
NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);
-INFO_TABLE(stg_EMPTY_MVAR_info,stg_EMPTY_MVAR_entry,4,0,MVAR,,EF_,"MVAR","MVAR");
+INFO_TABLE(stg_EMPTY_MVAR_info,stg_EMPTY_MVAR_entry,4,0,MVAR,,IF_,"MVAR","MVAR");
NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);
/* -----------------------------------------------------------------------------
end of a linked TSO queue.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(stg_END_TSO_QUEUE_info,stg_END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,"END_TSO_QUEUE","END_TSO_QUEUE");
+INFO_TABLE_CONSTR(stg_END_TSO_QUEUE_info,stg_END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_TSO_QUEUE","END_TSO_QUEUE");
NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
-SET_STATIC_HDR(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE_info,0/*CC*/,,EI_)
+SET_STATIC_HDR(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE_info,0/*CC*/,,extern StgInfoTable)
, /*payload*/{} };
/* -----------------------------------------------------------------------------
an END_MUT_LIST closure.
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(stg_END_MUT_LIST_info,stg_END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,"END_MUT_LIST","END_MUT_LIST");
+INFO_TABLE_CONSTR(stg_END_MUT_LIST_info,stg_END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_MUT_LIST","END_MUT_LIST");
NON_ENTERABLE_ENTRY_CODE(END_MUT_LIST);
-SET_STATIC_HDR(stg_END_MUT_LIST_closure,stg_END_MUT_LIST_info,0/*CC*/,,EI_)
+SET_STATIC_HDR(stg_END_MUT_LIST_closure,stg_END_MUT_LIST_info,0/*CC*/,,extern StgInfoTable)
, /*payload*/{} };
-INFO_TABLE(stg_MUT_CONS_info, stg_MUT_CONS_entry, 1, 1, MUT_CONS, , EF_, "MUT_CONS", "MUT_CONS");
+INFO_TABLE(stg_MUT_CONS_info, stg_MUT_CONS_entry, 1, 1, MUT_CONS, , IF_, "MUT_CONS", "MUT_CONS");
NON_ENTERABLE_ENTRY_CODE(MUT_CONS);
/* -----------------------------------------------------------------------------
Exception lists
-------------------------------------------------------------------------- */
-INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST_info,stg_END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,"END_EXCEPTION_LIST","END_EXCEPTION_LIST");
+INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST_info,stg_END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_EXCEPTION_LIST","END_EXCEPTION_LIST");
NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST);
-SET_STATIC_HDR(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST_info,0/*CC*/,,EI_)
+SET_STATIC_HDR(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST_info,0/*CC*/,,extern StgInfoTable)
, /*payload*/{} };
-INFO_TABLE(stg_EXCEPTION_CONS_info, stg_EXCEPTION_CONS_entry, 1, 1, CONSTR, , EF_, "EXCEPTION_CONS", "EXCEPTION_CONS");
+INFO_TABLE(stg_EXCEPTION_CONS_info, stg_EXCEPTION_CONS_entry, 1, 1, CONSTR, , IF_, "EXCEPTION_CONS", "EXCEPTION_CONS");
NON_ENTERABLE_ENTRY_CODE(EXCEPTION_CONS);
/* -----------------------------------------------------------------------------
-------------------------------------------------------------------------- */
#define ArrayInfo(type) \
-INFO_TABLE(stg_##type##_info, stg_##type##_entry, 0, 0, type, , EF_,"" # type "","" # type "");
+INFO_TABLE(stg_##type##_info, stg_##type##_entry, 0, 0, type, , IF_,"" # type "","" # type "");
ArrayInfo(ARR_WORDS);
NON_ENTERABLE_ENTRY_CODE(ARR_WORDS);
Mutable Variables
-------------------------------------------------------------------------- */
-INFO_TABLE(stg_MUT_VAR_info, stg_MUT_VAR_entry, 1, 1, MUT_VAR, , EF_, "MUT_VAR", "MUT_VAR");
+INFO_TABLE(stg_MUT_VAR_info, stg_MUT_VAR_entry, 1, 1, MUT_VAR, , IF_, "MUT_VAR", "MUT_VAR");
NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
/* -----------------------------------------------------------------------------
- Standard Error Entry.
-
- This is used for filling in vector-table entries that can never happen,
- for instance.
- -------------------------------------------------------------------------- */
-/* No longer used; we use NULL, because a) it never happens, right? and b)
- Windows doesn't like DLL entry points being used as static initialisers
-STGFUN(stg_error_entry) \
-{ \
- FB_ \
- DUMP_ERRMSG("fatal: stg_error_entry"); \
- STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE); \
- return NULL; \
- FE_ \
-}
-*/
-/* -----------------------------------------------------------------------------
Dummy return closure
Entering this closure will just return to the address on the top of the
just enter the top stack word to start the thread. (see deleteThread)
* -------------------------------------------------------------------------- */
-INFO_TABLE(stg_dummy_ret_info, stg_dummy_ret_entry, 0, 0, CONSTR_NOCAF_STATIC, , EF_, "DUMMY_RET", "DUMMY_RET");
-STGFUN(stg_dummy_ret_entry)
-{
- W_ ret_addr;
- FB_
- ret_addr = Sp[0];
- Sp++;
- JMP_(ENTRY_CODE(ret_addr));
- FE_
-}
-SET_STATIC_HDR(stg_dummy_ret_closure,stg_dummy_ret_info,CCS_DONT_CARE,,EI_)
-, /*payload*/{} };
-
-/* -----------------------------------------------------------------------------
- Strict IO application - performing an IO action and entering its result.
-
- rts_evalIO() lets you perform Haskell IO actions from outside of Haskell-land,
- returning back to you their result. Want this result to be evaluated to WHNF
- by that time, so that we can easily get at the int/char/whatever using the
- various get{Ty} functions provided by the RTS API.
+INFO_TABLE( stg_dummy_ret_info, stg_dummy_ret_entry,
+ 0, 0, CONSTR_NOCAF_STATIC, , EF_, "DUMMY_RET", "DUMMY_RET");
- forceIO takes care of this, performing the IO action and entering the
- results that comes back.
-
- * -------------------------------------------------------------------------- */
-
-#ifdef REG_R1
-INFO_TABLE_SRT_BITMAP(stg_forceIO_ret_info,stg_forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
-STGFUN(stg_forceIO_ret_entry)
-{
- FB_
- Sp++;
- Sp -= sizeofW(StgSeqFrame);
- PUSH_SEQ_FRAME(Sp);
- JMP_(GET_ENTRY(R1.cl));
-}
-#else
-INFO_TABLE_SRT_BITMAP(stg_forceIO_ret_info,stg_forceIO_ret_entry,0,0,0,0,RET_SMALL,,EF_,0,0);
-STGFUN(stg_forceIO_ret_entry)
-{
- StgClosure *rval;
- FB_
- rval = (StgClosure *)Sp[0];
- Sp += 2;
- Sp -= sizeofW(StgSeqFrame);
- PUSH_SEQ_FRAME(Sp);
- R1.cl = rval;
- JMP_(GET_ENTRY(R1.cl));
-}
-#endif
-
-INFO_TABLE(stg_forceIO_info,stg_forceIO_entry,1,0,FUN_STATIC,,EF_,"FORCE_IO","FORCE_IO");
-FN_(stg_forceIO_entry)
+STGFUN(stg_dummy_ret_entry)
{
FB_
- /* Sp[0] contains the IO action we want to perform */
- R1.p = (P_)Sp[0];
- /* Replace it with the return continuation that enters the result. */
- Sp[0] = (W_)&stg_forceIO_ret_info;
- Sp--;
- /* Push the RealWorld# tag and enter */
- Sp[0] =(W_)REALWORLD_TAG;
- JMP_(GET_ENTRY(R1.cl));
+ JMP_(ENTRY_CODE(Sp[0]));
FE_
}
-SET_STATIC_HDR(stg_forceIO_closure,stg_forceIO_info,CCS_DONT_CARE,,EI_)
+SET_STATIC_HDR(stg_dummy_ret_closure,stg_dummy_ret_info,CCS_DONT_CARE,,extern StgInfoTable)
, /*payload*/{} };
-
/* -----------------------------------------------------------------------------
CHARLIKE and INTLIKE closures.
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.hc,v 1.19 2002/07/16 14:56:09 simonmar Exp $
+ * $Id: StgStartup.hc,v 1.20 2002/12/11 15:36:54 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Code for starting, stopping and restarting threads.
*
#define CHECK_SENSIBLE_REGS() \
ASSERT(Hp != (P_)0); \
ASSERT(Sp != (P_)0); \
- ASSERT(Su != (StgUpdateFrame *)0); \
ASSERT(SpLim != (P_)0); \
ASSERT(HpLim != (P_)0); \
- ASSERT(Sp <= (P_)Su); \
ASSERT(SpLim - RESERVED_STACK_WORDS <= Sp); \
ASSERT(HpLim >= Hp);
slot 0).
-------------------------------------------------------------------------- */
-EXTFUN(stg_stop_thread_entry);
+EXTFUN(stg_stop_thread_ret);
#if defined(PROFILING)
#define STOP_THREAD_BITMAP 3
+#define STOP_THREAD_WORDS 2
#else
#define STOP_THREAD_BITMAP 0
+#define STOP_THREAD_WORDS 0
#endif
/* VEC_POLY_INFO expects to see these names - but they should all be the same. */
-#define stg_stop_thread_0_entry stg_stop_thread_entry
-#define stg_stop_thread_1_entry stg_stop_thread_entry
-#define stg_stop_thread_2_entry stg_stop_thread_entry
-#define stg_stop_thread_3_entry stg_stop_thread_entry
-#define stg_stop_thread_4_entry stg_stop_thread_entry
-#define stg_stop_thread_5_entry stg_stop_thread_entry
-#define stg_stop_thread_6_entry stg_stop_thread_entry
-#define stg_stop_thread_7_entry stg_stop_thread_entry
-
-VEC_POLY_INFO_TABLE(stg_stop_thread,STOP_THREAD_BITMAP,0,0,0,STOP_FRAME,,EF_);
-
-STGFUN(stg_stop_thread_entry)
+#define stg_stop_thread_0_ret stg_stop_thread_ret
+#define stg_stop_thread_1_ret stg_stop_thread_ret
+#define stg_stop_thread_2_ret stg_stop_thread_ret
+#define stg_stop_thread_3_ret stg_stop_thread_ret
+#define stg_stop_thread_4_ret stg_stop_thread_ret
+#define stg_stop_thread_5_ret stg_stop_thread_ret
+#define stg_stop_thread_6_ret stg_stop_thread_ret
+#define stg_stop_thread_7_ret stg_stop_thread_ret
+
+VEC_POLY_INFO_TABLE( stg_stop_thread,
+ MK_SMALL_BITMAP(STOP_THREAD_WORDS, STOP_THREAD_BITMAP),
+ 0,0,0,STOP_FRAME,,EF_);
+
+STGFUN(stg_stop_thread_ret)
{
FB_
-
- /*
- * The final exit.
- *
- * The top-top-level closures (e.g., "main") are of type "IO a".
- * When entered, they perform an IO action and return an 'a' in R1.
- *
- * We save R1 on top of the stack where the scheduler can find it,
- * tidy up the registers and return to the scheduler.
- */
-
- /* Move Sp to the last word on the stack, and Su to just past the end
- * of the stack. We then place the return value at the top of the stack.
- */
- Sp += sizeofW(StgStopFrame) - 1;
- Su = (StgUpdateFrame *)(Sp+1);
- Sp[0] = R1.w;
+ //
+ // The final exit.
+ //
+ // The top-top-level closures (e.g., "main") are of type "IO a".
+ // When entered, they perform an IO action and return an 'a' in R1.
+ //
+ // We save R1 on top of the stack where the scheduler can find it,
+ // tidy up the registers and return to the scheduler.
+ //
+ // We Leave the stack looking like this:
+ //
+ // +----------------+
+ // | -------------------> return value
+ // +----------------+
+ // | stg_enter_info |
+ // +----------------+
+ //
+ // The stg_enter_info is just a dummy info table so that the
+ // garbage collector can understand the stack (there must always
+ // be an info table on top of the stack).
+ //
+
+ Sp += sizeofW(StgStopFrame) - 2;
+ Sp[1] = R1.w;
+ Sp[0] = (W_)&stg_enter_info;
CurrentTSO->what_next = ThreadComplete;
- SaveThreadState(); /* inline! */
+ SaveThreadState(); // inline!
- /* R1 contains the return value of the thread */
- R1.p = (P_)ThreadFinished;
+ // R1 contains the return value of the thread
+ R1.i = ThreadFinished;
JMP_(StgReturn);
FE_
/* -----------------------------------------------------------------------------
Start a thread from the scheduler by returning to the address on
- the top of the stack (and popping the address). This is used for
- returning to the slow entry point of a function after a garbage collection
- or re-schedule. The slow entry point expects the stack to contain the
- pending arguments only.
+ the top of the stack. This is used for all entries to STG code
+ from C land.
-------------------------------------------------------------------------- */
STGFUN(stg_returnToStackTop)
FB_
LoadThreadState();
CHECK_SENSIBLE_REGS();
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+/* -----------------------------------------------------------------------------
+ Strict IO application - performing an IO action and entering its result.
+
+ rts_evalIO() lets you perform Haskell IO actions from outside of
+ Haskell-land, returning back to you their result. Want this result
+ to be evaluated to WHNF by that time, so that we can easily get at
+ the int/char/whatever using the various get{Ty} functions provided
+ by the RTS API.
+
+ forceIO takes care of this, performing the IO action and entering the
+ results that comes back.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_forceIO_info,stg_forceIO_ret,
+ MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
+
+#ifdef REG_R1
+STGFUN(stg_forceIO_ret)
+{
+ FB_
Sp++;
- JMP_(ENTRY_CODE(Sp[-1]));
+ ENTER();
+ FE_
+}
+#else
+STGFUN(stg_forceIO_ret)
+{
+ FB_
+ R1.w = Sp[0];
+ Sp += 2;
+ ENTER();
FE_
}
+#endif
/* -----------------------------------------------------------------------------
- Start a thread from the scheduler by entering the closure pointed
- to by the word on the top of the stack.
- -------------------------------------------------------------------------- */
+ Non-strict IO application.
+
+ This stack frame works like stg_forceIO_info except that it
+ doesn't evaluate the return value. We need the layer because the
+ return convention for an IO action differs depending on whether R1
+ is a register or not.
+ ------------------------------------------------------------------------- */
-STGFUN(stg_enterStackTop)
+INFO_TABLE_RET( stg_noforceIO_info,stg_noforceIO_ret,
+ MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
+ 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_LEN*/,
+ RET_SMALL,, EF_, 0, 0);
+
+#ifdef REG_R1
+STGFUN(stg_noforceIO_ret)
{
FB_
- LoadThreadState();
- CHECK_SENSIBLE_REGS();
- /* don't count this enter for ticky-ticky profiling */
- R1.p = (P_)Sp[0];
Sp++;
- JMP_(GET_ENTRY(R1.cl));
+ JMP_(ENTRY_CODE(Sp[0]));
FE_
}
+#else
+STGFUN(stg_noforceIO_ret)
+{
+ FB_
+ R1.w = Sp[0];
+ Sp += 2;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+#endif
-
/* -----------------------------------------------------------------------------
Special STG entry points for module registration.
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: StgStdThunks.hc,v 1.20 2002/03/01 18:28:15 keithw Exp $
+ * $Id: StgStdThunks.hc,v 1.21 2002/12/11 15:36:54 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#define SAVE_CCCS(fs) CCS_HDR(Sp-fs)=CCCS
#define GET_SAVED_CCCS RESTORE_CCCS(CCS_HDR(Sp))
#define ENTER_CCS(p) ENTER_CCS_TCL(p)
-#define RET_BITMAP 3
+#define RET_BITMAP 3
+#define RET_FRAMESIZE 2
#else
#define SAVE_CCCS(fs) /* empty */
#define GET_SAVED_CCCS /* empty */
#define ENTER_CCS(p) /* empty */
-#define RET_BITMAP 0
+#define RET_BITMAP 0
+#define RET_FRAMESIZE 0
#endif
#define SELECTOR_CODE_UPD(offset) \
IF_(stg_sel_ret_##offset##_upd_ret); \
- INFO_TABLE_SRT_BITMAP(stg_sel_ret_##offset##_upd_info,stg_sel_ret_##offset##_upd_ret, RET_BITMAP, 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_upd_info,stg_sel_ret_##offset##_upd_ret, MK_SMALL_BITMAP(RET_FRAMESIZE, RET_BITMAP), 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
EF_(stg_sel_ret_##offset##_upd_ret) { \
FB_ \
R1.p=(P_)R1.cl->payload[offset]; \
GET_SAVED_CCCS; \
Sp=Sp+sizeofW(StgHeader); \
- JMP_(ENTRY_CODE(*R1.p)); \
+ ENTER(); \
FE_ \
} \
\
EF_(stg_sel_##offset##_upd_entry) { \
FB_ \
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */ \
- STK_CHK_NP(UPD_FRAME_SIZE,1,); \
+ STK_CHK_NP(UPD_FRAME_SIZE,); \
UPD_BH_UPDATABLE(&stg_sel_##offset##_upd_info); \
LDV_ENTER(R1.cl); \
PUSH_UPD_FRAME(R1.p,0); \
Sp[-UPD_FRAME_SIZE]=(W_)&stg_sel_ret_##offset##_upd_info; \
R1.p = (P_)R1.cl->payload[0]; \
Sp=Sp-UPD_FRAME_SIZE; \
- JMP_(ENTRY_CODE(*R1.p)); \
+ ENTER(); \
FE_ \
}
#define SELECTOR_CODE_NOUPD(offset) \
IF_(stg_sel_ret_##offset##_noupd_ret); \
- INFO_TABLE_SRT_BITMAP(stg_sel_ret_##offset##_noupd_info, stg_sel_ret_##offset##_noupd_ret, RET_BITMAP, 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_noupd_info, stg_sel_ret_##offset##_noupd_ret, MK_SMALL_BITMAP(RET_FRAMESIZE, RET_BITMAP), 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
IF_(stg_sel_ret_##offset##_noupd_ret) { \
FB_ \
R1.p=(P_)R1.cl->payload[offset]; \
EF_(stg_sel_##offset##_noupd_entry) { \
FB_ \
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */ \
- STK_CHK_NP(NOUPD_FRAME_SIZE,1,) \
+ STK_CHK_NP(NOUPD_FRAME_SIZE,) \
UPD_BH_SINGLE_ENTRY(&stg_sel_##offset##_noupd_info); \
LDV_ENTER(R1.cl); \
TICK_UPDF_OMITTED(); \
* in the compiler that means stg_ap_1 is generated occasionally (ToDo)
*/
-INFO_TABLE_SRT(stg_ap_1_upd_info,stg_ap_1_upd_entry,1,1,0,0,0,THUNK_1_0,,EF_,"stg_ap_1_upd_info","stg_ap_1_upd_info");
+INFO_TABLE_THUNK(stg_ap_1_upd_info,stg_ap_1_upd_entry,1,1,0,0,0,THUNK_1_0,,EF_,"stg_ap_1_upd_info","stg_ap_1_upd_info");
FN_(stg_ap_1_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame),1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame),);
UPD_BH_UPDATABLE(&stg_ap_1_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - sizeofW(StgUpdateFrame);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp -= sizeofW(StgUpdateFrame);
+ Sp--; // for stg_ap_0_ret
+ JMP_(stg_ap_0_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_2_upd_info,stg_ap_2_upd_entry,2,0,0,0,0,THUNK_2_0,,EF_,"stg_ap_2_upd_info","stg_ap_2_upd_info");
+INFO_TABLE_THUNK(stg_ap_2_upd_info,stg_ap_2_upd_entry,2,0,0,0,0,THUNK_2_0,,EF_,"stg_ap_2_upd_info","stg_ap_2_upd_info");
FN_(stg_ap_2_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+1,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+1,);
UPD_BH_UPDATABLE(&stg_ap_2_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
PUSH_UPD_FRAME(R1.p,0);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+1);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp -= sizeofW(StgUpdateFrame)+1;
+ Sp--; // for stg_ap_1_ret
+ JMP_(stg_ap_p_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_3_upd_info,stg_ap_3_upd_entry,3,0,0,0,0,THUNK,,EF_,"stg_ap_3_upd_info","stg_ap_3_upd_info");
+INFO_TABLE_THUNK(stg_ap_3_upd_info,stg_ap_3_upd_entry,3,0,0,0,0,THUNK,,EF_,"stg_ap_3_upd_info","stg_ap_3_upd_info");
FN_(stg_ap_3_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+2,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+2,);
UPD_BH_UPDATABLE(&stg_ap_3_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[2]);
Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+2);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp -= sizeofW(StgUpdateFrame)+2;
+ Sp--; // for stg_ap_pp_ret
+ JMP_(stg_ap_pp_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_4_upd_info,stg_ap_4_upd_entry,4,0,0,0,0,THUNK,,EF_,"stg_ap_4_upd_info","stg_ap_4_upd_info");
+INFO_TABLE_THUNK(stg_ap_4_upd_info,stg_ap_4_upd_entry,4,0,0,0,0,THUNK,,EF_,"stg_ap_4_upd_info","stg_ap_4_upd_info");
FN_(stg_ap_4_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+3,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+3,);
UPD_BH_UPDATABLE(&stg_ap_4_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+3);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp--; // for stg_ap_ppp_ret
+ JMP_(stg_ap_ppp_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_5_upd_info,stg_ap_5_upd_entry,5,0,0,0,0,THUNK,,EF_,"stg_ap_5_upd_info","stg_ap_5_upd_info");
+INFO_TABLE_THUNK(stg_ap_5_upd_info,stg_ap_5_upd_entry,5,0,0,0,0,THUNK,,EF_,"stg_ap_5_upd_info","stg_ap_5_upd_info");
FN_(stg_ap_5_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+4,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+4,);
UPD_BH_UPDATABLE(&stg_ap_5_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+4);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp--; // for stg_ap_pppp_ret
+ JMP_(stg_ap_pppp_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_6_upd_info,stg_ap_6_upd_entry,6,0,0,0,0,THUNK,,EF_,"stg_ap_6_upd_info","stg_ap_6_upd_info");
+INFO_TABLE_THUNK(stg_ap_6_upd_info,stg_ap_6_upd_entry,6,0,0,0,0,THUNK,,EF_,"stg_ap_6_upd_info","stg_ap_6_upd_info");
FN_(stg_ap_6_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+5,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+5,);
UPD_BH_UPDATABLE(&stg_ap_6_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+5);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp--; // for stg_ap_ppppp_ret
+ JMP_(stg_ap_ppppp_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_7_upd_info,stg_ap_7_upd_entry,7,0,0,0,0,THUNK,,EF_,"stg_ap_7_upd_info","stg_ap_7_upd_info");
+INFO_TABLE_THUNK(stg_ap_7_upd_info,stg_ap_7_upd_entry,7,0,0,0,0,THUNK,,EF_,"stg_ap_7_upd_info","stg_ap_7_upd_info");
FN_(stg_ap_7_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+6,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+6,);
UPD_BH_UPDATABLE(&stg_ap_7_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
Sp = Sp - (sizeofW(StgUpdateFrame)+6);
- JMP_(ENTRY_CODE(*R1.p));
+ Sp--; // for stg_ap_pppppp_ret
+ JMP_(stg_ap_pppppp_ret);
FE_
}
-INFO_TABLE_SRT(stg_ap_8_upd_info,stg_ap_8_upd_entry,8,0,0,0,0,THUNK,,EF_,"stg_ap_8_upd_info","stg_ap_8_upd_info");
+INFO_TABLE_THUNK(stg_ap_8_upd_info,stg_ap_8_upd_entry,8,0,0,0,0,THUNK,,EF_,"stg_ap_8_upd_info","stg_ap_8_upd_info");
FN_(stg_ap_8_upd_entry) {
FB_
TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+7,1,);
+ STK_CHK_NP(sizeofW(StgUpdateFrame)+7,);
UPD_BH_UPDATABLE(&stg_ap_8_upd_info);
LDV_ENTER(R1.cl);
ENTER_CCS(R1.p);
Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[2]);
Sp[-UF_SIZE-7]=(W_)(R1.cl->payload[1]);
R1.p=(P_)(R1.cl->payload[0]);
- Sp=Sp-10;
- JMP_(ENTRY_CODE(*R1.p));
+ Sp = Sp - (sizeofW(StgUpdateFrame)+7);
+ Sp--; // for stg_ap_ppppppp_ret
+ JMP_(stg_ap_ppppppp_ret);
FE_
}
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.70 2002/11/01 11:05:47 simonmar Exp $
+ * $Id: Storage.c,v 1.71 2002/12/11 15:36:54 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
macosx_get_memory_layout();
#endif
- /* Sanity check to make sure we are able to make the distinction
- * between closures and infotables
+ /* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
+ * doing something reasonable.
*/
- if (!LOOKS_LIKE_GHC_INFO(&stg_BLACKHOLE_info)) {
- barf("LOOKS_LIKE_GHC_INFO+ is incorrectly defined");
- exit(0);
- }
- if (LOOKS_LIKE_GHC_INFO(&stg_dummy_ret_closure)) {
- barf("LOOKS_LIKE_GHC_INFO- is incorrectly defined");
- exit(0);
- }
- if (LOOKS_LIKE_STATIC_CLOSURE(&stg_BLACKHOLE_info)) {
- barf("LOOKS_LIKE_STATIC_CLOSURE- is incorrectly defined");
- exit(0);
- }
- if (!LOOKS_LIKE_STATIC_CLOSURE(&stg_dummy_ret_closure)) {
- barf("LOOKS_LIKE_STATIC_CLOSURE+ is incorrectly defined");
- exit(0);
- }
+ ASSERT(LOOKS_LIKE_INFO_PTR(&stg_BLACKHOLE_info));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
+ ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.heapSizeSuggestion >
*/
ACQUIRE_SM_LOCK;
- if (is_dynamically_loaded_rwdata_ptr((StgPtr)caf)) {
+ if (0 /*TODO: is_dynamically_loaded_rwdata_ptr((StgPtr)caf)*/) {
((StgIndStatic *)caf)->saved_info = (StgInfoTable *)caf->header.info;
((StgIndStatic *)caf)->static_link = caf_list;
caf_list = caf;
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.45 2002/10/21 11:38:54 simonmar Exp $
+ * $Id: Storage.h,v 1.46 2002/12/11 15:36:54 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* External Storage Manger Interface
*
nat np = inf->layout.payload.ptrs, \
nw = inf->layout.payload.nptrs, i; \
if (inf->type != THUNK_SELECTOR) { \
- for (i = np; i < np + nw; i++) { \
+ for (i = 0; i < np + nw; i++) { \
((StgClosure *)p1)->payload[i] = 0; \
} \
} \
#endif
/* -----------------------------------------------------------------------------
- The CAF table - used to let us revert CAFs
+ The CAF table - used to let us revert CAFs in GHCi
-------------------------------------------------------------------------- */
void revertCAFs( void );
-#if defined(DEBUG)
-void printMutOnceList(generation *gen);
-void printMutableList(generation *gen);
-#endif /* DEBUG */
-
-/* --------------------------------------------------------------------------
- Address space layout macros
- --------------------------------------------------------------------------
-
- Here are the assumptions GHC makes about address space layout.
- Broadly, it thinks there are three sections:
-
- CODE Read-only. Contains code and read-only data (such as
- info tables)
- Also called "text"
-
- DATA Read-write data. Contains static closures (and on some
- architectures, info tables too)
-
- HEAP Dynamically-allocated closures
-
- USER None of the above. The only way USER things arise right
- now is when GHCi allocates a constructor info table, which
- it does by mallocing them.
-
- Three macros identify these three areas:
- IS_DATA(p), HEAP_ALLOCED(p)
-
- HEAP_ALLOCED is called FOR EVERY SINGLE CLOSURE during GC.
- It needs to be FAST.
-
- Implementation of HEAP_ALLOCED
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Concerning HEAP, most of the time (certainly under [Static] and [GHCi],
- we ensure that the heap is allocated above some fixed address HEAP_BASE
- (defined in MBlock.h). In this case we set TEXT_BEFORE_HEAP, and we
- get a nice fast test.
-
- Sometimes we can't be quite sure. For example in Windows, we can't
- fix where our heap address space comes from. In this case we un-set
- TEXT_BEFORE_HEAP. That makes it more expensive to test whether a pointer
- comes from the HEAP section, because we need to look at the allocator's
- address maps (see HEAP_ALLOCED macro)
-
- Implementation of CODE and DATA
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Concerning CODE and DATA, there are three main regimes:
-
- [Static] Totally The segments are contiguous, and laid out
- statically linked exactly as above
-
- [GHCi] Static, GHCi may load new modules, but it knows the
- except for GHCi address map, so for any given address it can
- still tell which section it belongs to
-
- [DLL] OS-supported Chunks of CODE and DATA may be mixed in
- dynamic loading the address space, and we can't tell how
-
-
- For the [Static] case, we assume memory is laid out like this
- (in order of increasing addresses)
-
- Start of memory
- CODE section
- TEXT_SECTION_END_MARKER (usually _etext)
- DATA section
- DATA_SECTION_END_MARKER (usually _end)
- USER section
- HEAP_BASE
- HEAP section
-
- For the [GHCi] case, we have to consult GHCi's dynamic linker's
- address maps, which is done by macros
- is_dynamically_loaded_code_or_rodata_ptr
- is_dynamically_loaded_code_or_rwdata_ptr
-
- For the [DLL] case, IS_DATA is really not usable at all.
- */
-
-
-#undef TEXT_BEFORE_HEAP
-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
-#define TEXT_BEFORE_HEAP 1
-#endif
-
-extern void* TEXT_SECTION_END_MARKER_DECL;
-extern void* DATA_SECTION_END_MARKER_DECL;
-
-#ifdef darwin_TARGET_OS
-extern unsigned long macho_etext;
-extern unsigned long macho_edata;
-#define IS_CODE_PTR(p) ( ((P_)(p) < (P_)macho_etext) \
- || is_dynamically_loaded_code_or_rodata_ptr((char *)p) )
-#define IS_DATA_PTR(p) ( ((P_)(p) >= (P_)macho_etext && \
- (P_)(p) < (P_)macho_edata) \
- || is_dynamically_loaded_rwdata_ptr((char *)p) )
-#define IS_USER_PTR(p) ( ((P_)(p) >= (P_)macho_edata) \
- && is_not_dynamically_loaded_ptr((char *)p) )
-#else
-/* Take into account code sections in dynamically loaded object files. */
-#define IS_DATA_PTR(p) ( ((P_)(p) >= (P_)&TEXT_SECTION_END_MARKER && \
- (P_)(p) < (P_)&DATA_SECTION_END_MARKER) \
- || is_dynamically_loaded_rwdata_ptr((char *)p) )
-#define IS_USER_PTR(p) ( ((P_)(p) >= (P_)&DATA_SECTION_END_MARKER) \
- && is_not_dynamically_loaded_ptr((char *)p) )
-#endif
-
-/* --------------------------------------------------------------------------
- Macros for distinguishing data pointers from code pointers
- --------------------------------------------------------------------------
-
- Specification
- ~~~~~~~~~~~~~
- The garbage collector needs to make some critical distinctions between pointers.
- In particular we need
-
- LOOKS_LIKE_GHC_INFO(p) p points to an info table
-
- For both of these macros, p is
- *either* a pointer to a closure (static or heap allocated)
- *or* a return address on the (Haskell) stack
-
- (Return addresses are in fact info-pointers, so that the Haskell stack
- looks very like a chunk of heap.)
-
- The garbage collector uses LOOKS_LIKE_GHC_INFO when walking the stack, as it
- walks over the "pending arguments" on its way to the next return address.
- It is called moderately often, but not as often as HEAP_ALLOCED
-
- ToDo: LOOKS_LIKE_GHC_INFO(p) does not return True when p points to a
- constructor info table allocated by GHCi. We should really rename
- LOOKS_LIKE_GHC_INFO to LOOKS_LIKE_GHC_RETURN_INFO.
-
- Implementation
- ~~~~~~~~~~~~~~
- LOOKS_LIKE_GHC_INFO is more complicated because of the need to distinguish
- between static closures and info tables. It's a known portability problem.
- We have three approaches:
-
- Plan A: Address-space partitioning.
- keep static closures in the (single, contiguous) data segment: IS_DATA_PTR(p)
-
- Plan A can fail for two reasons:
- * In many environments (eg. dynamic loading),
- text and data aren't in a single contiguous range.
- * When we compile through vanilla C (no mangling) we sometimes
- can't guaranteee to put info tables in the text section. This
- happens eg. on MacOS where the C compiler refuses to put const
- data in the text section if it has any code pointers in it
- (which info tables do *only* when we're compiling without
- TABLES_NEXT_TO_CODE).
-
- Hence, Plan B: (compile-via-C-with-mangling, or native code generation)
- Put a zero word before each static closure.
- When compiling to native code, or via C-with-mangling, info tables
- are laid out "backwards" from the address specified in the info pointer
- (the entry code goes forward from the info pointer). Hence, the word
- before the one referenced the info pointer is part of the info table,
- and is guaranteed non-zero.
-
- For reasons nobody seems to fully understand, the statically-allocated tables
- of INTLIKE and CHARLIKE closures can't have this zero word, so we
- have to test separately for them.
-
- Plan B fails altogether for the compile-through-vanilla-C route, because
- info tables aren't laid out backwards.
-
-
- Hence, Plan C: (unregisterised, compile-through-vanilla-C route only)
- If we didn't manage to get info tables into the text section, then
- we can distinguish between a static closure pointer and an info
- pointer as follows: the first word of an info table is a code pointer,
- and therefore in text space, whereas the first word of a closure pointer
- is an info pointer, and therefore not. Shazam!
-*/
-
-
-/* When working with Win32 DLLs, static closures are identified by
- being prefixed with a zero word. This is needed so that we can
- distinguish between pointers to static closures and (reversed!)
- info tables.
-
- This 'scheme' breaks down for closure tables such as CHARLIKE,
- so we catch these separately.
-
- LOOKS_LIKE_STATIC_CLOSURE()
- - discriminates between static closures and info tbls
- (needed by LOOKS_LIKE_GHC_INFO() below - [Win32 DLLs only.])
- LOOKS_LIKE_STATIC()
- - distinguishes between static and heap allocated data.
- */
-#if defined(ENABLE_WIN32_DLL_SUPPORT)
- /* definitely do not enable for mingw DietHEP */
-#define LOOKS_LIKE_STATIC(r) (!(HEAP_ALLOCED(r)))
-
-/* Tiresome predicates needed to check for pointers into the closure tables */
-#define IS_CHARLIKE_CLOSURE(p) \
- ( (P_)(p) >= (P_)stg_CHARLIKE_closure && \
- (char*)(p) <= ((char*)stg_CHARLIKE_closure + \
- (MAX_CHARLIKE-MIN_CHARLIKE) * sizeof(StgIntCharlikeClosure)) )
-#define IS_INTLIKE_CLOSURE(p) \
- ( (P_)(p) >= (P_)stg_INTLIKE_closure && \
- (char*)(p) <= ((char*)stg_INTLIKE_closure + \
- (MAX_INTLIKE-MIN_INTLIKE) * sizeof(StgIntCharlikeClosure)) )
-
-#define LOOKS_LIKE_STATIC_CLOSURE(r) (((*(((unsigned long *)(r))-1)) == 0) || IS_CHARLIKE_CLOSURE(r) || IS_INTLIKE_CLOSURE(r))
-
-#elif defined(darwin_TARGET_OS) && !defined(TABLES_NEXT_TO_CODE)
-
-#define LOOKS_LIKE_STATIC(r) (!(HEAP_ALLOCED(r)))
-#define LOOKS_LIKE_STATIC_CLOSURE(r) (IS_DATA_PTR(r) && !LOOKS_LIKE_GHC_INFO(r))
-
-#else
-
-#define LOOKS_LIKE_STATIC(r) IS_DATA_PTR(r)
-#define LOOKS_LIKE_STATIC_CLOSURE(r) IS_DATA_PTR(r)
+/* -----------------------------------------------------------------------------
+ DEBUGGING predicates for pointers
-#endif
+ LOOKS_LIKE_INFO_PTR(p) returns False if p is definitely not an info ptr
+ LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr
+ These macros are complete but not sound. That is, they might
+ return false positives. Do not rely on them to distinguish info
+ pointers from closure pointers, for example.
-/* -----------------------------------------------------------------------------
- Macros for distinguishing infotables from closures.
-
- You'd think it'd be easy to tell an info pointer from a closure pointer:
- closures live on the heap and infotables are in read only memory. Right?
- Wrong! Static closures live in read only memory and Hugs allocates
- infotables for constructors on the (writable) C heap.
+ We don't use address-space predicates these days, for portability
+ reasons, and the fact that code/data can be scattered about the
+ address space in a dynamically-linked environment. Our best option
+ is to look at the alleged info table and see whether it seems to
+ make sense...
-------------------------------------------------------------------------- */
-/* not accurate by any means, but stops the assertions failing... */
-/* TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO */
-#define IS_HUGS_CONSTR_INFO(info) IS_USER_PTR(info)
+#define LOOKS_LIKE_INFO_PTR(p) \
+ (p && ((StgInfoTable *)(INFO_PTR_TO_STRUCT(p)))->type != INVALID_OBJECT && \
+ ((StgInfoTable *)(INFO_PTR_TO_STRUCT(p)))->type < N_CLOSURE_TYPES)
-/* LOOKS_LIKE_GHC_INFO is called moderately often during GC, but
- * Certainly not as often as HEAP_ALLOCED.
- */
-#if defined(darwin_TARGET_OS) && !defined(TABLES_NEXT_TO_CODE)
- /* Plan C, see above */
-#define LOOKS_LIKE_GHC_INFO(info) IS_CODE_PTR(((StgInfoTable *)info).entry)
-#else
-#define LOOKS_LIKE_GHC_INFO(info) (!HEAP_ALLOCED(info) \
- && !LOOKS_LIKE_STATIC_CLOSURE(info))
-#endif
+#define LOOKS_LIKE_CLOSURE_PTR(p) \
+ (LOOKS_LIKE_INFO_PTR(((StgClosure *)(p))->header.info))
/* -----------------------------------------------------------------------------
Macros for calculating how big a closure will be (used during allocation)
-------------------------------------------------------------------------- */
-static __inline__ StgOffset AP_sizeW ( nat n_args )
-{ return sizeofW(StgAP_UPD) + n_args; }
+static __inline__ StgOffset PAP_sizeW ( nat n_args )
+{ return sizeofW(StgPAP) + n_args; }
-static __inline__ StgOffset PAP_sizeW ( nat n_args )
-{ return sizeofW(StgPAP) + n_args; }
+static __inline__ StgOffset AP_STACK_sizeW ( nat size )
+{ return sizeofW(StgAP_STACK) + size; }
-static __inline__ StgOffset CONSTR_sizeW( nat p, nat np )
+static __inline__ StgOffset CONSTR_sizeW( nat p, nat np )
{ return sizeofW(StgHeader) + p + np; }
-static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void )
+static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void )
{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
-static __inline__ StgOffset BLACKHOLE_sizeW ( void )
+static __inline__ StgOffset BLACKHOLE_sizeW ( void )
{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
/* --------------------------------------------------------------------------
- * Sizes of closures
- * ------------------------------------------------------------------------*/
+ Sizes of closures
+ ------------------------------------------------------------------------*/
static __inline__ StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
{ return sizeofW(StgClosure)
+ sizeofW(StgPtr) * itbl->layout.payload.ptrs
+ sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+static __inline__ StgOffset ap_stack_sizeW( StgAP_STACK* x )
+{ return AP_STACK_sizeW(x->size); }
+
static __inline__ StgOffset pap_sizeW( StgPAP* x )
{ return PAP_sizeW(x->n_args); }
static __inline__ StgWord tso_sizeW ( StgTSO *tso )
{ return TSO_STRUCT_SIZEW + tso->stack_size; }
-#endif /* STORAGE_H */
+/* -----------------------------------------------------------------------------
+ Sizes of stack frames
+ -------------------------------------------------------------------------- */
+
+static inline StgWord stack_frame_sizeW( StgClosure *frame )
+{
+ StgRetInfoTable *info;
+
+ info = get_ret_itbl(frame);
+ switch (info->i.type) {
+
+ case RET_DYN:
+ {
+ StgRetDyn *dyn = (StgRetDyn *)frame;
+ return sizeofW(StgRetDyn) + RET_DYN_SIZE +
+ GET_PTRS(dyn->liveness) + GET_NONPTRS(dyn->liveness);
+ }
+
+ case RET_FUN:
+ return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;
+
+ case RET_BIG:
+ return 1 + info->i.layout.large_bitmap->size;
+
+ case RET_BCO:
+ return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
+
+ default:
+ return 1 + BITMAP_SIZE(info->i.layout.bitmap);
+ }
+}
+
+/* -----------------------------------------------------------------------------
+ Debugging bits
+ -------------------------------------------------------------------------- */
+
+#if defined(DEBUG)
+void printMutOnceList(generation *gen);
+void printMutableList(generation *gen);
+#endif
+#endif // STORAGE_H
/* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.22 2002/11/01 11:05:47 simonmar Exp $
+ * $Id: StoragePriv.h,v 1.23 2002/12/11 15:36:54 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern nat countBlocks(bdescr *);
#endif
-/*
- * These three are used by the garbage collector when we have
- * dynamically-linked object modules. (see Storage.h,
- * IS_DATA_PTR etc.).
- * Defined in Linker.c.
- */
-int is_dynamically_loaded_code_or_rodata_ptr ( void* p );
-int is_dynamically_loaded_rwdata_ptr ( void* p );
-int is_not_dynamically_loaded_ptr ( void* p );
-
/* Functions from GC.c
*/
extern void threadPaused ( StgTSO * );
/* -----------------------------------------------------------------------------
- * $Id: Ticky.c,v 1.16 2002/03/04 10:35:43 keithw Exp $
+ * $Id: Ticky.c,v 1.17 2002/12/11 15:36:54 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1992-1997
* (c) The GHC Team, 1998-1999
#ifdef PAR
ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr +
#endif
- ALLOC_BH_ctr + ALLOC_UPD_PAP_ctr + ALLOC_PRIM_ctr;
+ ALLOC_BH_ctr + ALLOC_PAP_ctr + ALLOC_PRIM_ctr;
unsigned long tot_adm_wds = /* total number of admin words allocated */
ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
#ifdef PAR
ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm +
#endif
- ALLOC_BH_adm + ALLOC_UPD_PAP_adm + ALLOC_PRIM_adm;
+ ALLOC_BH_adm + ALLOC_PAP_adm + ALLOC_PRIM_adm;
unsigned long tot_gds_wds = /* total number of words of ``good stuff'' allocated */
ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds +
#endif
- ALLOC_BH_gds + ALLOC_UPD_PAP_gds + ALLOC_PRIM_gds;
+ ALLOC_BH_gds + ALLOC_PAP_gds + ALLOC_PRIM_gds;
unsigned long tot_slp_wds = /* total number of ``slop'' words allocated */
ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
#ifdef PAR
ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp +
#endif
- ALLOC_BH_slp + ALLOC_UPD_PAP_slp + ALLOC_PRIM_slp;
+ ALLOC_BH_slp + ALLOC_PAP_slp + ALLOC_PRIM_slp;
unsigned long tot_wds = /* total words */
tot_adm_wds + tot_gds_wds + tot_slp_wds;
unsigned long tot_thk_enters = ENT_STATIC_THK_ctr + ENT_DYN_THK_ctr;
unsigned long tot_con_enters = ENT_STATIC_CON_ctr + ENT_DYN_CON_ctr;
unsigned long tot_fun_direct_enters = ENT_STATIC_FUN_DIRECT_ctr + ENT_DYN_FUN_DIRECT_ctr;
- unsigned long tot_fun_std_enters = ENT_STATIC_FUN_STD_ctr + ENT_DYN_FUN_STD_ctr;
unsigned long tot_ind_enters = ENT_STATIC_IND_ctr + ENT_DYN_IND_ctr;
+ // This is the number of function calls which went via a
+ // slow/unknown application (one of the stg_ap_ functions).
+ unsigned long tot_fun_slow_enters =
+ SLOW_CALL_ctr - SLOW_CALL_BUILT_PAP_ctr - SLOW_CALL_NEW_PAP_ctr;
+
unsigned long tot_enters =
tot_con_enters + tot_fun_direct_enters +
tot_ind_enters + ENT_PERM_IND_ctr + ENT_PAP_ctr + tot_thk_enters;
unsigned long jump_direct_enters =
tot_enters - ENT_VIA_NODE_ctr;
- unsigned long bypass_enters =
- tot_fun_direct_enters -
- (tot_fun_std_enters - UPD_PAP_IN_NEW_ctr);
unsigned long tot_returns =
- RET_NEW_ctr + RET_OLD_ctr + RET_UNBOXED_TUP_ctr +
- RET_SEMI_IN_HEAP_ctr + RET_SEMI_BY_DEFAULT_ctr/*?*/;
+ RET_NEW_ctr + RET_OLD_ctr + RET_UNBOXED_TUP_ctr;
unsigned long tot_returns_of_new = RET_NEW_ctr;
fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PRIM));
fprintf(tf,"\n%7ld (%5.1f%%) partial applications",
- ALLOC_UPD_PAP_ctr,
- PC(INTAVG(ALLOC_UPD_PAP_ctr, tot_allocs)));
- if (ALLOC_UPD_PAP_ctr != 0)
- fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(UPD_PAP));
+ ALLOC_PAP_ctr,
+ PC(INTAVG(ALLOC_PAP_ctr, tot_allocs)));
+ if (ALLOC_PAP_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PAP));
fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
ALLOC_TSO_ctr,
fprintf(tf,"%7ld (%5.1f%%) data values\n",
tot_con_enters,
PC(INTAVG(tot_con_enters,tot_enters)));
- fprintf(tf,"%7ld (%5.1f%%) function values\n\t\t [of which %ld (%.1f%%) bypassed arg-satisfaction chk]\n",
- tot_fun_direct_enters,
- PC(INTAVG(tot_fun_direct_enters,tot_enters)),
- bypass_enters,
- PC(INTAVG(bypass_enters,tot_fun_direct_enters)));
- fprintf(tf,"%7ld (%5.1f%%) partial applications\n",
- ENT_PAP_ctr,
- PC(INTAVG(ENT_PAP_ctr,tot_enters)));
fprintf(tf,"%7ld (%5.1f%%) normal indirections\n",
tot_ind_enters,
PC(INTAVG(tot_ind_enters,tot_enters)));
ENT_PERM_IND_ctr,
PC(INTAVG(ENT_PERM_IND_ctr,tot_enters)));
+ fprintf(tf,"\nCALLS: %ld of which %ld (%.lf%%) were slow/unknown calls\n\t\t [the rest went direct to the fast entry point]\n",
+ tot_fun_direct_enters,
+ tot_fun_slow_enters,
+ PC(INTAVG(tot_fun_slow_enters,tot_fun_direct_enters))
+ );
+
fprintf(tf,"\nRETURNS: %ld\n", tot_returns);
fprintf(tf,"%7ld (%5.1f%%) from entering a new constructor\n\t\t [the rest from entering an existing constructor]\n",
tot_returns_of_new,
UPDF_PUSHED_ctr,
UPDF_OMITTED_ctr);
- fprintf(tf,"\nSEQ FRAMES: %ld", SEQF_PUSHED_ctr);
-
fprintf(tf,"\nCATCH FRAMES: %ld", CATCHF_PUSHED_ctr);
if (UPDF_RCC_PUSHED_ctr != 0)
PR_HST(ALLOC_PRIM_hst,2);
PR_HST(ALLOC_PRIM_hst,3);
PR_HST(ALLOC_PRIM_hst,4);
- PR_CTR(ALLOC_UPD_PAP_ctr);
- PR_CTR(ALLOC_UPD_PAP_adm);
- PR_CTR(ALLOC_UPD_PAP_gds);
- PR_CTR(ALLOC_UPD_PAP_slp);
- PR_HST(ALLOC_UPD_PAP_hst,0);
- PR_HST(ALLOC_UPD_PAP_hst,1);
- PR_HST(ALLOC_UPD_PAP_hst,2);
- PR_HST(ALLOC_UPD_PAP_hst,3);
- PR_HST(ALLOC_UPD_PAP_hst,4);
+ PR_CTR(ALLOC_PAP_ctr);
+ PR_CTR(ALLOC_PAP_adm);
+ PR_CTR(ALLOC_PAP_gds);
+ PR_CTR(ALLOC_PAP_slp);
+ PR_HST(ALLOC_PAP_hst,0);
+ PR_HST(ALLOC_PAP_hst,1);
+ PR_HST(ALLOC_PAP_hst,2);
+ PR_HST(ALLOC_PAP_hst,3);
+ PR_HST(ALLOC_PAP_hst,4);
PR_CTR(ALLOC_TSO_ctr);
PR_CTR(ALLOC_TSO_adm);
PR_CTR(ENT_VIA_NODE_ctr);
PR_CTR(ENT_STATIC_CON_ctr);
PR_CTR(ENT_DYN_CON_ctr);
- PR_CTR(ENT_STATIC_FUN_STD_ctr);
- PR_CTR(ENT_DYN_FUN_STD_ctr);
PR_CTR(ENT_STATIC_FUN_DIRECT_ctr);
PR_CTR(ENT_DYN_FUN_DIRECT_ctr);
PR_CTR(ENT_STATIC_IND_ctr);
* determine the number of closures entered 0/1/>1. KSW 1999-04. */
COND_PR_CTR(ENT_PERM_IND_ctr,RtsFlags.GcFlags.squeezeUpdFrames == rtsFalse,"E!NT_PERM_IND_ctr requires +RTS -Z");
+ PR_CTR(ENT_AP_ctr);
PR_CTR(ENT_PAP_ctr);
- PR_CTR(ENT_AP_UPD_ctr);
+ PR_CTR(ENT_AP_STACK_ctr);
PR_CTR(ENT_BH_ctr);
PR_CTR(ENT_STATIC_THK_ctr);
PR_CTR(ENT_DYN_THK_ctr);
+ PR_CTR(SLOW_CALL_ctr);
+ PR_CTR(SLOW_CALL_BUILT_PAP_ctr);
+ PR_CTR(SLOW_CALL_NEW_PAP_ctr);
+ PR_HST(SLOW_CALL_hst,0);
+ PR_HST(SLOW_CALL_hst,1);
+ PR_HST(SLOW_CALL_hst,2);
+ PR_HST(SLOW_CALL_hst,3);
+ PR_HST(SLOW_CALL_hst,4);
+ PR_HST(SLOW_CALL_hst,5);
+ PR_HST(SLOW_CALL_hst,6);
+ PR_HST(SLOW_CALL_hst,7);
+
PR_CTR(RET_NEW_ctr);
PR_CTR(RET_OLD_ctr);
PR_CTR(RET_UNBOXED_TUP_ctr);
- PR_CTR(RET_SEMI_BY_DEFAULT_ctr);
- PR_CTR(RET_SEMI_IN_HEAP_ctr);
- PR_CTR(RET_SEMI_FAILED_IND_ctr);
- PR_CTR(RET_SEMI_FAILED_UNEVAL_ctr);
PR_CTR(VEC_RETURN_ctr);
PR_HST(RET_NEW_hst,0);
PR_HST(RET_UNBOXED_TUP_hst,6);
PR_HST(RET_UNBOXED_TUP_hst,7);
PR_HST(RET_UNBOXED_TUP_hst,8);
- PR_HST(RET_SEMI_IN_HEAP_hst,0);
- PR_HST(RET_SEMI_IN_HEAP_hst,1);
- PR_HST(RET_SEMI_IN_HEAP_hst,2);
- PR_HST(RET_SEMI_IN_HEAP_hst,3);
- PR_HST(RET_SEMI_IN_HEAP_hst,4);
- PR_HST(RET_SEMI_IN_HEAP_hst,5);
- PR_HST(RET_SEMI_IN_HEAP_hst,6);
- PR_HST(RET_SEMI_IN_HEAP_hst,7);
- PR_HST(RET_SEMI_IN_HEAP_hst,8);
PR_HST(RET_VEC_RETURN_hst,0);
PR_HST(RET_VEC_RETURN_hst,1);
PR_HST(RET_VEC_RETURN_hst,2);
PR_HST(RET_VEC_RETURN_hst,7);
PR_HST(RET_VEC_RETURN_hst,8);
- PR_CTR(RET_SEMI_loads_avoided);
-
PR_CTR(UPDF_OMITTED_ctr);
PR_CTR(UPDF_PUSHED_ctr);
- PR_CTR(SEQF_PUSHED_ctr);
PR_CTR(CATCHF_PUSHED_ctr);
PR_CTR(UPDF_RCC_PUSHED_ctr);
/* Function name at the end so it doesn't mess up the tabulation */
for (p = ticky_entry_ctrs; p != NULL; p = p->link) {
- fprintf(tf, "%11ld%11ld%11ld %6u%6u %-11s%-30s",
+ fprintf(tf, "%11ld%11ld %6u%6u %-11s%-30s",
p->entry_count,
- p->slow_entry_count,
p->allocs,
p->arity,
p->stk_args,
* here.
*/
StgEntCounter top_ct
- = { 0, 0, 0,
+ = { 0, 0, 0,
"TOP", "",
- 0, 0, 0, NULL };
+ 0, 0, NULL };
#endif /* TICKY_TICKY */
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.37 2001/11/28 14:29:33 simonmar Exp $
+ * $Id: Updates.hc,v 1.38 2002/12/11 15:36:54 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2002
*
* Code to perform updates.
*
use a single generic piece of code that simply entered the return value
to return, but it's quicker this way. The direct return code of course
just does another direct return when it's finished.
-
- Why is there necessarily an activation underneath us on the stack?
- Because if we're returning, that means we've got a constructor in
- our hands. If there were any arguments to be applied to it, that
- would be a type error. We don't ever return a PAP to an update frame,
- the update is handled manually by stg_update_PAP.
*/
/* on entry to the update code
update code.
*/
-#if defined(REG_Su)
-#define UPD_FRAME_ENTRY_TEMPLATE(label,ret) \
- STGFUN(label); \
- STGFUN(label) \
- { \
- FB_ \
- \
- Su = (StgUpdateFrame *)((StgUpdateFrame *)Sp)->updatee; \
- \
- /* Tick - it must be a con, all the paps are handled \
- * in stg_upd_PAP and PAP_entry below \
- */ \
- TICK_UPD_CON_IN_NEW(sizeW_fromITBL(get_itbl(Su))); \
- \
- UPD_IND(Su,R1.p); \
- \
- /* reset Su to the next update frame */ \
- Su = ((StgUpdateFrame *)Sp)->link; \
- \
- /* remove the update frame from the stack */ \
- Sp += sizeofW(StgUpdateFrame); \
- \
- JMP_(ret); \
- FE_ \
- }
-#else
-
#define UPD_FRAME_ENTRY_TEMPLATE(label,ret) \
STGFUN(label); \
STGFUN(label) \
\
UPD_IND(updatee, R1.cl); \
\
- /* reset Su to the next update frame */ \
- Su = ((StgUpdateFrame *)Sp)->link; \
- \
/* remove the update frame from the stack */ \
Sp += sizeofW(StgUpdateFrame); \
\
JMP_(ret); \
FE_ \
}
-#endif
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_entry,ENTRY_CODE(Sp[0]));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_0_entry,RET_VEC(Sp[0],0));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_1_entry,RET_VEC(Sp[0],1));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_2_entry,RET_VEC(Sp[0],2));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_3_entry,RET_VEC(Sp[0],3));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_4_entry,RET_VEC(Sp[0],4));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_5_entry,RET_VEC(Sp[0],5));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_6_entry,RET_VEC(Sp[0],6));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_7_entry,RET_VEC(Sp[0],7));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_ret,ENTRY_CODE(Sp[0]));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_0_ret,RET_VEC(Sp[0],0));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_1_ret,RET_VEC(Sp[0],1));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_2_ret,RET_VEC(Sp[0],2));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_3_ret,RET_VEC(Sp[0],3));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_4_ret,RET_VEC(Sp[0],4));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_5_ret,RET_VEC(Sp[0],5));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_6_ret,RET_VEC(Sp[0],6));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_7_ret,RET_VEC(Sp[0],7));
/*
Make sure this table is big enough to handle the maximum vectored
*/
#if defined(PROFILING)
-#define UPD_FRAME_BITMAP 7
+#define UPD_FRAME_BITMAP 3
+#define UPD_FRAME_WORDS 3
#else
-#define UPD_FRAME_BITMAP 1
+#define UPD_FRAME_BITMAP 0
+#define UPD_FRAME_WORDS 1
#endif
/* this bitmap indicates that the first word of an update frame is a
* there's a cost-centre-stack in there too).
*/
-VEC_POLY_INFO_TABLE(stg_upd_frame,UPD_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, UPDATE_FRAME,, EF_);
-
-/* -----------------------------------------------------------------------------
- Entry Code for a PAP.
-
- The idea is to copy the chunk of stack from the PAP object and then
- re-enter the function closure that failed it's args check in the
- first place.
-
- In fact, we do a little optimisation too, by performing the updates
- for any update frames sitting on top of the stack. (ToDo: is this
- really an optimisation? --SDM)
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_PAP_info,stg_PAP_entry,/*special layout*/0,0,PAP,,EF_,"PAP","PAP");
-STGFUN(stg_PAP_entry)
-{
- nat Words;
- P_ p;
- nat i;
- StgPAP *pap;
-
- FB_
-
- pap = (StgPAP *) R1.p;
-
- /*
- * remove any update frames on the top of the stack, by just
- * performing the update here.
- */
- while ((W_)Su - (W_)Sp == 0) {
-
- switch (get_itbl(Su)->type) {
-
- case UPDATE_FRAME:
- /* We're sitting on top of an update frame, so let's do the business */
- UPD_IND(Su->updatee, pap);
-
-#if defined(PROFILING)
- /*
- * Restore the Cost Centre too (if required); again see Sansom
- * thesis p 183. Take the CC out of the update frame if a
- * CAF/DICT.
- */
-
- CCCS = Su->header.prof.ccs;
-#endif /* PROFILING */
-
- Su = Su->link;
- Sp += sizeofW(StgUpdateFrame);
- continue;
-
- case SEQ_FRAME:
- /* Just pop the seq frame and return to the activation record
- * underneath us - R1 already contains the address of the PAP.
- */
- Su = ((StgSeqFrame *)Su)->link;
- Sp += sizeofW(StgSeqFrame);
- JMP_(ENTRY_CODE(*Sp));
-
- case CATCH_FRAME:
- /* can't happen, see stg_update_PAP */
- barf("PAP_entry: CATCH_FRAME");
-
- default:
- barf("PAP_entry: strange activation record");
- }
-
- }
-
- Words = pap->n_args;
-
- /*
- * Check for stack overflow.
- */
- STK_CHK_NP(Words,1,);
- Sp -= Words;
-
- TICK_ENT_PAP(pap);
- LDV_ENTER(pap);
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CCS_PAP_CL(pap);
-
- R1.cl = pap->fun;
- p = (P_)(pap->payload);
-
- /* Reload the stack */
- for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
-
- /* Off we go! */
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- stg_update_PAP: Update the current closure with a partial application.
-
- This function is called whenever an argument satisfaction check fails.
- -------------------------------------------------------------------------- */
-
-EXTFUN(__stg_update_PAP)
-{
- nat Words, PapSize;
-#ifdef PROFILING
- CostCentreStack *CCS_pap;
-#endif
- StgPAP* PapClosure;
- StgClosure *Fun, *Updatee;
- P_ p;
- I_ i;
-
- FB_
-
- /* Save the pointer to the function closure that just failed the
- * argument satisfaction check
- */
- Fun = R1.cl;
-
- /* Just copy the whole block of stack between the stack pointer
- * and the update frame pointer.
- */
- Words = (P_)Su - (P_)Sp;
- ASSERT((int)Words >= 0);
-
-#if defined(PROFILING)
- /* pretend we just entered the function closure */
- ENTER_CCS_FCL(Fun);
- CCS_pap = CCCS;
-#endif
-
- if (Words == 0) {
-
- /*
- * No arguments, only Node. Skip building the PAP and
- * just plan to update with an indirection.
- */
-
- PapClosure = (StgPAP *)Fun;
-
- } else {
- /* Build the PAP */
-
- PapSize = Words + sizeofW(StgPAP);
-
- /*
- * First we need to do a heap check, which involves saving
- * everything on the stack. We only have one live pointer:
- * Fun, the function closure that was passed to us. If the
- * heap check fails, we push the function closure on the stack
- * and instruct the scheduler to try entering it again when
- * the garbage collector has run.
- *
- * It's done this way because there's a possibility that the
- * garbage collector might have messed around with the stack,
- * such as removing the update frame.
- */
- if ((Hp += PapSize) > HpLim) {
- HpAlloc = PapSize;
- Sp -= 1;
- Sp[0] = (W_)Fun;
- JMP_(stg_gc_entertop);
- }
-
- TICK_ALLOC_UPD_PAP(1/*fun*/ + Words, 0);
- CCS_ALLOC(CCS_pap, PapSize);
-
- PapClosure = (StgPAP *)(Hp + 1 - PapSize); /* The new PapClosure */
-
- SET_HDR(PapClosure,&stg_PAP_info,CCS_pap);
- PapClosure->n_args = Words;
- PapClosure->fun = Fun;
-
- /* Now fill in the closure fields */
-
- p = Hp;
- for (i = Words; --i >= 0; ) {
- *p-- = (W_) Sp[i];
- }
- }
-
- /*
- * Finished constructing PAP closure; now update the updatee.
- */
-
- /* ToDo: we'd like to just jump to the code for PAP_entry here,
- * which deals with a stack of update frames in one go. What to
- * do about the special ticky and profiling stuff here?
- */
-
- switch (get_itbl(Su)->type) {
-
- case SEQ_FRAME:
- /* Set Sp to just above the SEQ frame (should be an activation rec.)*/
- Sp = (P_)Su + sizeofW(StgSeqFrame);
-
- /* restore Su */
- Su = ((StgSeqFrame *)Su)->link;
-
- /* return to the activation record, with the address of the PAP in R1 */
- R1.p = (P_)PapClosure;
- JMP_(ENTRY_CODE(*Sp));
-
- case CATCH_FRAME:
- /* Set Sp to just above the CATCH frame (should be an activation rec.)*/
- Sp = (P_)Su + sizeofW(StgCatchFrame);
-
- /* restore Su */
- Su = ((StgCatchFrame *)Su)->link;
-
- /* restart by entering the PAP */
- R1.p = (P_)PapClosure;
- JMP_(GET_ENTRY(R1.cl));
-
- case UPDATE_FRAME:
- /*
- * Now we have a standard update frame, so we update the updatee with
- * either the new PAP or Node.
- */
-
- Updatee = Su->updatee;
-
-#if defined(PROFILING)
- if (Words != 0) {
- UPD_IND(Updatee,PapClosure);
- TICK_UPD_PAP_IN_NEW(Words+1);
- } else {
- /* Lexical scoping requires a *permanent* indirection, and we
- * also have to set the cost centre for the indirection.
- */
- UPD_PERM_IND(Updatee,PapClosure);
- TICK_UPD_PAP_IN_PLACE();
- Updatee->header.prof.ccs = CCS_pap;
- }
-#else
- UPD_IND(Updatee,PapClosure);
- if (Words != 0) {
- TICK_UPD_PAP_IN_NEW(Words+1);
- } else {
- TICK_UPD_PAP_IN_PLACE();
- }
-#endif
-
-#if defined(PROFILING)
- CCCS = Su->header.prof.ccs;
- ENTER_CCS_PAP(CCS_pap);
-#endif /* PROFILING */
-
- /* Restore Su */
- Su = Su->link;
-
- /*
- * Squeeze out update frame from stack.
- */
- for (i = Words; --i >= 0; ) {
- Sp[i+(sizeofW(StgUpdateFrame))] = Sp[i];
- }
- Sp += sizeofW(StgUpdateFrame);
- break;
-
- default:
- barf("stg_update_PAP: strange activation record");
- }
-
- /*
- * All done! Restart by re-entering Node
- * Don't count this entry for ticky-ticky profiling.
- */
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-
-/* -----------------------------------------------------------------------------
- Entry Code for an AP_UPD.
-
- The idea is to copy the chunk of stack from the AP object and then
- enter the function closure.
-
- (This code is a simplified copy of the PAP code - with all the
- update frame code stripped out.)
- -------------------------------------------------------------------------- */
-
-
-INFO_TABLE(stg_AP_UPD_info,stg_AP_UPD_entry,/*special layout*/0,0,AP_UPD,,EF_,"AP_UPD","AP_UPD");
-STGFUN(stg_AP_UPD_entry)
-{
- nat Words;
- P_ p;
- nat i;
- StgAP_UPD *ap;
-
- FB_
-
- ap = (StgAP_UPD *) R1.p;
-
- Words = ap->n_args;
-
- /*
- * Check for stack overflow.
- */
- STK_CHK_GEN(Words+sizeofW(StgUpdateFrame), R1_PTR, stg_AP_UPD_entry, );
-
- PUSH_UPD_FRAME(R1.p, 0);
- Sp -= sizeofW(StgUpdateFrame) + Words;
-
- TICK_ENT_AP_UPD(ap);
- LDV_ENTER(ap);
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_UPD_CL */
-
- R1.cl = ap->fun;
- p = (P_)(ap->payload);
-
- /* Reload the stack */
- for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
-
- /* Off we go! */
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
+VEC_POLY_INFO_TABLE( stg_upd_frame,
+ MK_SMALL_BITMAP(UPD_FRAME_WORDS, UPD_FRAME_BITMAP),
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ UPDATE_FRAME,, EF_);
/*-----------------------------------------------------------------------------
Seq frames
expression whose scrutinee has either a polymorphic or function type
(constructor types can be handled by normal 'case' expressions).
- To handle a polymorphic/function typed seq, we push a SEQ_FRAME on
+ To handle a polymorphic/function typed seq, we push a SEQ frame on
the stack. This is a polymorphic activation record that just pops
- itself and returns when entered. The purpose of the SEQ_FRAME is to
- act as a barrier in case the scrutinee is a partial application - in
- this way it is just like an update frame, except that it doesn't
- update anything.
- -------------------------------------------------------------------------- */
+ itself and returns (in a non-vectored way) when entered. The
+ purpose of the SEQ frame is to avoid having to make a polymorphic return
+ point for each polymorphic case expression.
-#define SEQ_FRAME_ENTRY_TEMPLATE(label,ret) \
- IFN_(label) \
- { \
- FB_ \
- Su = ((StgSeqFrame *)Sp)->link; \
- Sp += sizeofW(StgSeqFrame); \
- JMP_(ret); \
- FE_ \
- }
+ Another way of looking at it: the SEQ frame turns a vectored return
+ into a direct one.
+ -------------------------------------------------------------------------- */
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_entry, ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_0_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_1_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_2_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_3_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_4_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_5_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_6_entry,ENTRY_CODE(Sp[0]));
-SEQ_FRAME_ENTRY_TEMPLATE(stg_seq_frame_7_entry,ENTRY_CODE(Sp[0]));
+IF_(stg_seq_frame_ret);
-VEC_POLY_INFO_TABLE(stg_seq_frame, UPD_FRAME_BITMAP, NULL/*srt*/, 0/*srt_off*/, 0/*srt_len*/, SEQ_FRAME,, EF_);
+#define stg_seq_frame_0_ret stg_seq_frame_ret
+#define stg_seq_frame_1_ret stg_seq_frame_ret
+#define stg_seq_frame_2_ret stg_seq_frame_ret
+#define stg_seq_frame_3_ret stg_seq_frame_ret
+#define stg_seq_frame_4_ret stg_seq_frame_ret
+#define stg_seq_frame_5_ret stg_seq_frame_ret
+#define stg_seq_frame_6_ret stg_seq_frame_ret
+#define stg_seq_frame_7_ret stg_seq_frame_ret
-/* -----------------------------------------------------------------------------
- * The seq infotable
- *
- * This closure takes one argument, which it evaluates and returns the
- * result with a direct return (never a vectored return!) in R1. It
- * does this by pushing a SEQ_FRAME on the stack and
- * entering its argument.
- *
- * It is used in deleteThread when reverting blackholes.
- * -------------------------------------------------------------------------- */
+VEC_POLY_INFO_TABLE( stg_seq_frame,
+ MK_SMALL_BITMAP(0, 0),
+ 0/*srt*/, 0/*srt_off*/, 0/*srt_len*/,
+ RET_SMALL,, EF_);
-INFO_TABLE(stg_seq_info,stg_seq_entry,1,0,FUN,,EF_,0,0);
-STGFUN(stg_seq_entry)
+IF_(stg_seq_frame_ret)
{
- FB_
- STK_CHK_GEN(sizeofW(StgSeqFrame), NO_PTRS, stg_seq_entry, );
- Sp -= sizeofW(StgSeqFrame);
- PUSH_SEQ_FRAME(Sp);
- R1.cl = R1.cl->payload[0];
- JMP_(ENTRY_CODE(*R1.p));
- FE_
+ FB_
+ Sp ++;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
}
/* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.25 2002/06/19 12:01:28 simonmar Exp $
+ * $Id: Weak.c,v 1.26 2002/12/11 15:36:54 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
IF_DEBUG(weak,fprintf(stderr,"weak: batching %d finalizers\n", n));
arr = (StgMutArrPtrs *)allocate(sizeofW(StgMutArrPtrs) + n);
+ TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCS_SYSTEM);
arr->ptrs = n;
g x = f x + 1
h x = x `div` 2
+
+data C = C {x :: Int}
ifeq "$(BootingFromHc)" "YES"
SUBDIRS = hp2ps parallel stat2resid prof unlit
else
-SUBDIRS = hasktags ghc-pkg hp2ps hsc2hs parallel stat2resid prof unlit genprimopcode
+SUBDIRS = hasktags ghc-pkg hp2ps hsc2hs parallel stat2resid prof unlit genprimopcode genapply
endif
endif
--- /dev/null
+{-# OPTIONS -cpp #-}
+module Main(main) where
+
+#include "../../includes/config.h"
+#include "../../includes/MachRegs.h"
+
+#if __GLASGOW_HASKELL__ >= 504
+import Text.PrettyPrint
+import Data.Word
+import Data.Bits
+import Data.List ( intersperse )
+import Data.Char ( toUpper )
+#else
+import Bits
+import Word
+import Pretty
+import List ( intersperse )
+import Char ( toUpper )
+#endif
+
+
+-- -----------------------------------------------------------------------------
+-- Argument kinds (rougly equivalent to PrimRep)
+
+data ArgRep
+ = N -- non-ptr
+ | P -- ptr
+ | V -- void
+ | F -- float
+ | D -- double
+ | L -- long (64-bit)
+
+-- size of a value in *words*
+argSize :: ArgRep -> Int
+argSize N = 1
+argSize P = 1
+argSize V = 0
+argSize F = 1
+argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
+argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
+
+showArg :: ArgRep -> Char
+showArg N = 'n'
+showArg P = 'p'
+showArg V = 'v'
+showArg F = 'f'
+showArg D = 'd'
+showArg L = 'l'
+
+-- is a value a pointer?
+isPtr :: ArgRep -> Bool
+isPtr P = True
+isPtr _ = False
+
+-- -----------------------------------------------------------------------------
+-- Registers
+
+type Reg = String
+
+availableRegs :: ([Reg],[Reg],[Reg],[Reg])
+availableRegs =
+ ( vanillaRegs MAX_REAL_VANILLA_REG,
+ floatRegs MAX_REAL_FLOAT_REG,
+ doubleRegs MAX_REAL_DOUBLE_REG,
+ longRegs MAX_REAL_LONG_REG
+ )
+
+vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
+vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ] -- never use R1
+floatRegs n = [ "F" ++ show m | m <- [1..n] ]
+doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
+longRegs n = [ "L" ++ show m | m <- [1..n] ]
+
+-- -----------------------------------------------------------------------------
+-- Loading/saving register arguments to the stack
+
+loadRegArgs :: Int -> [ArgRep] -> (Doc,Int)
+loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
+ where
+ (reg_locs, sp') = assignRegs sp args
+
+-- a bit like assignRegs in CgRetConv.lhs
+assignRegs
+ :: Int -- Sp of first arg
+ -> [ArgRep] -- args
+ -> ([(Reg,Int)], Int) -- Sp and rest of args
+assignRegs sp args = assign sp args availableRegs []
+
+assign sp [] regs doc = (doc, sp)
+assign sp (V : args) regs doc = assign sp args regs doc
+assign sp (arg : args) regs doc
+ = case findAvailableReg arg regs of
+ Just (reg, regs') -> assign (sp + argSize arg) args regs'
+ ((reg, sp) : doc)
+ Nothing -> (doc, sp)
+
+findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
+ Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
+ Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
+ Just (freg, (vregs,fregs,dregs,lregs))
+findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
+ Just (dreg, (vregs,fregs,dregs,lregs))
+findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
+ Just (lreg, (vregs,fregs,dregs,lregs))
+findAvailableReg _ _ = Nothing
+
+assign_reg_to_stk reg@('F':_) sp
+ = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('D':_) sp
+ = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('L':_) sp
+ = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg sp
+ = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
+
+assign_stk_to_reg reg@('F':_) sp
+ = text reg <> text " = " <> text "PK_FLT(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('D':_) sp
+ = text reg <> text " = " <> text "PK_DBL(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('L':_) sp
+ = text reg <> text " = " <> text "PK_Word64(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg sp
+ = text reg <> text " = Sp[" <> int sp <> text "];"
+
+
+-- make a ptr/non-ptr bitmap from a list of argument types
+mkBitmap :: [ArgRep] -> Word32
+mkBitmap args = foldr f 0 args
+ where f arg bm | isPtr arg = bm `shiftL` 1
+ | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
+ where size = argSize arg
+
+-- -----------------------------------------------------------------------------
+-- Generating the application functions
+
+mkApplyRetName args
+ = text "stg_ap_" <> text (map showArg args) <> text "_ret"
+
+mkApplyInfoName args
+ = text "stg_ap_" <> text (map showArg args) <> text "_info"
+
+genMkPAP macro jump is_pap args all_args_size fun_info_label
+ = smaller_arity_cases
+ $$ exact_arity_case
+ $$ larger_arity_case
+
+ where
+ n_args = length args
+
+-- The SMALLER ARITY cases:
+-- if (arity == 1) {
+-- Sp[0] = Sp[1];
+-- Sp[1] = (W_)&stg_ap_1_info;
+-- JMP_(GET_ENTRY(R1.cl));
+
+ smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
+
+ smaller_arity arity
+ = text "if (arity == " <> int arity <> text ") {" $$
+ let
+ (reg_doc, sp')
+ | is_pap = (empty, 1)
+ | otherwise = loadRegArgs 1 these_args
+ in
+ nest 4 (vcat [
+ reg_doc,
+ vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
+ text "Sp[" <> int these_args_size <> text "] = (W_)&" <>
+ mkApplyInfoName rest_args <> semi,
+ text "Sp += " <> int (sp' - 1) <> semi,
+ -- for a PAP, we have to arrange that the stack contains a
+ -- return address in the even that stg_PAP_entry fails its
+ -- heap check. See stg_PAP_entry in Apply.hc for details.
+ if is_pap
+ then text "Sp--; Sp[0] = (W_)&" <> mkApplyInfoName these_args <> semi
+ else empty,
+ text "JMP_" <> parens (text jump) <> semi
+ ]) $$
+ text "}"
+ where
+ (these_args, rest_args) = splitAt arity args
+ these_args_size = sum (map argSize these_args)
+
+ shuffle_down i =
+ text "Sp[" <> int (i-1) <> text "] = Sp["
+ <> int i <> text "];"
+
+-- The EXACT ARITY case
+--
+-- if (arity == 1) {
+-- Sp++;
+-- JMP_(GET_ENTRY(R1.cl));
+
+ exact_arity_case
+ = text "if (arity == " <> int n_args <> text ") {" $$
+ let
+ (reg_doc, sp')
+ | is_pap = (empty, 0)
+ | otherwise = loadRegArgs 1 args
+ in
+ nest 4 (vcat [
+ reg_doc,
+ text "Sp += " <> int sp' <> semi,
+ if is_pap
+ then text "Sp[0] = (W_)&" <> fun_info_label <> semi
+ else empty,
+ text "JMP_" <> parens (text jump) <> semi
+ ])
+
+-- The LARGER ARITY cases:
+--
+-- } else /* arity > 1 */ {
+-- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
+-- }
+
+ larger_arity_case =
+ text "} else {" $$
+ nest 4 (
+ text macro <> char '(' <> int n_args <> comma <>
+ int all_args_size <>
+ text ",(W_)&" <> fun_info_label <>
+ text ");"
+ ) $$
+ char '}'
+
+-- -----------------------------------------------------------------------------
+-- generate an apply function
+
+-- args is a list of 'p', 'n', 'f', 'd' or 'l'
+
+genApply args =
+ let
+ fun_ret_label = mkApplyRetName args
+ fun_info_label = mkApplyInfoName args
+ all_args_size = sum (map argSize args)
+ in
+ vcat [
+ text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
+ fun_ret_label <> text "," <>
+ text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
+ int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
+ text "0,0,0,RET_SMALL,,EF_,0,0);",
+ text "",
+ text "F_ " <> fun_ret_label <> text "( void )\n{",
+ nest 4 (vcat [
+ text "StgInfoTable *info;",
+ text "nat arity;",
+
+-- if fast == 1:
+-- print "static void *lbls[] ="
+-- print " { [FUN] &&fun_lbl,"
+-- print " [FUN_1_0] &&fun_lbl,"
+-- print " [FUN_0_1] &&fun_lbl,"
+-- print " [FUN_2_0] &&fun_lbl,"
+-- print " [FUN_1_1] &&fun_lbl,"
+-- print " [FUN_0_2] &&fun_lbl,"
+-- print " [FUN_STATIC] &&fun_lbl,"
+-- print " [PAP] &&pap_lbl,"
+-- print " [THUNK] &&thunk_lbl,"
+-- print " [THUNK_1_0] &&thunk_lbl,"
+-- print " [THUNK_0_1] &&thunk_lbl,"
+-- print " [THUNK_2_0] &&thunk_lbl,"
+-- print " [THUNK_1_1] &&thunk_lbl,"
+-- print " [THUNK_0_2] &&thunk_lbl,"
+-- print " [THUNK_STATIC] &&thunk_lbl,"
+-- print " [THUNK_SELECTOR] &&thunk_lbl,"
+-- print " [IND] &&ind_lbl,"
+-- print " [IND_OLDGEN] &&ind_lbl,"
+-- print " [IND_STATIC] &&ind_lbl,"
+-- print " [IND_PERM] &&ind_lbl,"
+-- print " [IND_OLDGEN_PERM] &&ind_lbl"
+-- print " };"
+
+ text "FB_",
+ text "",
+ text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <>
+ text "... \"); printClosure(R1.cl));",
+
+ text "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
+ <> text "));",
+
+-- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
+-- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
+
+ text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
+
+ let do_assert [] _ = []
+ do_assert (arg:args) offset
+ | isPtr arg = this : rest
+ | otherwise = rest
+ where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp["
+ <> int offset <> text "]));"
+ rest = do_assert args (offset + argSize arg)
+ in
+ vcat (do_assert args 1),
+
+ text "again:",
+ text "info = get_itbl(R1.cl);",
+
+-- if fast == 1:
+-- print " goto *lbls[info->type];";
+-- else:
+ text "switch (info->type) {" $$
+ nest 4 (vcat [
+
+-- if fast == 1:
+-- print " bco_lbl:"
+-- else:
+ text "case BCO:",
+ nest 4 (vcat [
+ text "arity = BCO_ARITY((StgBCO *)R1.p);",
+ text "goto apply_fun;"
+ ]),
+
+-- if fast == 1:
+-- print " fun_lbl:"
+-- else:
+ text "case FUN:",
+ text "case FUN_1_0:",
+ text "case FUN_0_1:",
+ text "case FUN_2_0:",
+ text "case FUN_1_1:",
+ text "case FUN_0_2:",
+ text "case FUN_STATIC:",
+ nest 4 (vcat [
+ text "arity = itbl_to_fun_itbl(info)->arity;",
+ text "apply_fun:",
+ text "ASSERT(arity > 0);",
+ genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)" False{-not PAP-}
+ args all_args_size fun_info_label
+ ]),
+
+-- if fast == 1:
+-- print " pap_lbl:"
+-- else:
+
+ text "case PAP:",
+ nest 4 (vcat [
+ text "arity = ((StgPAP *)R1.p)->arity;",
+ text "ASSERT(arity > 0);",
+ genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-}
+ args all_args_size fun_info_label
+ ]),
+
+ text "",
+
+-- if fast == 1:
+-- print " thunk_lbl:"
+-- else:
+ text "case AP:",
+ text "case AP_STACK:",
+ text "case CAF_BLACKHOLE:",
+ text "case BLACKHOLE:",
+ text "case BLACKHOLE_BQ:",
+ text "case SE_BLACKHOLE:",
+ text "case SE_CAF_BLACKHOLE:",
+ text "case THUNK:",
+ text "case THUNK_1_0:",
+ text "case THUNK_0_1:",
+ text "case THUNK_2_0:",
+ text "case THUNK_1_1:",
+ text "case THUNK_0_2:",
+ text "case THUNK_STATIC:",
+ text "case THUNK_SELECTOR:",
+ nest 4 (vcat [
+ text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
+ text "JMP_(GET_ENTRY(R1.cl));",
+ text ""
+ ]),
+
+-- if fast == 1:
+-- print " ind_lbl:"
+-- else:
+ text "case IND:",
+ text "case IND_OLDGEN:",
+ text "case IND_STATIC:",
+ text "case IND_PERM:",
+ text "case IND_OLDGEN_PERM:",
+ nest 4 (vcat [
+ text "R1.cl = ((StgInd *)R1.p)->indirectee;",
+ text "goto again;"
+ ]),
+ text "",
+
+-- if fast == 0:
+
+ text "default:",
+ nest 4 (
+ text "barf(\"" <> fun_ret_label <> text "\");"
+ ),
+ text "}"
+
+ ])
+ ]),
+ text "FE_",
+ text "}"
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Making a stack apply
+
+-- These little functions are like slow entry points. They provide
+-- the layer between the PAP entry code and the function's fast entry
+-- point: namely they load arguments off the stack into registers (if
+-- available) and jump to the function's entry code.
+--
+-- On entry: R1 points to the function closure
+-- arguments are on the stack starting at Sp
+--
+-- Invariant: the list of arguments never contains void. Since we're only
+-- interested in loading arguments off the stack here, we can ignore
+-- void arguments.
+
+mkStackApplyEntryLabel:: [ArgRep] -> Doc
+mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
+
+genStackApply :: [ArgRep] -> Doc
+genStackApply args =
+ let fn_entry_label = mkStackApplyEntryLabel args in
+ vcat [
+ text "IF_" <> parens fn_entry_label,
+ text "{",
+ nest 4 (text "FB_" $$ body $$ text "FE_"),
+ text "}"
+ ]
+ where
+ (assign_regs, sp') = loadRegArgs 0 args
+ body = vcat [assign_regs,
+ text "Sp += " <> int sp' <> semi,
+ text "JMP_(GET_ENTRY(R1.cl));"
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Stack save entry points.
+--
+-- These code fragments are used to save registers on the stack at a heap
+-- check failure in the entry code for a function. We also have to save R1
+-- and the return address (stg_gen_ap_info) on the stack. See stg_fun_gc_gen
+-- in HeapStackCheck.hc for more details.
+
+mkStackSaveEntryLabel :: [ArgRep] -> Doc
+mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
+
+genStackSave :: [ArgRep] -> Doc
+genStackSave args =
+ let fn_entry_label= mkStackSaveEntryLabel args in
+ vcat [
+ text "IF_" <> parens fn_entry_label,
+ text "{",
+ nest 4 (text "FB_" $$ body $$ text "FE_"),
+ text "}"
+ ]
+ where
+ body = vcat [text "Sp -= " <> int sp_offset <> semi,
+ vcat (map (uncurry assign_reg_to_stk) reg_locs),
+ text "Sp[2] = R1.w;",
+ text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
+ text "Sp[0] = (W_)&stg_gc_fun_info;",
+ text "JMP_(stg_gc_noregs);"
+ ]
+
+ std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
+ -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
+ (reg_locs, sp_offset) = assignRegs std_frame_size args
+
+-- -----------------------------------------------------------------------------
+-- The prologue...
+
+main = putStr (render the_code)
+ where the_code = vcat [
+ text "// DO NOT EDIT!",
+ text "// Automatically generated by GenApply.hs",
+ text "",
+ text "#include \"Stg.h\"",
+ text "#include \"Rts.h\"",
+ text "#include \"RtsFlags.h\"",
+ text "#include \"Storage.h\"",
+ text "#include \"RtsUtils.h\"",
+ text "#include \"Printer.h\"",
+ text "#include \"Sanity.h\"",
+ text "#include \"Apply.h\"",
+ text "",
+ text "#include <stdio.h>",
+
+ vcat (intersperse (text "") $ map genApply applyTypes),
+ vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
+
+ genStackApplyArray stackApplyTypes,
+ genStackSaveArray stackApplyTypes,
+ genBitmapArray stackApplyTypes,
+
+ text "" -- add a newline at the end of the file
+ ]
+
+-- These have been shown to cover about 99% of cases in practice...
+applyTypes = [
+ [V],
+ [F],
+ [D],
+ [L],
+ [N],
+ [P],
+ [P,V],
+ [P,P],
+ [P,P,V],
+ [P,P,P],
+ [P,P,P,P],
+ [P,P,P,P,P],
+ [P,P,P,P,P,P],
+ [P,P,P,P,P,P,P]
+ ]
+
+-- No need for V args in the stack apply cases.
+-- ToDo: the stack apply and stack save code doesn't make a distinction
+-- between N and P (they both live in the same register), only the bitmap
+-- changes, so we could share the apply/save code between lots of cases.
+stackApplyTypes = [
+ [N],
+ [P],
+ [F],
+ [D],
+ [L],
+ [N,N],
+ [N,P],
+ [P,N],
+ [P,P],
+ [N,N,N],
+ [N,N,P],
+ [N,P,N],
+ [N,P,P],
+ [P,N,N],
+ [P,N,P],
+ [P,P,N],
+ [P,P,P],
+ [P,P,P,P],
+ [P,P,P,P,P],
+ [P,P,P,P,P,P],
+ [P,P,P,P,P,P,P],
+ [P,P,P,P,P,P,P,P]
+ ]
+
+genStackFns args = genStackApply args $$ genStackSave args
+
+
+genStackApplyArray types =
+ text "StgFun *stg_ap_stack_entries[] = {" $$
+ vcat (map arr_ent types) $$
+ text "};"
+ where
+ arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
+
+genStackSaveArray types =
+ text "StgFun *stg_stack_save_entries[] = {" $$
+ vcat (map arr_ent types) $$
+ text "};"
+ where
+ arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
+
+genBitmapArray :: [[ArgRep]] -> Doc
+genBitmapArray types =
+ vcat [
+ text "StgWord stg_arg_bitmaps[] = {",
+ vcat (map gen_bitmap types),
+ text "};"
+ ]
+ where
+ gen_bitmap ty = brackets (arg_const ty) <+>
+ text "MK_SMALL_BITMAP" <> parens (
+ int (sum (map argSize ty)) <> comma <>
+ text (show (mkBitmap ty))) <>
+ comma
+
+arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))
+
--- /dev/null
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+HS_PROG = $(GHC_GENAPPLY_PGM)
+
+# genapply is needed to boot in ghc/rts...
+ifneq "$(BootingFromHc)" "YES"
+boot :: all
+endif
+
+ghc_ge_504 = $(shell if (test $(GhcCanonVersion) -ge 504); then echo YES; else echo NO; fi)
+
+ifeq "$(ghc_ge_504)" "NO"
+SRC_HC_OPTS += -package lang -package util -package text
+endif
+
+include $(TOP)/mk/target.mk
projects / ghc-hetmet.git / commitdiff