Commit 0bffc410 authored by simonmar's avatar simonmar

[project @ 2002-12-11 15:36:20 by simonmar]

Merge the eval-apply-branch on to the HEAD
------------------------------------------

This is a change to GHC's evaluation model in order to ultimately make
GHC more portable and to reduce complexity in some areas.

At some point we'll update the commentary to describe the new state of
the RTS.  Pending that, the highlights of this change are:

  - No more Su.  The Su register is gone, update frames are one
    word smaller.

  - Slow-entry points and arg checks are gone.  Unknown function calls
    are handled by automatically-generated RTS entry points (AutoApply.hc,
    generated by the program in utils/genapply).

  - The stack layout is stricter: there are no "pending arguments" on
    the stack any more, the stack is always strictly a sequence of
    stack frames.

    This means that there's no need for LOOKS_LIKE_GHC_INFO() or
    LOOKS_LIKE_STATIC_CLOSURE() any more, and GHC doesn't need to know
    how to find the boundary between the text and data segments (BIG WIN!).

  - A couple of nasty hacks in the mangler caused by the neet to
    identify closure ptrs vs. info tables have gone away.

  - Info tables are a bit more complicated.  See InfoTables.h for the
    details.

  - As a side effect, GHCi can now deal with polymorphic seq.  Some bugs
    in GHCi which affected primitives and unboxed tuples are now
    fixed.

  - Binary sizes are reduced by about 7% on x86.  Performance is roughly
    similar, some programs get faster while some get slower.  I've seen
    GHCi perform worse on some examples, but haven't investigated
    further yet (GHCi performance *should* be about the same or better
    in theory).

  - Internally the code generator is rather better organised.  I've moved
    info-table generation from the NCG into the main codeGen where it is
    shared with the C back-end; info tables are now emitted as arrays
    of words in both back-ends.  The NCG is one step closer to being able
    to support profiling.

