%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.23 1999/05/13 17:30:52 simonm Exp $
+% $Id: AbsCSyn.lhs,v 1.24 1999/06/24 13:04:13 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, spRelToInt )
import CostCentre ( CostCentre, CostCentreStack )
-import Const ( mkMachInt, Literal )
+import Const ( mkMachInt, Literal(..) )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp )
import Unique ( Unique )
| CInitHdr -- to initialise the header of a closure (both fixed/var parts)
ClosureInfo
- RegRelative -- address of the info ptr
+ CAddrMode -- address of the info ptr
CAddrMode -- cost centre to place in closure
-- CReg CurCostCentre or CC_HDR(R1.p{-Node-})
| 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
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
| GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
| THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL
| GRAN_YIELD -- for GrAnSim only -- HWL
- deriving Text
\end{code}
Heap/Stack checks. There are far too many of these.
| HP_CHK_UT_ALT -- unboxed tuple return.
| HP_CHK_GEN -- generic heap check
- deriving Text
\end{code}
\item[@CCallProfCtrMacro@:]
| CReg MagicId -- To replace (CAddr MagicId 0)
- | CTableEntry -- CVal should be generalized to allow this
- CAddrMode -- Base
- CAddrMode -- Offset
- PrimRep -- For casting
-
| CTemp !Unique !PrimRep -- Temporary locations
-- ``Temporaries'' correspond to local variables in C, and registers in
-- native code.
-- specified small integer. It is guaranteed to be in
-- the range mIN_INTLIKE..mAX_INTLIKE
- | CString FAST_STRING -- The address of the null-terminated string
| CLit Literal
+
| CLitLit FAST_STRING -- completely literal literal: just spit this String
-- into the C output
PrimRep
= ENTRY_CODE
| ARG_TAG -- stack argument tagging
| GET_TAG -- get current constructor tag
- deriving(Text)
+ | UPD_FRAME_UPDATEE
\end{code}
mkIntCLit :: Int -> CAddrMode
mkIntCLit i = CLit (mkMachInt (toInteger i))
+mkCString :: FAST_STRING -> CAddrMode
+mkCString s = CLit (MachStr s)
+
mkCCostCentre :: CostCentre -> CAddrMode
mkCCostCentre cc = CLbl (mkCC_Label cc) DataPtrRep
= HpRel FAST_INT -- }
| SpRel FAST_INT -- }- offsets in StgWords
| NodeRel FAST_INT -- }
+ | CIndex CAddrMode CAddrMode PrimRep -- pointer arithmetic :-)
+ -- CIndex a b k === (k*)a[b]
data ReturnInfo
= DirectReturn -- Jump directly, if possible
%************************************************************************
%* *
-\subsection[RegRelative]{@RegRelatives@: ???}
+\subsection[Liveness]{Liveness Masks}
%* *
%************************************************************************
getAmodeRep (CLbl label kind) = kind
getAmodeRep (CCharLike _) = PtrRep
getAmodeRep (CIntLike _) = PtrRep
-getAmodeRep (CString _) = PtrRep
getAmodeRep (CLit lit) = literalPrimRep lit
getAmodeRep (CLitLit _ kind) = kind
-getAmodeRep (CTableEntry _ _ kind) = kind
getAmodeRep (CMacroExpr kind _ _) = kind
-#ifdef DEBUG
getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
-#endif
\end{code}
@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)
- CAssign (CReg _) (CAddr _) -> Cost (1,0,0,0,0) -- typ.: add %reg1,<adr>,%reg2
+ CAssign (CReg _) source_m -> addrModeCosts source_m Rhs
CAssign target_m source_m -> addrModeCosts target_m Lhs +
addrModeCosts source_m Rhs
CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
else Cost (0, 0, 1, 0, 0)
- CAddr _ -> if lhs then Cost (0, 0, 0, 1, 0) -- ??unchecked
- else Cost (0, 0, 1, 0, 0)
-
CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
{- for costing CReg->Creg ops see special -}
{- case in costs fct -}
- CTableEntry base_mode offset_mode kind ->
- addrModeCosts base_mode side +
- addrModeCosts offset_mode side +
- Cost (1,0,1,0,0)
CTemp _ _ -> nullCosts {- if lhs then Cost (0, 0, 0, 1, 0)
else Cost (0, 0, 1, 0, 0) -}
CIntLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
else Cost (0, 0, 1, 0, 0)
- CString _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
-
CLit _ -> if lhs then nullCosts -- should never occur
else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
GRAN_YIELD -> nullCosts {- GrAnSim bookkeeping -- added SOF -}
THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -}
- _ -> trace ("Costs.stmtMacroCosts: "++show macro) nullCosts
+ _ -> trace ("Costs.stmtMacroCosts") nullCosts
-- ---------------------------------------------------------------------------
pprAmode am, rparen]
DynamicVectoredReturn am' -> mk_vector (pprAmode am')
StaticVectoredReturn n -> mk_vector (int n) -- Always positive
- mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma,
+ mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
x, rparen ]
pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
= hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
pprAbsC (CCheck macro as code) c
- = hcat [text (show macro), lparen,
+ = hcat [ptext (cCheckMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)), comma,
pprAbsC code c, pp_paren_semi
]
pprAbsC (CMacroStmt macro as) _
- = hcat [text (show macro), lparen,
+ = hcat [ptext (cStmtMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
pprAbsC (CCallProfCtrMacro op as) _
= hcat [ptext op, lparen,
}
-pprAbsC (CInitHdr cl_info reg_rel cost_centre) _
+pprAbsC (CInitHdr cl_info amode cost_centre) _
= hcat [ ptext SLIT("SET_HDR_"), char '(',
- ppr_amode (CAddr reg_rel), comma,
+ ppr_amode amode, comma,
pprCLabelAddr info_lbl, comma,
if_profiling (pprAmode cost_centre),
pp_paren_semi ]
Lastly, the question is: will the C compiler think the types of the
two sides of the assignment match?
- We assume that the types will match
- if neither side is a @CVal@ addressing mode for any register
- which can point into the heap or B stack.
+ We assume that the types will match if neither side is a
+ @CVal@ addressing mode for any register which can point into
+ the heap or stack.
-Why? Because the heap and B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things
-of fixed type.
+Why? Because the heap and stack are used to store miscellaneous
+things, whereas the temporaries, registers, etc., are only used for
+things of fixed type.
\begin{code}
pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
ppr_amode (CIntLike int)
= hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
-ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"']
- -- ToDo: are these *used* for anything?
-
ppr_amode (CLit lit) = pprBasicLit lit
ppr_amode (CLitLit str _) = ptext str
ppr_amode (CJoinPoint _)
= panic "ppr_amode: CJoinPoint"
-ppr_amode (CTableEntry base index kind)
- = hcat [text "((", pprPrimKind kind, text " *)(",
- ppr_amode base, text "))[(I_)(", ppr_amode index,
- ptext SLIT(")]")]
-
ppr_amode (CMacroExpr pk macro as)
- = parens (pprPrimKind pk) <+>
- parens (text (show macro) <>
+ = parens (pprPrimKind pk) <>
+ parens (ptext (cExprMacroText macro) <>
parens (hcat (punctuate comma (map pprAmode as))))
\end{code}
+\begin{code}
+cExprMacroText ENTRY_CODE = SLIT("ENTRY_CODE")
+cExprMacroText ARG_TAG = SLIT("ARG_TAG")
+cExprMacroText GET_TAG = SLIT("GET_TAG")
+cExprMacroText UPD_FRAME_UPDATEE = SLIT("UPD_FRAME_UPDATEE")
+
+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 GRAN_FETCH = SLIT("GRAN_FETCH")
+cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
+cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
+cStmtMacroText THREAD_CONTEXT_SWITCH = SLIT("THREAD_CONTEXT_SWITCH")
+cStmtMacroText GRAN_YIELD = SLIT("GRAN_YIELD")
+
+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_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")
+\end{code}
+
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
else
(pp_Node, Just (addPlusSign sign_wanted (int off)))
+pprRegRelative sign_wanted (CIndex base offset kind)
+ = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
+ , Just (hcat [if sign_wanted then char '+' else empty,
+ text "(I_)(", ppr_amode offset, ptext SLIT(")")])
+ )
\end{code}
@pprMagicId@ just prints the register name. @VanillaReg@ registers are
\begin{code}
ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
+ppr_decls_Amode (CVal (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
+ppr_decls_Amode (CAddr (CIndex base offset _)) = ppr_decls_Amodes [base,offset]
ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing)
returnTE (Nothing,
if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} label))
-ppr_decls_Amode (CTableEntry base index _)
- = ppr_decls_Amode base `thenTE` \ p1 ->
- ppr_decls_Amode index `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
-
ppr_decls_Amode (CMacroExpr _ _ amodes)
= ppr_decls_Amodes amodes
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.32 1999/06/22 07:59:59 simonpj Exp $
+% $Id: CgCase.lhs,v 1.33 1999/06/24 13:04:16 simonmar Exp $
%
%********************************************************
%* *
TagToEnumOp -> only arg_amodes
_ -> CTemp (mkBuiltinUnique 1) IntRep
- closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
+ closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
in
case op of {
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.32 1999/06/08 15:56:46 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.33 1999/06/24 13:04:17 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
fast_entry_code
= profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
- mkIntCLit stg_arity -- total # of args
-
- {- CLbl (mkRednCountsLabel name) PtrRep,
- CString (_PK_ (showSDoc (ppr name))),
+ CLbl (mkRednCountsLabel name) PtrRep,
+ mkCString (_PK_ (showSDoc (ppr name))),
mkIntCLit stg_arity, -- total # of args
mkIntCLit sp_stk_args, -- # passed on stk
- CString (_PK_ (map (showTypeCategory . idType) all_args)),
- CString SLIT(""), CString SLIT("")
- -}
+ mkCString (_PK_ (map (showTypeCategory . idType) all_args))
+ ] `thenC`
-- Nuked for now; see comment at end of file
-- CString (_PK_ (show_wrapper_name wrapper_maybe)),
-- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
- ] `thenC`
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps.
link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
else
nopC) `thenC`
- profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [CString cl_name] `thenC`
+ profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
code
(True ,False) -> pushUpdateFrame (CReg node) code
(True ,True ) -> -- blackhole the (updatable) CAF:
link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
- profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [CString cl_name] `thenC`
+ profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
pushUpdateFrame update_closure code
where
cl_name :: FAST_STRING
idInfoToAmode, stableAmodeIdInfo,
heapIdInfo, CgIdInfo, bindNewToStack
)
-import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
-import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp )
+import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots,
+ updateFrameSize
+ )
+import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
+ getSpRelOffset )
import CgClosure ( cgTopRhsClosure )
import CgRetConv ( assignRegs )
-import Constants ( mAX_INTLIKE, mIN_INTLIKE )
-import CgHeapery ( allocDynClosure )
+import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
+import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
mkUnboxedTupleReturnCode )
import CLabel ( mkClosureLabel, mkStaticClosureLabel )
import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
- layOutStaticClosure
+ layOutStaticClosure, closureSize
)
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
import Module ( isDynamicModule )
import Const ( Con(..), Literal(..), isLitLitLit )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
-import PrimRep ( PrimRep(..) )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Unique ( Uniquable(..) )
import Util
import Panic ( assertPanic, trace )
\end{code}
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
+ CaseAlts _ (Just (alts, Just (Nothing, (_,deflt_lbl))))
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
-- In this case,
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
- --
- -- if the default is a bind-default (ie does use y), we
- -- should return the constructor in the heap,
- -- pointed to by Node.
-
- case maybe_deflt_binder of
- Just binder ->
- ASSERT(not (isUnboxedTupleCon con))
- buildDynCon binder currentCCS con amodes all_zero_size_args
- `thenFC` \ idinfo ->
- profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
- performReturn (move_to_reg amode node) jump_to_join_point
-
- Nothing ->
- performReturn AbsCNop {- No reg assts -} jump_to_join_point
+
+ performReturn AbsCNop {- No reg assts -} jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
-- Ignore the sequel: we've already looked at it above
+ -- If the sequel is an update frame, we might be able to
+ -- do update in place...
+ UpdateCode
+ | not all_zero_size_args -- no nullary constructors, please
+ && not (maybeCharLikeCon con) -- no chars please (these are all static)
+ && not (any isFollowableRep (map getAmodeRep amodes))
+ -- no ptrs please (generational gc...)
+ && closureSize closure_info <= mIN_UPD_SIZE
+ -- don't know the real size of the
+ -- thunk, so assume mIN_UPD_SIZE
+
+ -> -- get a new temporary and make it point to the updatee
+ let
+ uniq = getUnique con
+ temp = CTemp uniq PtrRep
+ in
+ getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CAssign temp
+ (CMacroExpr PtrRep UPD_FRAME_UPDATEE [CAddr sp_rel]))
+ `thenC`
+
+ -- stomp all over it with the new constructor
+ 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`
+
+ -- pop the update frame off the stack, and do the proper
+ -- return.
+ let new_sp = args_sp - updateFrameSize in
+ setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
+ performReturn (AbsCNop) (mkStaticAlgReturnCode con)
+
+ where (closure_info, stuff)
+ = layOutDynClosure (dataConName con)
+ getAmodeRep amodes lf_info
+
+ lf_info = mkConLFInfo con
+
other_sequel -- The usual case
| isUnboxedTupleCon con ->
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.27 1999/06/09 14:28:38 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.28 1999/06/24 13:04:18 simonmar Exp $
%
%********************************************************
%* *
absC (CAssign dyn_tag amode) `thenC`
performReturn (
CAssign (CReg node)
- (CTableEntry
+ (CVal (CIndex
(CLbl (mkClosureTblLabel tycon) PtrRep)
- dyn_tag PtrRep))
+ dyn_tag PtrRep) PtrRep))
(\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
where
dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
-- about to return anyway.
dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
- closure_lbl = CTableEntry
+ closure_lbl = CVal (CIndex
(CLbl (mkClosureTblLabel tycon) PtrRep)
- dyn_tag PtrRep
+ dyn_tag PtrRep) PtrRep
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.17 1999/05/26 14:12:13 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.18 1999/06/24 13:04:19 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
fastEntryChecks, altHeapCheck, thunkChecks,
- allocDynClosure
+ allocDynClosure, inPlaceAllocDynClosure
-- new functions, basically inserting macro calls into Code -- HWL
,fetchAndReschedule, yield
where
closure_size = closureSize closure_info
slop_size = slopSize closure_info
+\end{code}
+
+Occasionally we can update a closure in place instead of allocating
+new space for it. This is the function that does the business, assuming:
+
+ - node points to the closure to be overwritten
+
+ - the new closure doesn't contain any pointers if we're
+ using a generational collector.
+
+\begin{code}
+inPlaceAllocDynClosure
+ :: ClosureInfo
+ -> CAddrMode -- Pointer to beginning of closure
+ -> CAddrMode -- Cost Centre to stick in the object
+
+ -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -> Code
+
+inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
+ = let -- do_move IS THE ASSIGNMENT FUNCTION
+ do_move (amode, offset_from_start)
+ = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
+ (getAmodeRep amode))
+ amode
+ in
+ -- GENERATE THE CODE
+ absC ( mkAbstractCs (
+ [ CInitHdr closure_info head use_cc ]
+ ++ (map do_move amodes_with_offsets)))
-- Avoid hanging on to anything in the CC field when we're not profiling.
cInitHdr closure_info amode cc
- | opt_SccProfilingOn = CInitHdr closure_info amode cc
- | otherwise = CInitHdr closure_info amode (panic "absent cc")
+ | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
+ | otherwise = CInitHdr closure_info (CAddr amode) (panic "absent cc")
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.11 1999/06/08 15:56:47 simonmar Exp $
+% $Id: CgStackery.lhs,v 1.12 1999/06/24 13:04:20 simonmar Exp $
%
\section[CgStackery]{Stack management functions}
allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
adjustStackHW, getFinalStackHW,
mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
- freeStackSlots, dataStackSlots, addFreeSlots
+ freeStackSlots, dataStackSlots, addFreeSlots,
+ updateFrameSize, seqFrameSize
) where
#include "HsVersions.h"
import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
+import CmdLineOpts ( opt_SccProfilingOn )
import Panic ( panic )
+import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE )
+
import IOExts ( trace )
\end{code}
(MkCgState _ _ ((_,_,_, hwSp), _)) = state1
\end{code}
+\begin{code}
+updateFrameSize | opt_SccProfilingOn = sCC_UF_SIZE
+ | otherwise = uF_SIZE
+
+seqFrameSize | opt_SccProfilingOn = sCC_SEQ_FRAME_SIZE
+ | otherwise = sEQ_FRAME_SIZE
+\end{code}
%************************************************************************
%* *
import CgMonad
import AbsCSyn
-import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE )
import PrimRep ( PrimRep(..) )
-import CgStackery ( allocStackTop )
+import CgStackery ( allocStackTop, updateFrameSize, seqFrameSize )
import CgUsages ( getVirtSp, getSpRelOffset )
import CmdLineOpts ( opt_SccProfilingOn )
import Panic ( assertPanic )
pushUpdateFrame :: CAddrMode -> Code -> Code
pushUpdateFrame updatee code
- = let
- -- frame_size *includes* the return address
- frame_size = if opt_SccProfilingOn
- then sCC_UF_SIZE
- else uF_SIZE
- in
+ =
#ifdef DEBUG
getEndOfBlockInfo `thenFC` \ eob_info ->
ASSERT(case eob_info of { EndOfBlockInfo _ (OnStack _) -> True;
_ -> False})
#endif
- allocStackTop frame_size `thenFC` \ _ ->
- getVirtSp `thenFC` \ vsp ->
+ allocStackTop updateFrameSize `thenFC` \ _ ->
+ getVirtSp `thenFC` \ vsp ->
setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) (
it will also push the SEQ frame, using pushSeqFrame.
\begin{code}
-seq_frame_size | opt_SccProfilingOn = sCC_SEQ_FRAME_SIZE
- | otherwise = sEQ_FRAME_SIZE
-
reserveSeqFrame :: EndOfBlockInfo -> EndOfBlockInfo
reserveSeqFrame (EndOfBlockInfo args_sp (CaseAlts amode stuff))
- = EndOfBlockInfo (args_sp + seq_frame_size) (SeqFrame 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 - seq_frame_size)
+ returnFC (args_sp - seqFrameSize)
\end{code}
_exports_
CgUsages getSpRelOffset;
_declarations_
-1 getSpRelOffset _:_ AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;;
+1 getSpRelOffset _:_ AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.CAddrMode ;;
gencode (CInitHdr cl_info reg_rel _)
= let
- lhs = a2stix (CVal reg_rel PtrRep)
+ lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
\end{code}
amodeToStix (CAddr (NodeRel off))
= StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
+amodeToStix (CAddr (CIndex base off pk))
+ = StIndex pk (amodeToStix base) (amodeToStix off)
+
amodeToStix (CReg magic) = StReg (StixMagicId magic)
amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
amodeToStix (CLbl lbl _) = StCLbl lbl
-amodeToStix (CTableEntry base off pk)
- = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
-
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
amodeToStix (CIntLike x)
= panic "CIntLike"
- -- A CString is just a (CLit . MachStr)
-amodeToStix (CString s) = StString s
-
amodeToStix (CLit core)
= case core of
MachChar c -> StInt (toInteger (ord c))
projects / ghc-hetmet.git / commitdiff