From a5f7799965947977599a777dae10f103f9b9fd1a Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 24 Jun 1999 13:04:23 +0000 Subject: [PATCH] [project @ 1999-06-24 13:04:13 by simonmar] - Implement update-in-place in certain very specialised circumstances - Clean up abstract C a bit - Speed up pretty-printing absC a bit. --- ghc/compiler/absCSyn/AbsCSyn.lhs | 25 +++++----- ghc/compiler/absCSyn/AbsCUtils.lhs | 4 -- ghc/compiler/absCSyn/Costs.lhs | 14 +----- ghc/compiler/absCSyn/PprAbsC.lhs | 85 ++++++++++++++++++++++---------- ghc/compiler/codeGen/CgCase.lhs | 4 +- ghc/compiler/codeGen/CgClosure.lhs | 18 +++---- ghc/compiler/codeGen/CgCon.lhs | 80 +++++++++++++++++++++--------- ghc/compiler/codeGen/CgExpr.lhs | 10 ++-- ghc/compiler/codeGen/CgHeapery.lhs | 39 +++++++++++++-- ghc/compiler/codeGen/CgStackery.lhs | 15 +++++- ghc/compiler/codeGen/CgUpdate.lhs | 21 +++----- ghc/compiler/codeGen/CgUsages.hi-boot | 2 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 4 +- ghc/compiler/nativeGen/StixPrim.lhs | 9 ++-- 14 files changed, 203 insertions(+), 127 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index d88a523..90f678d 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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} @@ -47,7 +47,7 @@ import CLabel 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 ) @@ -114,7 +114,7 @@ stored in a mixed type location.) | 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-}) @@ -232,13 +232,13 @@ data CStmtMacro | 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. @@ -265,7 +265,6 @@ data CCheckMacro | HP_CHK_UT_ALT -- unboxed tuple return. | HP_CHK_GEN -- generic heap check - deriving Text \end{code} \item[@CCallProfCtrMacro@:] @@ -300,11 +299,6 @@ data CAddrMode | 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. @@ -320,8 +314,8 @@ data CAddrMode -- 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 @@ -348,7 +342,7 @@ data CExprMacro = ENTRY_CODE | ARG_TAG -- stack argument tagging | GET_TAG -- get current constructor tag - deriving(Text) + | UPD_FRAME_UPDATEE \end{code} @@ -358,6 +352,9 @@ Convenience functions: 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 @@ -376,6 +373,8 @@ data RegRelative = 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 @@ -400,7 +399,7 @@ nodeRel IBOX(off) = NodeRel off %************************************************************************ %* * -\subsection[RegRelative]{@RegRelatives@: ???} +\subsection[Liveness]{Liveness Masks} %* * %************************************************************************ diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 072be07..029c7c7 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -155,14 +155,10 @@ getAmodeRep (CTemp uniq kind) = kind 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'' diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 3588fe5..b6d955c 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -117,7 +117,7 @@ costs absC = CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0) - CAssign (CReg _) (CAddr _) -> Cost (1,0,0,0,0) -- typ.: add %reg1,,%reg2 + CAssign (CReg _) source_m -> addrModeCosts source_m Rhs CAssign target_m source_m -> addrModeCosts target_m Lhs + addrModeCosts source_m Rhs @@ -242,16 +242,9 @@ addrModeCosts addr_mode side = 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) -} @@ -272,9 +265,6 @@ addrModeCosts addr_mode side = 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 @@ -326,7 +316,7 @@ stmtMacroCosts macro modes = 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 -- --------------------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index cd63474..f65ab5c 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -147,7 +147,7 @@ pprAbsC (CReturn am return_info) c 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 */") @@ -271,12 +271,12 @@ pprAbsC (CSimultaneous abs_c) c = 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, @@ -338,9 +338,9 @@ pprAbsC (CCodeBlock label abs_C) _ } -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 ] @@ -1036,13 +1036,13 @@ pprAssign Word64Rep dest@(CVal reg_rel _) src 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)) @@ -1144,9 +1144,6 @@ ppr_amode (CCharLike ch) 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 @@ -1154,17 +1151,50 @@ 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} @@ -1223,6 +1253,11 @@ pprRegRelative sign_wanted (NodeRel o) 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 @@ -1491,10 +1526,11 @@ ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes \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) @@ -1522,11 +1558,6 @@ ppr_decls_Amode (CLbl label kind) 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 diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 9eb6b22..c4afa17 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -154,7 +154,7 @@ cgCase (StgCon (PrimOp op) args res_ty) 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 { diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 8646051..e04a4c2 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (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} @@ -372,21 +372,17 @@ closureCodeBody binder_info closure_info cc all_args body 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. @@ -638,13 +634,13 @@ setupUpdate closure_info code 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 diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 6be1371..84f6808 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -26,18 +26,21 @@ import CgBindery ( getArgAmodes, bindNewToNode, 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 ) @@ -49,7 +52,8 @@ import Name ( nameModule, isLocallyDefinedName ) 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} @@ -286,7 +290,7 @@ cgReturnDataCon con amodes all_zero_size_args 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 @@ -299,27 +303,57 @@ cgReturnDataCon con amodes all_zero_size_args -- 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 -> diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index fc96eb3..e12979d 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -133,9 +133,9 @@ cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty) 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 @@ -177,9 +177,9 @@ cgExpr x@(StgCon (PrimOp op) args res_ty) -- 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} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 80d968f..1663846 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,14 +1,14 @@ % % (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 @@ -468,11 +468,42 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets 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} diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index a5479fe..d97476e 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (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} @@ -13,7 +13,8 @@ module CgStackery ( allocStack, allocPrimStack, allocStackTop, deAllocStackTop, adjustStackHW, getFinalStackHW, mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts, - freeStackSlots, dataStackSlots, addFreeSlots + freeStackSlots, dataStackSlots, addFreeSlots, + updateFrameSize, seqFrameSize ) where #include "HsVersions.h" @@ -24,7 +25,10 @@ import AbsCSyn 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} @@ -219,6 +223,13 @@ getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1 (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} %************************************************************************ %* * diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs index 621e480..82a0800 100644 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -11,9 +11,8 @@ module CgUpdate ( pushUpdateFrame, reserveSeqFrame, pushSeqFrame ) where 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 ) @@ -38,20 +37,15 @@ to reflect the frame pushed. 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) ( @@ -76,16 +70,13 @@ args_sp. When the scrutinee comes around to pushing a return address, 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} diff --git a/ghc/compiler/codeGen/CgUsages.hi-boot b/ghc/compiler/codeGen/CgUsages.hi-boot index db5fc01..0a4b9c1 100644 --- a/ghc/compiler/codeGen/CgUsages.hi-boot +++ b/ghc/compiler/codeGen/CgUsages.hi-boot @@ -2,4 +2,4 @@ _interface_ CgUsages 1 _exports_ CgUsages getSpRelOffset; _declarations_ -1 getSpRelOffset _:_ AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;; +1 getSpRelOffset _:_ AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.CAddrMode ;; diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 1588f3c..e4c1968 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -243,10 +243,10 @@ addresses, etc.) 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} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 3579ca1..9f01488 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -314,14 +314,14 @@ amodeToStix (CAddr (HpRel off)) 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))) @@ -342,9 +342,6 @@ amodeToStix (CIntLike (CLit (MachInt i _))) 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)) -- 1.7.10.4