This has all been fairly thoroughly tested, but no doubt I've messed
up the commit in some way.
parent a63622cc
......@@ -58,9 +58,11 @@ name = Util.global (value) :: IORef (ty); \
#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}
......@@ -191,6 +191,7 @@ stored in a mixed type location.)
-- *** 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.
......@@ -198,18 +199,12 @@ stored in a mixed type location.)
| 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
......@@ -260,14 +255,10 @@ macros. An example is @STK_CHK@, which checks for stack-space
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)
......@@ -293,11 +284,10 @@ data CCheckMacro
= 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
......@@ -306,9 +296,8 @@ data CCheckMacro
| 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@:]
......@@ -469,7 +458,7 @@ bitmap to C compilation time (or rather, C preprocessing time).
\begin{code}
type LivenessMask = [BitSet]
data Liveness = Liveness CLabel LivenessMask
data Liveness = Liveness CLabel !Int LivenessMask
\end{code}
%************************************************************************
......@@ -515,7 +504,6 @@ data MagicId
-- 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
......@@ -545,7 +533,6 @@ instance Eq MagicId where
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)
......
......@@ -144,7 +144,6 @@ magicIdPrimRep (FloatReg _) = FloatRep
magicIdPrimRep (DoubleReg _) = DoubleRep
magicIdPrimRep (LongReg kind _) = kind
magicIdPrimRep Sp = PtrRep
magicIdPrimRep Su = PtrRep
magicIdPrimRep SpLim = PtrRep
magicIdPrimRep Hp = PtrRep
magicIdPrimRep HpLim = PtrRep
......@@ -320,11 +319,10 @@ flatAbsC (AbsCStmts s1 s2)
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)
......@@ -418,10 +416,10 @@ flatAbsC (CSequential abcs)
-- 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}
......@@ -12,8 +10,8 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
mkInfoTableLabel,
mkStdEntryLabel,
mkFastEntryLabel,
mkEntryLabel,
mkSlowEntryLabel,
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
......@@ -62,6 +60,9 @@ module CLabel (
mkSelectorInfoLabel,
mkSelectorEntryLabel,
mkRtsApplyInfoLabel,
mkRtsApplyEntryLabel,
mkForeignLabel,
mkCC_Label, mkCCS_Label,
......@@ -149,20 +150,17 @@ data CLabel
\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
......@@ -178,13 +176,12 @@ data CaseLabelInfo
| 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
......@@ -206,12 +203,16 @@ data RtsLabelInfo
| RtsModuleRegd
| RtsApplyInfoLabel LitString
| RtsApplyEntryLabel LitString
deriving (Eq, Ord)
-- Label Type: for generating C declarations.
data CLabelType
= InfoTblType
= RetInfoTblType
| InfoTblType
| ClosureType
| VecTblType
| ClosureTblType
......@@ -223,10 +224,9 @@ data CLabelType
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)
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
......@@ -240,7 +240,7 @@ mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
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
......@@ -266,10 +266,10 @@ mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
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)
......@@ -291,6 +291,11 @@ mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic
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}
......@@ -312,6 +317,10 @@ Declarations for direct return points are needed, because they may be
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
......@@ -354,26 +363,35 @@ externallyVisibleCLabel (CC_Label _) = False -- not strictly 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
Bitmap -> DataType
_ -> CodeType
labelType (DataConLabel _ info) =
......@@ -429,6 +447,7 @@ internal names. <type> is one of the following:
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)
......@@ -471,8 +490,6 @@ pprCLbl (CaseLabel u (CaseAlt tag))
= 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
......@@ -488,7 +505,7 @@ pprCLbl (RtsLabel (Rts_Code str)) = text str
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),
......@@ -518,6 +535,12 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
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")
......@@ -550,10 +573,10 @@ ppIdFlavor x = pp_cSEP <>
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)
Entry -> ptext SLIT("entry")
Slow -> ptext SLIT("slow")
RednCounts -> ptext SLIT("ct")
Bitmap -> ptext SLIT("btm")
)
ppConFlavor x = pp_cSEP <>
......@@ -564,4 +587,3 @@ 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
% ---------------------------------------------------------------------------
......@@ -217,13 +217,13 @@ costs absC =
CCallTypedef _ _ _ _ _ -> nullCosts
CStaticClosure _ _ _ -> nullCosts
CStaticClosure _ _ _ _ -> nullCosts
CSRT _ _ -> nullCosts
CBitmap _ _ -> nullCosts
CBitmap _ -> nullCosts
CClosureInfoAndCode _ _ _ _ -> nullCosts
CClosureInfoAndCode _ _ -> nullCosts
CRetVector _ _ _ _ -> nullCosts
......@@ -309,15 +309,10 @@ stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes
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 -}
......
......@@ -29,9 +29,8 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
playThreadSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
mkClosureLabel, mkErrorStdEntryLabel,
CLabel, CLabelType(..), labelType, labelDynamic
)
......@@ -39,18 +38,17 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
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
......@@ -59,12 +57,18 @@ import StgSyn ( StgOp(..) )
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
......@@ -191,7 +195,7 @@ pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
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)
......@@ -295,11 +299,11 @@ pprAbsC stmt@(CSRT lbl closures) c
<> 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
......@@ -390,7 +394,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args)
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) ->
......@@ -399,7 +403,7 @@ pprAbsC (CCodeBlock lbl abs_C) _
pp_exts,
hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
else "IFN_("),
else "IF_("),
pprCLabel lbl, text ") {"],
pp_temps,
......@@ -423,7 +427,7 @@ pprAbsC (CInitHdr cl_info amode cost_centre size) _
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,
......@@ -440,7 +444,6 @@ pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _
ptext SLIT("};") ]
}
where
closure_lbl = closureLabelFromCI cl_info
info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
......@@ -457,81 +460,13 @@ pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _
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 stmt@(CClosureInfoAndCode cl_info entry) _
= pprInfoTable info_lbl (mkInfoTable cl_info)
$$ let stuff = CCodeBlock entry_lbl entry in
pprAbsC stuff (costs stuff)
]
where
entry_lbl = entryLabelFromCI cl_info
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)
pprAbsC stmt@(CClosureTbl tycon) _
= vcat (
......@@ -543,58 +478,15 @@ pprAbsC stmt@(CClosureTbl tycon) _
) $$ 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"))
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 [
......@@ -609,6 +501,22 @@ pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
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 '+'
......@@ -753,6 +661,7 @@ ppLocalnessMacro include_dyn_prefix clabel =
ClosureType -> ptext SLIT("C_")
CodeType -> ptext SLIT("F_")
InfoTblType -> ptext SLIT("I_")
RetInfoTblType -> ptext SLIT("RI_")
ClosureTblType -> ptext SLIT("CP_")
DataType -> ptext SLIT("D_")
]
......@@ -805,7 +714,7 @@ ppr_vol_regs (r:rs)