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
......@@ -222,11 +223,10 @@ data CLabelType
\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
......@@ -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,27 +363,36 @@ 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
_ -> CodeType
InfoTbl -> InfoTblType
Closure -> ClosureType
Bitmap -> DataType
_ -> CodeType
labelType (DataConLabel _ info) =
case info of
......@@ -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")
......@@ -549,11 +572,11 @@ ppIdFlavor x = pp_cSEP <>
(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 <>
......@@ -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 -}
......
This diff is collapsed.
......@@ -23,7 +23,7 @@ module CgBindery (
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
buildLivenessMask, buildContLivenessMask
buildContLivenessMask
) where
#include "HsVersions.h"
......@@ -32,7 +32,7 @@ import AbsCSyn
import CgMonad
import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
import CgStackery ( freeStackSlots )
import CgStackery ( freeStackSlots, getStackFrame )
import CLabel ( mkClosureLabel,
mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
......@@ -44,7 +44,7 @@ import VarEnv
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
......@@ -85,7 +85,7 @@ data VolatileLoc
| 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)
......@@ -361,7 +361,7 @@ bindNewToStack :: (Id, VirtualSpOffset) -> Code
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
......@@ -374,7 +374,7 @@ 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.
......@@ -392,7 +392,7 @@ bindArgsToRegs :: [Id] -> [MagicId] -> Code
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
......@@ -449,43 +449,41 @@ pointer has its own bitmap to describe the update frame).
\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
......@@ -503,24 +501,27 @@ listToLivenessMask [] = []
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}
%************************************************************************
......
This diff is collapsed.
This diff is collapsed.
......@@ -26,25 +26,22 @@ import CgBindery ( getArgAmodes, bindNewToNode,
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
)
......@@ -55,6 +52,8 @@ import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
import Util
import Outputable
import List ( partition )
\end{code}
%************************************************************************
......@@ -78,14 +77,15 @@ cgTopRhsCon id con args srt
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
......@@ -186,10 +186,10 @@ buildDynCon binder ccs con args
= 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
......@@ -220,10 +220,8 @@ bindConArgs con args
= 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
......@@ -231,33 +229,44 @@ returned in registers and on the stack instead of the heap.
\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