From 5cd3527da623a25b9ace2995f9d2e7f6c90c611f Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 26 Sep 2001 15:11:51 +0000 Subject: [PATCH] [project @ 2001-09-26 15:11:50 by simonpj] ------------------------------- Code generation and SRT hygiene ------------------------------- This is a big tidy up commit. I don't think it breaks anything, but it certainly makes the code clearer (to me). I'm not certain that you can use it without sucking in my other big commit... they come from the same tree. Core-to-STG, live variables and Static Reference Tables (SRTs) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I did a big tidy-up of the live-variable computation in CoreToStg. The key idea is that the live variables consist of two parts: dynamic live vars static live vars (CAFs) These two always travel round together, but they were always treated separately by the code until now. Now it's a new data type: type LiveInfo = (StgLiveVars, -- Dynamic live variables; -- i.e. ones with a nested (non-top-level) binding CafSet) -- Static live variables; -- i.e. top-level variables that are CAFs or refer to them There's lots of documentation in CoreToStg. Code generation ~~~~~~~~~~~~~~~ Arising from this, I found that SRT labels were stored in a LambdaFormInfo during code generation, whereas they *ought* to be in the ClosureInfo (which in turn contains a LambdaFormInfo). This led to lots of changes in ClosureInfo, and I took the opportunity to make it into a labelled record. Similarly, I made the data type in AbstractC a bit more explicit: -- C_SRT is what StgSyn.SRT gets translated to... -- we add a label for the table, and expect only the 'offset/length' form data C_SRT = NoC_SRT | C_SRT CLabel !Int{-offset-} !Int{-length-} (Previously there were bottoms lying around.) --- ghc/compiler/absCSyn/AbsCSyn.lhs | 19 +- ghc/compiler/absCSyn/PprAbsC.lhs | 25 +- ghc/compiler/codeGen/CgCase.lhs | 20 +- ghc/compiler/codeGen/CgClosure.lhs | 18 +- ghc/compiler/codeGen/CgCon.lhs | 38 ++- ghc/compiler/codeGen/CgConTbls.lhs | 9 +- ghc/compiler/codeGen/CgExpr.lhs | 19 +- ghc/compiler/codeGen/CgLetNoEscape.lhs | 10 +- ghc/compiler/codeGen/CgMonad.lhs | 23 +- ghc/compiler/codeGen/ClosureInfo.lhs | 313 ++++++++++---------- ghc/compiler/codeGen/CodeGen.lhs | 12 +- ghc/compiler/nativeGen/MachCode.lhs | 4 +- ghc/compiler/nativeGen/StixInfo.lhs | 23 +- ghc/compiler/stgSyn/CoreToStg.lhs | 490 +++++++++++++++++--------------- 14 files changed, 517 insertions(+), 506 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 6863c3d..9aa589b 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.37 2001/07/24 05:04:58 ken Exp $ +% $Id: AbsCSyn.lhs,v 1.38 2001/09/26 15:11:50 simonpj Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -17,6 +17,7 @@ raw assembler/machine code. module AbsCSyn {- ( -- export everything AbstractC(..), + C_SRT(..) CStmtMacro(..), CExprMacro(..), CAddrMode(..), @@ -47,7 +48,7 @@ import Literal ( mkMachInt, Literal(..) ) import ForeignCall ( CCallSpec ) import PrimRep ( PrimRep(..) ) import Unique ( Unique ) -import StgSyn ( StgOp, SRT(..) ) +import StgSyn ( StgOp ) import TyCon ( TyCon ) import BitSet -- for liveness masks import FastTypes @@ -146,7 +147,7 @@ stored in a mixed type location.) | CRetDirect -- Direct return !Unique -- for making labels AbstractC -- return code - (CLabel,SRT) -- SRT info + C_SRT -- SRT info Liveness -- stack liveness at the return point -- see the notes about these next few; they follow below... @@ -193,7 +194,7 @@ stored in a mixed type location.) | CRetVector -- A labelled block of static data CLabel [CAddrMode] - (CLabel,SRT) -- SRT info + C_SRT -- SRT info Liveness -- stack liveness at the return point | CClosureTbl -- table of constructors for enumerated types @@ -214,6 +215,16 @@ stored in a mixed type location.) -- CostCentre.lhs) | CSplitMarker -- Split into separate object modules here + +-- C_SRT is what StgSyn.SRT gets translated to... +-- we add a label for the table, and expect only the 'offset/length' form + +data C_SRT = NoC_SRT + | C_SRT CLabel !Int{-offset-} !Int{-length-} + +needsSRT :: C_SRT -> Bool +needsSRT NoC_SRT = False +needsSRT (C_SRT _ _ _) = True \end{code} About @CMacroStmt@, etc.: notionally, they all just call some diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 2ce020e..2793d0f 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -53,7 +53,7 @@ import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) -import StgSyn ( SRT(..), StgOp(..) ) +import StgSyn ( StgOp(..) ) import BitSet ( BitSet, intBS ) import Outputable import GlaExts @@ -476,8 +476,11 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ is_constr = maybeToBool maybe_tag (Just tag) = maybe_tag - needs_srt = infoTblNeedsSRT cl_info - srt = getSRTInfo cl_info + srt = closureSRT cl_info + needs_srt = case srt of + NoC_SRT -> False + other -> True + size = closureNonHdrSize cl_info @@ -646,16 +649,12 @@ pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -pp_srt_info srt = - case srt of - (lbl, NoSRT) -> - hcat [ int 0, comma, - int 0, comma, - int 0, comma ] - (lbl, SRT off len) -> - hcat [ pprCLabel lbl, comma, - int off, comma, - int len, comma ] +pp_srt_info NoC_SRT = hcat [ int 0, comma, + int 0, comma, + int 0, comma ] +pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma, + int off, comma, + int len, comma ] \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index d9dc5c8..43147e5 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.52 2001/05/22 13:43:15 simonpj Exp $ +% $Id: CgCase.lhs,v 1.53 2001/09/26 15:11:50 simonpj Exp $ % %******************************************************** %* * @@ -402,8 +402,8 @@ cgEvalAlts cc_slot bndr srt alts [alt] -> let lbl = mkReturnInfoLabel uniq in cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c -> - getSRTLabel `thenFC` \srt_label -> - absC (CRetDirect uniq abs_c (srt_label, srt) + getSRTInfo srt `thenFC` \ srt_info -> + absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC` returnFC (CaseAlts (CLbl lbl RetRep) Nothing) _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type" @@ -442,9 +442,9 @@ cgEvalAlts cc_slot bndr srt alts getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c -> -- Generate the labelled block, starting with restore-cost-centre - getSRTLabel `thenFC` \srt_label -> + getSRTInfo srt `thenFC` \srt_info -> absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) - (srt_label,srt) liveness_mask) `thenC` + srt_info liveness_mask) `thenC` -- Return an amode for the block returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing) @@ -807,7 +807,7 @@ mkReturnVector :: Unique -> FCode CAddrMode mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv - = getSRTLabel `thenFC` \srt_label -> + = getSRTInfo srt `thenFC` \ srt_info -> let (return_vec_amode, vtbl_body) = case ret_conv of { @@ -815,7 +815,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv UnvectoredReturn 0 -> ASSERT(null tagged_alt_absCs) (CLbl ret_label RetRep, - absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness)); + absC (CRetDirect uniq deflt_absC srt_info liveness)); UnvectoredReturn n -> -- find the tag explicitly rather than using tag_reg for now. @@ -827,7 +827,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv (CLbl ret_label RetRep, absC (CRetDirect uniq (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC) - (srt_label, srt) + srt_info liveness)); VectoredReturn table_size -> @@ -835,9 +835,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv (vector_table, alts_absC) = unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)]) - ret_vector = CRetVector vtbl_label - vector_table - (srt_label, srt) liveness + ret_vector = CRetVector vtbl_label vector_table srt_info liveness in (CLbl vtbl_label DataPtrRep, -- alts come first, because we don't want to declare all the symbols diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 5cc5ed4..ea8f34c 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.48 2001/09/10 10:07:21 rje Exp $ +% $Id: CgClosure.lhs,v 1.49 2001/09/26 15:11:50 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -73,17 +73,19 @@ They should have no free variables. cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo + -> SRT -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info args body lf_info +cgTopRhsClosure id ccs binder_info srt args body lf_info = -- LAY OUT THE OBJECT + getSRTInfo srt `thenFC` \ srt_info -> let name = idName id - closure_info = layOutStaticNoFVClosure name lf_info + closure_info = layOutStaticNoFVClosure name lf_info srt_info closure_label = mkClosureLabel name cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info in @@ -147,7 +149,8 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload getArgAmodes payload `thenFC` \ amodes -> let (closure_info, amodes_w_offsets) - = layOutDynClosure (idName binder) getAmodeRep amodes lf_info + = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT + -- No SRT for a standard-form closure (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body in @@ -166,13 +169,14 @@ Here's the general case. cgRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo + -> SRT -> [Id] -- Free vars -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgRhsClosure binder cc binder_info fvs args body lf_info +cgRhsClosure binder cc binder_info srt fvs args body lf_info = ( -- LAY OUT THE OBJECT -- @@ -192,12 +196,14 @@ cgRhsClosure binder cc binder_info fvs args body lf_info else fvs in mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> + getSRTInfo srt `thenFC` \ srt_info -> let closure_info :: ClosureInfo bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)] (closure_info, bind_details) - = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info + = layOutDynClosure (idName binder) get_kind + fvs_w_amodes_and_info lf_info srt_info bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index aa2aec3..954dca8 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -38,9 +38,9 @@ import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall, mkUnboxedTupleReturnCode ) import CLabel ( mkClosureLabel ) -import ClosureInfo ( mkConLFInfo, mkLFArgument, - layOutDynCon, layOutDynClosure, - layOutStaticClosure, closureSize +import ClosureInfo ( mkConLFInfo, mkLFArgument, closureLFInfo, + layOutDynConstr, layOutDynClosure, + layOutStaticConstr, closureSize ) import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) @@ -71,19 +71,15 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS cgTopRhsCon id con args = ASSERT(not (isDllConApp con args)) -- checks for litlit args too ASSERT(length args == dataConRepArity con) - let - name = idName id - closure_label = mkClosureLabel name - lf_info = mkConLFInfo con - in - ( -- LAY IT OUT getArgAmodes args `thenFC` \ amodes -> let - (closure_info, amodes_w_offsets) - = layOutStaticClosure name getAmodeRep amodes lf_info + name = idName id + closure_label = mkClosureLabel name + lf_info = closureLFInfo closure_info + (closure_info, amodes_w_offsets) = layOutStaticConstr name con getAmodeRep amodes in -- BUILD THE OBJECT @@ -93,7 +89,7 @@ cgTopRhsCon id con args (mkCCostCentreStack dontCareCCS) -- because it's static data (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs - ) `thenC` + `thenC` -- RETURN returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info) @@ -186,7 +182,7 @@ buildDynCon binder ccs con args returnFC (heapIdInfo binder hp_off lf_info) where (closure_info, amodes_w_offsets) - = layOutDynClosure (idName binder) getAmodeRep args lf_info + = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT lf_info = mkConLFInfo con use_cc -- cost-centre to stick in the object @@ -220,7 +216,9 @@ bindConArgs con args mapCs bind_arg args_w_offsets where bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument - (_, args_w_offsets) = layOutDynCon con idPrimRep args + (_, args_w_offsets) = layOutDynConstr bogus_name con idPrimRep args + +bogus_name = panic "bindConArgs" \end{code} Unboxed tuples are handled slightly differently - the object is @@ -235,8 +233,8 @@ bindUnboxedTupleComponents bindUnboxedTupleComponents args = -- Assign as many components as possible to registers - let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args) - (reg_args, stk_args) = splitAt (length arg_regs) args + let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args) + (reg_args, stk_args) = splitAt (length arg_regs) args in -- Allocate the rest on the stack (ToDo: separate out pointers) @@ -338,11 +336,9 @@ cgReturnDataCon con amodes 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 + where + (closure_info, stuff) + = layOutDynConstr (dataConName con) con getAmodeRep amodes other_sequel -- The usual case diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 9c205cc..5a2b6be 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -13,9 +13,7 @@ import CgMonad import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import ClosureInfo ( layOutStaticClosure, layOutDynCon, - mkConLFInfo, ClosureInfo - ) +import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo ) import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon ) import Name ( getOccName ) import OccName ( occNameUserString ) @@ -114,8 +112,7 @@ genConInfo comp_info tycon data_con -- To allow the debuggers, interpreters, etc to cope with static -- data structures (ie those built at compile time), we take care that -- info-table contains the information we need. - (static_ci,_) = layOutStaticClosure con_name typePrimRep arg_tys - (mkConLFInfo data_con) + (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys body = (initC comp_info ( profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC` @@ -149,7 +146,7 @@ mkConCodeAndInfo con arg_tys = dataConRepArgTys con (closure_info, arg_things) - = layOutDynCon con typePrimRep arg_tys + = layOutDynConstr (dataConName con) con typePrimRep arg_tys body_code = -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index f4ad2a1..6905285 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.43 2001/05/22 13:43:15 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.44 2001/09/26 15:11:50 simonpj Exp $ % %******************************************************** %* * @@ -35,7 +35,7 @@ import CgTailCall ( cgTailCall, performReturn, performPrimReturn, tailCallPrimOp, returnUnboxedTuple ) import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, - mkApLFInfo, layOutDynCon ) + mkApLFInfo, layOutDynConstr ) import CostCentre ( sccAbleCostCentre, isSccCountCostCentre ) import Id ( idPrimRep, idType, Id ) import VarSet @@ -325,15 +325,14 @@ mkRhsClosure bndr cc bi srt cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where lf_info = mkSelectorLFInfo (idType bndr) offset_into_int - (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynCon con idPrimRep params + (isUpdatable upd_flag) + (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) + bogus_name = panic "mkRhsClosure" \end{code} - - Ap thunks ~~~~~~~~~ @@ -377,11 +376,9 @@ The default case ~~~~~~~~~~~~~~~~ \begin{code} mkRhsClosure bndr cc bi srt fvs upd_flag args body - = getSRTLabel `thenFC` \ srt_label -> - let lf_info = - mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt - in - cgRhsClosure bndr cc bi fvs args body lf_info + = cgRhsClosure bndr cc bi srt fvs args body lf_info + where + lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args \end{code} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 07cacd4..a5b0a20 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -% $Id: CgLetNoEscape.lhs,v 1.14 2000/07/11 16:03:37 simonmar Exp $ +% $Id: CgLetNoEscape.lhs,v 1.15 2001/09/26 15:11:50 simonpj Exp $ % %******************************************************** %* * @@ -170,12 +170,12 @@ cgLetNoEscapeClosure (allocStackTop retPrimRepSize `thenFC` \_ -> nukeDeadBindings full_live_in_rhss) - (deAllocStackTop retPrimRepSize `thenFC` \_ -> - buildContLivenessMask uniq `thenFC` \ liveness -> + (deAllocStackTop retPrimRepSize `thenFC` \_ -> + buildContLivenessMask uniq `thenFC` \ liveness -> forkAbsC (cgLetNoEscapeBody binder cc args body uniq) `thenFC` \ code -> - getSRTLabel `thenFC` \ srt_label -> - absC (CRetDirect uniq code (srt_label,srt) liveness) + getSRTInfo srt `thenFC` \ srt_info -> + absC (CRetDirect uniq code srt_info liveness) `thenC` returnFC ()) `thenFC` \ (vSp, _) -> diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index ac50b28..780db64 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $ +% $Id: CgMonad.lhs,v 1.30 2001/09/26 15:11:50 simonpj Exp $ % \section[CgMonad]{The code generation monad} @@ -23,7 +23,7 @@ module CgMonad ( EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, - setSRTLabel, getSRTLabel, + setSRTLabel, getSRTLabel, getSRTInfo, setTickyCtrLabel, getTickyCtrLabel, StackUsage, Slot(..), HeapUsage, @@ -53,6 +53,7 @@ import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) import {-# SOURCE #-} CgUsages ( getSpRelOffset ) import AbsCSyn +import StgSyn ( SRT(..) ) import AbsCUtils ( mkAbsCStmts ) import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling ) import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel ) @@ -615,15 +616,19 @@ getEndOfBlockInfo = do \end{code} \begin{code} -getSRTLabel :: FCode CLabel -getSRTLabel = do - (MkCgInfoDown _ _ srt _ _) <- getInfoDown - return srt +getSRTInfo :: SRT -> FCode C_SRT +getSRTInfo NoSRT = return NoC_SRT +getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel + return (C_SRT srt_lbl off len) + +getSRTLabel :: FCode CLabel -- Used only by cgPanic +getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown + return srt_lbl setSRTLabel :: CLabel -> Code -> Code -setSRTLabel srt code = do - (MkCgInfoDown c_info statics _ ticky eob_info) <- getInfoDown - withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info) +setSRTLabel srt_lbl code + = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown + withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info) \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 2801d45..6ba2ec0 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.47 2001/05/22 13:43:15 simonpj Exp $ +% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -23,8 +23,8 @@ module ClosureInfo ( closureGoodStuffSize, closurePtrsSize, slopSize, - layOutDynClosure, layOutDynCon, layOutStaticClosure, - layOutStaticNoFVClosure, + layOutDynClosure, layOutDynConstr, layOutStaticClosure, + layOutStaticNoFVClosure, layOutStaticConstr, mkVirtHeapOffsets, nodeMustPointToIt, getEntryConvention, @@ -36,7 +36,7 @@ module ClosureInfo ( slowFunEntryCodeRequired, funInfoTableRequired, closureName, infoTableLabelFromCI, fastLabelFromCI, - closureLabelFromCI, + closureLabelFromCI, closureSRT, entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, closureSingleEntry, closureReEntrant, closureSemiTag, @@ -51,14 +51,12 @@ module ClosureInfo ( cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, maybeSelectorInfo, - infoTblNeedsSRT, staticClosureNeedsLink, - getSRTInfo ) where #include "HsVersions.h" -import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset ) +import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset, C_SRT(..), needsSRT ) import StgSyn import CgMonad @@ -95,22 +93,24 @@ import Util ( mapAccumL ) import Outputable \end{code} -The ``wrapper'' data type for closure information: - -\begin{code} -data ClosureInfo - = MkClosureInfo - Name -- The thing bound to this closure - LambdaFormInfo -- info derivable from the *source* - SMRep -- representation used by storage manager -\end{code} - %************************************************************************ %* * \subsection[ClosureInfo-datatypes]{Data types for closure information} %* * %************************************************************************ +The ``wrapper'' data type for closure information: + +\begin{code} +data ClosureInfo + = MkClosureInfo { + closureName :: Name, -- The thing bound to this closure + closureLFInfo :: LambdaFormInfo, -- Info derivable from the *source* + closureSMRep :: SMRep, -- representation used by storage manager + closureSRT :: C_SRT -- What SRT applies to this closure + } +\end{code} + %************************************************************************ %* * \subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info} @@ -124,8 +124,6 @@ data LambdaFormInfo TopLevelFlag -- True if top level !Int -- Arity !Bool -- True <=> no fvs - CLabel -- SRT label - SRT -- SRT info | LFCon -- Constructor DataCon -- The constructor @@ -141,8 +139,6 @@ data LambdaFormInfo !Bool -- True <=> no free vars Bool -- True <=> updatable (i.e., *not* single-entry) StandardFormInfo - CLabel -- SRT label - SRT -- SRT info | LFArgument -- Used for function arguments. We know nothing about -- this closure. Treat like updatable "LFThunk"... @@ -209,23 +205,20 @@ mkClosureLFInfo :: Id -- The binder -> [Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> CLabel -- SRT label - -> SRT -- SRT info -> LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args@(_:_) srt_label srt -- Non-empty args - = LFReEntrant (idType bndr) top (length args) (null fvs) srt_label srt +mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args + = LFReEntrant (idType bndr) top (length args) (null fvs) -mkClosureLFInfo bndr top fvs ReEntrant [] srt_label srt - = LFReEntrant (idType bndr) top 0 (null fvs) srt_label srt +mkClosureLFInfo bndr top fvs ReEntrant [] + = LFReEntrant (idType bndr) top 0 (null fvs) -mkClosureLFInfo bndr top fvs upd_flag [] srt_label srt +mkClosureLFInfo bndr top fvs upd_flag [] #ifdef DEBUG | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty) #endif | otherwise = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk - srt_label srt where ty = idType bndr \end{code} @@ -242,14 +235,10 @@ mkConLFInfo con mkSelectorLFInfo rhs_ty offset updatable = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset) - (error "mkSelectorLFInfo: no srt label") - (error "mkSelectorLFInfo: no srt") mkApLFInfo rhs_ty upd_flag arity - = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag) - (ApThunk arity) - (error "mkApLFInfo: no srt label") - (error "mkApLFInfo: no srt") + = LFThunk rhs_ty NotTopLevel (arity == 0) + (isUpdatable upd_flag) (ApThunk arity) \end{code} Miscellaneous LF-infos. @@ -262,8 +251,6 @@ mkLFImported :: Id -> LambdaFormInfo mkLFImported id = case idCgArity id of n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0 - (error "mkLFImported: no srt label") - (error "mkLFImported: no srt") other -> LFImported -- Not sure of exact arity \end{code} @@ -275,24 +262,30 @@ mkLFImported id \begin{code} closureSize :: ClosureInfo -> HeapOffset -closureSize cl_info@(MkClosureInfo _ _ sm_rep) - = fixedHdrSize + closureNonHdrSize cl_info +closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info closureNonHdrSize :: ClosureInfo -> Int -closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep) - = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) - --ToDo: pass lf_info? +closureNonHdrSize cl_info + = tot_wds + computeSlopSize tot_wds + (closureSMRep cl_info) + (closureUpdReqd cl_info) where tot_wds = closureGoodStuffSize cl_info +slopSize :: ClosureInfo -> Int +slopSize cl_info + = computeSlopSize (closureGoodStuffSize cl_info) + (closureSMRep cl_info) + (closureUpdReqd cl_info) + closureGoodStuffSize :: ClosureInfo -> Int -closureGoodStuffSize (MkClosureInfo _ _ sm_rep) - = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep +closureGoodStuffSize cl_info + = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info) in ptrs + nonptrs closurePtrsSize :: ClosureInfo -> Int -closurePtrsSize (MkClosureInfo _ _ sm_rep) - = let (ptrs, _) = sizes_from_SMRep sm_rep +closurePtrsSize cl_info + = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info) in ptrs -- not exported: @@ -330,10 +323,6 @@ Static closures have an extra ``static link field'' at the end, but we don't bother taking that into account here. \begin{code} -slopSize cl_info@(MkClosureInfo _ lf_info sm_rep) - = computeSlopSize (closureGoodStuffSize cl_info) sm_rep - (closureUpdReqd cl_info) - computeSlopSize :: Int -> SMRep -> Bool -> Int computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable @@ -361,11 +350,13 @@ layOutDynClosure, layOutStaticClosure -> (a -> PrimRep) -- how to get a PrimRep for the fields -> [a] -- the "things" being layed out -> LambdaFormInfo -- what sort of closure it is + -> C_SRT -> (ClosureInfo, -- info about the closure [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them -layOutDynClosure name kind_fn things lf_info - = (MkClosureInfo name lf_info sm_rep, +layOutDynClosure name kind_fn things lf_info srt_info + = (MkClosureInfo { closureName = name, closureLFInfo = lf_info, + closureSMRep = sm_rep, closureSRT = srt_info }, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds @@ -374,16 +365,20 @@ layOutDynClosure name kind_fn things lf_info sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds \end{code} -A wrapper for when used with data constructors: +Wrappers for when used with data constructors: \begin{code} -layOutDynCon :: DataCon - -> (a -> PrimRep) - -> [a] - -> (ClosureInfo, [(a,VirtualHeapOffset)]) +layOutDynConstr, layOutStaticConstr + :: Name -- Of the closure + -> DataCon + -> (a -> PrimRep) -> [a] + -> (ClosureInfo, [(a,VirtualHeapOffset)]) + +layOutDynConstr name data_con kind_fn args + = layOutDynClosure name kind_fn args (mkConLFInfo data_con) NoC_SRT -layOutDynCon con kind_fn args - = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con) +layOutStaticConstr name data_con kind_fn things + = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT \end{code} %************************************************************************ @@ -399,11 +394,13 @@ Static closures for functions are laid out using layOutStaticNoFVClosure. \begin{code} -layOutStaticClosure name kind_fn things lf_info - = (MkClosureInfo name lf_info - (GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type), +layOutStaticClosure name kind_fn things lf_info srt_info + = (MkClosureInfo { closureName = name, closureLFInfo = lf_info, + closureSMRep = rep, closureSRT = srt_info }, things_w_offsets) where + rep = GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type + (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds things_w_offsets) = mkVirtHeapOffsets kind_fn things @@ -414,10 +411,12 @@ layOutStaticClosure name kind_fn things lf_info closure_type = getClosureType is_static tot_wds ptr_wds lf_info is_static = True -layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo -layOutStaticNoFVClosure name lf_info - = MkClosureInfo name lf_info (GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)) +layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> C_SRT -> ClosureInfo +layOutStaticNoFVClosure name lf_info srt_info + = MkClosureInfo { closureName = name, closureLFInfo = lf_info, + closureSMRep = rep, closureSRT = srt_info } where + rep = GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info) is_static = True \end{code} @@ -459,13 +458,13 @@ getClosureType is_static tot_wds ptr_wds lf_info | specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n | otherwise -> CONSTR - LFReEntrant _ _ _ _ _ _ + LFReEntrant _ _ _ _ | specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n | otherwise -> FUN - LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR + LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR - LFThunk _ _ _ _ _ _ _ + LFThunk _ _ _ _ _ | specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n | otherwise -> THUNK @@ -525,7 +524,7 @@ nodeMustPointToIt :: LambdaFormInfo -> FCode Bool nodeMustPointToIt lf_info = case lf_info of - LFReEntrant ty top arity no_fvs _ _ -> returnFC ( + LFReEntrant ty top arity no_fvs -> returnFC ( not no_fvs || -- Certainly if it has fvs we need to point to it isNotTopLevel top -- If it is not top level we will point to it @@ -552,7 +551,7 @@ nodeMustPointToIt lf_info -- having Node point to the result of an update. SLPJ -- 27/11/92. - LFThunk _ _ no_fvs updatable NonStandardThunk _ _ + LFThunk _ _ no_fvs updatable NonStandardThunk -> returnFC (updatable || not no_fvs || opt_SccProfilingOn) -- For the non-updatable (single-entry case): @@ -562,7 +561,7 @@ nodeMustPointToIt lf_info -- or profiling (in which case we need to recover the cost centre -- from inside it) - LFThunk _ _ no_fvs updatable some_standard_form_thunk _ _ + LFThunk _ _ no_fvs updatable some_standard_form_thunk -> returnFC True -- Node must point to any standard-form thunk. @@ -635,7 +634,7 @@ getEntryConvention name lf_info arg_kinds case lf_info of - LFReEntrant _ _ arity _ _ _ -> + LFReEntrant _ _ arity _ -> if arity == 0 || (length arg_kinds) < arity then StdEntry (mkStdEntryLabel name) else @@ -661,7 +660,7 @@ getEntryConvention name lf_info arg_kinds -- Should have no args (meaning what?) StdEntry (mkConEntryLabel (dataConName tup)) - LFThunk _ _ _ updatable std_form_info _ _ + LFThunk _ _ _ updatable std_form_info -> if updatable || opt_DoTickyProfiling -- to catch double entry || opt_SMP -- always enter via node on SMP, since the -- thunk might have been blackholed in the @@ -695,16 +694,15 @@ blackHoleOnEntry :: ClosureInfo -> Bool -- Single-entry ones have no fvs to plug, and we trust they don't form part -- of a loop. -blackHoleOnEntry (MkClosureInfo _ _ rep) - | isStaticRep rep - = False - -- Never black-hole a static closure +blackHoleOnEntry cl_info + | isStaticRep (closureSMRep cl_info) + = False -- Never black-hole a static closure -blackHoleOnEntry (MkClosureInfo _ lf_info _) - = case lf_info of - LFReEntrant _ _ _ _ _ _ -> False + | otherwise + = case closureLFInfo cl_info of + LFReEntrant _ _ _ _ -> False LFLetNoEscape _ -> False - LFThunk _ _ no_fvs updatable _ _ _ + LFThunk _ _ no_fvs updatable _ -> if updatable then not opt_OmitBlackHoling else opt_DoTickyProfiling || not no_fvs @@ -715,45 +713,36 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _) isStandardFormThunk :: LambdaFormInfo -> Bool -isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _) _ _) = True -isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _) _ _) = True -isStandardFormThunk other_lf_info = False +isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True +isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True +isStandardFormThunk other_lf_info = False -maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _ - (SelectorThunk offset) _ _) _) = Just offset +maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) }) + = Just offset maybeSelectorInfo _ = Nothing \end{code} ----------------------------------------------------------------------------- SRT-related stuff - \begin{code} -infoTblNeedsSRT :: ClosureInfo -> Bool -infoTblNeedsSRT (MkClosureInfo _ info _) = - case info of - LFThunk _ _ _ _ _ _ NoSRT -> False - LFThunk _ _ _ _ _ _ _ -> True - - LFReEntrant _ _ _ _ _ NoSRT -> False - LFReEntrant _ _ _ _ _ _ -> True - - _ -> False - staticClosureNeedsLink :: ClosureInfo -> Bool -staticClosureNeedsLink (MkClosureInfo _ info _) = - case info of - LFThunk _ _ _ _ _ _ NoSRT -> False - LFReEntrant _ _ _ _ _ NoSRT -> False - LFCon _ True -> False -- zero arity constructors - _ -> True - -getSRTInfo :: ClosureInfo -> (CLabel, SRT) -getSRTInfo (MkClosureInfo _ info _) = - case info of - LFThunk _ _ _ _ _ lbl srt -> (lbl,srt) - LFReEntrant _ _ _ _ lbl srt -> (lbl,srt) - _ -> panic "getSRTInfo" +-- A static closure needs a link field to aid the GC when traversing +-- the static closure graph. But it only needs such a field if either +-- a) it has an SRT +-- b) it's a non-nullary constructor +-- In case (b), the constructor's fields themselves play the role +-- of the SRT. +staticClosureNeedsLink (MkClosureInfo { closureName = name, closureSRT = srt, closureLFInfo = info }) + = needsSRT srt || constructor_srt + where + constructor_srt + = case info of + LFThunk _ _ _ _ _ -> False + LFReEntrant _ _ _ _ -> False + LFCon _ is_nullary -> not is_nullary + LFTuple _ is_nullary -> not is_nullary + other -> pprPanic "staticClosureNeedsLink" (ppr name) \end{code} Avoiding generating entries and info tables @@ -824,7 +813,7 @@ staticClosureRequired -> LambdaFormInfo -> Bool staticClosureRequired binder bndr_info - (LFReEntrant _ top_level _ _ _ _) -- It's a function + (LFReEntrant _ top_level _ _) -- It's a function = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding not (satCallsOnly bndr_info) @@ -847,7 +836,7 @@ funInfoTableRequired -> StgBinderInfo -> LambdaFormInfo -> Bool -funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _) +funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _) = isNotTopLevel top_level || not (satCallsOnly bndr_info) @@ -863,36 +852,27 @@ funInfoTableRequired other_binder_info binder other_lf_info = True \begin{code} isStaticClosure :: ClosureInfo -> Bool -isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep - -closureName :: ClosureInfo -> Name -closureName (MkClosureInfo name _ _) = name - -closureSMRep :: ClosureInfo -> SMRep -closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep - -closureLFInfo :: ClosureInfo -> LambdaFormInfo -closureLFInfo (MkClosureInfo _ lf_info _) = lf_info +isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd -closureUpdReqd (MkClosureInfo _ (LFBlackHole _) _) = True +closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd +closureUpdReqd (MkClosureInfo { closureLFInfo = LFBlackHole _ }) = True -- Black-hole closures are allocated to receive the results of an -- alg case with a named default... so they need to be updated. -closureUpdReqd other_closure = False +closureUpdReqd other_closure = False closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd -closureSingleEntry other_closure = False +closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd +closureSingleEntry other_closure = False closureReEntrant :: ClosureInfo -> Bool -closureReEntrant (MkClosureInfo _ (LFReEntrant _ _ _ _ _ _) _) = True +closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant other_closure = False \end{code} \begin{code} closureSemiTag :: ClosureInfo -> Maybe Int -closureSemiTag (MkClosureInfo _ lf_info _) +closureSemiTag (MkClosureInfo { closureLFInfo = lf_info }) = case lf_info of LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG) LFTuple _ _ -> Just 0 @@ -902,10 +882,10 @@ closureSemiTag (MkClosureInfo _ lf_info _) \begin{code} isToplevClosure :: ClosureInfo -> Bool -isToplevClosure (MkClosureInfo _ lf_info _) +isToplevClosure (MkClosureInfo { closureLFInfo = lf_info }) = case lf_info of - LFReEntrant _ TopLevel _ _ _ _ -> True - LFThunk _ TopLevel _ _ _ _ _ -> True + LFReEntrant _ TopLevel _ _ -> True + LFThunk _ TopLevel _ _ _ -> True other -> False \end{code} @@ -913,24 +893,24 @@ Label generation. \begin{code} fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _) +fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ }) = mkFastEntryLabel name arity -fastLabelFromCI (MkClosureInfo name _ _) - = pprPanic "fastLabelFromCI" (ppr name) +fastLabelFromCI cl_info + = pprPanic "fastLabelFromCI" (ppr (closureName cl_info)) infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI (MkClosureInfo id lf_info rep) +infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep }) = case lf_info of LFCon con _ -> mkConInfoPtr con rep LFTuple tup _ -> mkConInfoPtr tup rep LFBlackHole info -> info - LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ -> + LFThunk _ _ _ upd_flag (SelectorThunk offset) -> mkSelectorInfoLabel upd_flag offset - LFThunk _ _ _ upd_flag (ApThunk arity) _ _ -> + LFThunk _ _ _ upd_flag (ApThunk arity) -> mkApInfoTableLabel upd_flag arity other -> {-NO: if isStaticRep rep @@ -949,12 +929,12 @@ mkConEntryPtr con rep | isStaticRep rep = mkStaticConEntryLabel (dataConName con) | otherwise = mkConEntryLabel (dataConName con) -closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id +closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info) entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI (MkClosureInfo id lf_info rep) +entryLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep }) = case lf_info of - LFThunk _ _ _ upd_flag std_form_info _ _ -> thunkEntryLabel id std_form_info upd_flag + LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag LFCon con _ -> mkConEntryPtr con rep LFTuple tup _ -> mkConEntryPtr tup rep other -> mkStdEntryLabel id @@ -973,15 +953,15 @@ thunkEntryLabel thunk_id _ is_updatable \begin{code} allocProfilingMsg :: ClosureInfo -> FAST_STRING -allocProfilingMsg (MkClosureInfo _ lf_info _) - = case lf_info of - LFReEntrant _ _ _ _ _ _ -> SLIT("TICK_ALLOC_FUN") - LFCon _ _ -> SLIT("TICK_ALLOC_CON") - LFTuple _ _ -> SLIT("TICK_ALLOC_CON") - LFThunk _ _ _ True _ _ _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable - LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable - LFBlackHole _ -> SLIT("TICK_ALLOC_BH") - LFImported -> panic "TICK_ALLOC_IMP" +allocProfilingMsg cl_info + = case closureLFInfo cl_info of + LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN") + LFCon _ _ -> SLIT("TICK_ALLOC_CON") + LFTuple _ _ -> SLIT("TICK_ALLOC_CON") + LFThunk _ _ _ True _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable + LFThunk _ _ _ False _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable + LFBlackHole _ -> SLIT("TICK_ALLOC_BH") + LFImported -> panic "TICK_ALLOC_IMP" \end{code} We need a black-hole closure info to pass to @allocDynClosure@ when we @@ -990,11 +970,17 @@ ways to build an LFBlackHole, maintaining the invariant that it really is a black hole and not something else. \begin{code} -cafBlackHoleClosureInfo (MkClosureInfo name _ _) - = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep - -seCafBlackHoleClosureInfo (MkClosureInfo name _ _) - = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep +cafBlackHoleClosureInfo cl_info + = MkClosureInfo { closureName = closureName cl_info, + closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, + closureSMRep = BlackHoleRep, + closureSRT = NoC_SRT } + +seCafBlackHoleClosureInfo cl_info + = MkClosureInfo { closureName = closureName cl_info, + closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel, + closureSMRep = BlackHoleRep, + closureSRT = NoC_SRT } \end{code} %************************************************************************ @@ -1014,13 +1000,10 @@ in the closure info using @closureTypeDescr@. \begin{code} closureTypeDescr :: ClosureInfo -> String -closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _ _ _) _) - = getTyDescription ty -closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _ _ _) _) - = getTyDescription ty -closureTypeDescr (MkClosureInfo name (LFCon data_con _) _) - = occNameUserString (getOccName (dataConTyCon data_con)) -closureTypeDescr (MkClosureInfo name lf _) - = showSDoc (ppr name) +closureTypeDescr cl_info + = case closureLFInfo cl_info of + LFThunk ty _ _ _ _ -> getTyDescription ty + LFReEntrant ty _ _ _ -> getTyDescription ty + LFCon data_con _ -> occNameUserString (getOccName (dataConTyCon data_con)) + other -> showSDoc (ppr (closureName cl_info)) \end{code} - diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 2b15e21..d6b5d0f 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -50,8 +50,6 @@ import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) #ifdef DEBUG -import Id ( idCafInfo ) -import IdInfo ( mayHaveCafRefs ) import Outputable #endif \end{code} @@ -266,11 +264,9 @@ cgTopRhs bndr (StgRhsCon cc con args) srt cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt = -- There should be no free variables ASSERT(null fvs) - - getSRTLabel `thenFC` \srt_label -> - let lf_info = - mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt + let + lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args in - maybeGlobaliseId bndr `thenFC` \ bndr' -> - forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info) + maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info) \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 9117e78..1bed8e0 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -20,8 +20,8 @@ import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) import AbsCUtils ( magicIdPrimRep ) import ForeignCall ( CCallConv(..) ) -import CLabel ( isAsmTemp, CLabel, labelDynamic ) -import Maybes ( maybeToBool, expectJust ) +import CLabel ( CLabel, labelDynamic ) +import Maybes ( maybeToBool ) import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) import Stix ( getNatLabelNCG, StixTree(..), diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index fa1c07d..c23306f 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -15,13 +15,13 @@ module StixInfo ( #include "../includes/config.h" #include "NCG.h" -import AbsCSyn ( AbstractC(..), Liveness(..) ) +import AbsCSyn ( AbstractC(..), Liveness(..), C_SRT(..), needsSRT ) import CLabel ( CLabel ) import StgSyn ( SRT(..) ) import ClosureInfo ( closurePtrsSize, closureNonHdrSize, closureSMRep, infoTableLabelFromCI, - infoTblNeedsSRT, getSRTInfo, closureSemiTag + closureSRT, closureSemiTag ) import PrimRep ( PrimRep(..) ) import SMRep ( getSMRepClosureTypeInt ) @@ -50,7 +50,6 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) where info_lbl = infoTableLabelFromCI cl_info - needs_srt = infoTblNeedsSRT cl_info table | needs_srt = srt_label : rest_of_table | otherwise = rest_of_table @@ -72,18 +71,16 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) type_info = (fromInt closure_type) .|. (fromInt srt_len `shiftL` 16) #endif - srt = getSRTInfo cl_info + srt = closureSRT cl_info + needs_srt = needsSRT srt (srt_label,srt_len) | is_constr = (StInt 0, tag) - | needs_srt - = case srt of - (lbl, SRT off len) -> - (StIndex DataPtrRep (StCLbl lbl) - (StInt (toInteger off)), len) | otherwise - = (StInt 0, 0) + = case srt of + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len) maybe_tag = closureSemiTag cl_info is_constr = maybeToBool maybe_tag @@ -107,7 +104,7 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) genBitmapInfoTable :: Liveness - -> (CLabel, SRT) + -> C_SRT -> Int -> Bool -- must include SRT field (i.e. it's a vector) -> UniqSM StixTreeList @@ -146,8 +143,8 @@ genBitmapInfoTable liveness srt closure_type include_srt (srt_label,srt_len) = case srt of - (lbl, NoSRT) -> (StInt 0, 0) - (lbl, SRT off len) -> + NoC_SRT -> (StInt 0, 0) + C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 0537644..3df5a82 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -35,8 +35,6 @@ import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) import FastTypes hiding ( fastOr ) import Outputable -import List ( partition ) - infixr 9 `thenLne` \end{code} @@ -116,6 +114,25 @@ The later SRT pass takes these lists of Ids and uses them to construct the actual nested SRTs, and replaces the lists of Ids with (offset,length) pairs. + +Interaction of let-no-escape with SRTs [Sept 01] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + let-no-escape x = ...caf1...caf2... + in + ...x...x...x... + +where caf1,caf2 are CAFs. Since x doesn't have a closure, we +build SRTs just as if x's defn was inlined at each call site, and +that means that x's CAF refs get duplicated in the overall SRT. + +This is unlike ordinary lets, in which the CAF refs are not duplicated. + +We could fix this loss of (static) sharing by making a sort of pseudo-closure +for x, solely to put in the SRTs lower down. + + %************************************************************************ %* * \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} @@ -155,22 +172,18 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let - caf_info = hasCafRefs env rhs - - env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs)) - - how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs - | otherwise = TopLevelNoCafs + caf_info = hasCafRefs env rhs + env' = extendVarEnv env id how_bound + how_bound = LetBound (TopLet caf_info) (predictArity rhs) - (stg_rhs, fvs', cafs) = + (stg_rhs, fvs', lv_info) = initLne env ( - coreToStgRhs body_fvs TopLevel (id,rhs) - `thenLne` \ (stg_rhs, fvs', _) -> - freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> - returnLne (stg_rhs, fvs', cafs) + coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) -> + freeVarsToLiveVars fvs' `thenLne` \ lv_info -> + returnLne (stg_rhs, fvs', lv_info) ) - bind = StgNonRec (SRTEntries cafs) id stg_rhs + bind = StgNonRec (mkSRT lv_info) id stg_rhs in ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistent caf_info bind, ppr id) @@ -181,31 +194,28 @@ coreTopBindToStg env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - -- to calculate caf_info, we initially map all the binders to - -- TopLevelNoCafs. + -- To calculate caf_info, we initially map + -- all the binders to NoCafRefs env1 = extendVarEnvList env - [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity")) + [ (b, LetBound (TopLet NoCafRefs) (error "no arity")) | b <- binders ] caf_info = hasCafRefss env1{-NB: not env'-} rhss env' = extendVarEnvList env - [ (b, LetBound how_bound emptyLVS (predictArity rhs)) + [ (b, LetBound (TopLet caf_info) (predictArity rhs)) | (b,rhs) <- pairs ] - how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs - | otherwise = TopLevelNoCafs - - (stg_rhss, fvs', cafs) + (stg_rhss, fvs', lv_info) = initLne env' ( mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs `thenLne` \ (stg_rhss, fvss', _) -> let fvs' = unionFVInfos fvss' in - freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> - returnLne (stg_rhss, fvs', cafs) + freeVarsToLiveVars fvs' `thenLne` \ lv_info -> + returnLne (stg_rhss, fvs', lv_info) ) - bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) + bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) in ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistent caf_info bind, ppr binders) @@ -328,15 +338,15 @@ coreToStgExpr expr@(App _ _) (f, args) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) - = let (args, body) = myCollectBinders expr + = let + (args, body) = myCollectBinders expr args' = filterStgBinders args in extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) -> let - set_of_args = mkVarSet args' fvs = args' `minusFVBinders` body_fvs - escs = body_escs `minusVarSet` set_of_args + escs = body_escs `delVarSetList` args' result_expr | null args' = body | otherwise = StgLam (exprType expr) args' body in @@ -349,109 +359,68 @@ coreToStgExpr (Note (SCC cc) expr) coreToStgExpr (Note other_note expr) = coreToStgExpr expr - -- Cases require a little more real work. coreToStgExpr (Case scrut bndr alts) - = extendVarEnvLne [(bndr, CaseBound)] $ - vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> - freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) -> + = extendVarEnvLne [(bndr, LambdaBound)] ( + mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> + returnLne ( mkStgAlts (idType bndr) alts2, + unionFVInfos fvs_s, + unionVarSets escs_s ) + ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> let - -- determine whether the default binder is dead or not + -- Determine whether the default binder is dead or not -- This helps the code generator to avoid generating an assignment -- for the case binder (is extremely rare cases) ToDo: remove. - bndr'= if (bndr `elementOfFVInfo` alts_fvs) - then bndr - else bndr `setIdOccInfo` IAmDead + bndr' | bndr `elementOfFVInfo` alts_fvs = bndr + | otherwise = bndr `setIdOccInfo` IAmDead -- Don't consider the default binder as being 'live in alts', -- since this is from the point of view of the case expr, where -- the default binder is not free. - live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr) + alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs + alts_escs_wo_bndr = alts_escs `delVarSet` bndr in - -- we tell the scrutinee that everything live in the alts - -- is live in it, too. - setVarsLiveInCont (live_in_alts,alts_caf_refs) ( + + freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info -> + + -- We tell the scrutinee that everything + -- live in the alts is live in it, too. + setVarsLiveInCont alts_lv_info ( coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> - freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) -> - returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs) + freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ) - `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) -> + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) -> - let srt = SRTEntries alts_caf_refs - in returnLne ( - StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2, - bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs), - (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs + StgCase scrut2 (getLiveVars scrut_lv_info) + (getLiveVars alts_lv_info) + bndr' + (mkSRT alts_lv_info) + alts2, + scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, + alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs -- You might think we should have scrut_escs, not -- (getFVSet scrut_fvs), but actually we can't call, and -- then return from, a let-no-escape thing. ) where - scrut_ty = idType bndr - prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - vars_alts (alts,deflt) - | prim_case - = mapAndUnzip3Lne vars_prim_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgPrimAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - | otherwise - = mapAndUnzip3Lne vars_alg_alt alts - `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> - let - alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionVarSets alts_escs_list - in - vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> - returnLne ( - mkStgAlgAlts scrut_ty alts2 deflt2, - alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionVarSet` deflt_escs - ) - - where - vars_prim_alt (LitAlt lit, _, rhs) - = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - returnLne ((lit, rhs2), rhs_fvs, rhs_escs) - - vars_alg_alt (DataAlt con, binders, rhs) - = let - -- remove type variables - binders' = filterStgBinders binders - in - extendVarEnvLne [(b, CaseBound) | b <- binders'] $ - coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - let - good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] - -- records whether each param is used in the RHS - in - returnLne ( - (con, binders', good_use_mask, rhs2), - binders' `minusFVBinders` rhs_fvs, - rhs_escs `minusVarSet` mkVarSet binders' - -- ToDo: remove the minusVarSet; - -- since escs won't include any of these binders - ) - vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other) - - vars_deflt Nothing - = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet) - - vars_deflt (Just rhs) - = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> - returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs) + vars_alt (con, binders, rhs) + = let -- Remove type variables + binders' = filterStgBinders binders + in + extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ + coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + -- Records whether each param is used in the RHS + good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] + in + returnLne ( (con, binders', good_use_mask, rhs2), + binders' `minusFVBinders` rhs_fvs, + rhs_escs `delVarSetList` binders' ) + -- ToDo: remove the delVarSet; + -- since escs won't include any of these binders \end{code} Lets not only take quite a bit of work, but this is where we convert @@ -468,21 +437,28 @@ coreToStgExpr (Let bind body) \end{code} \begin{code} -mkStgAlgAlts ty alts deflt - = case alts of - -- Get the tycon from the data con - (dc, _, _, _) : _rest - -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt - - -- Otherwise just do your best - [] -> case splitTyConApp_maybe (repType ty) of - Just (tc,_) | isAlgTyCon tc - -> StgAlgAlts (Just tc) alts deflt - other - -> StgAlgAlts Nothing alts deflt - -mkStgPrimAlts ty alts deflt - = StgPrimAlts (tyConAppTyCon ty) alts deflt +mkStgAlts scrut_ty orig_alts + | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt + | otherwise = StgAlgAlts maybe_tycon alg_alts deflt + where + is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) + + prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts] + alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts] + + (other_alts, deflt) + = case orig_alts of -- DEFAULT is always first if it's there at all + (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs) + other -> (orig_alts, StgNoDefault) + + maybe_tycon = case alg_alts of + -- Get the tycon from the data con + (dc, _, _, _) : _rest -> Just (dataConTyCon dc) + + -- Otherwise just do your best + [] -> case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isAlgTyCon tc -> Just tc + _other -> Nothing \end{code} @@ -522,9 +498,9 @@ coreToStgApp maybe_thunk_body f args -- let f = \ab -> e in f -- No point in having correct arity info for f! -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things f_arity = case how_bound of - LetBound _ _ arity -> arity - _ -> 0 + LetBound _ arity -> arity fun_occ | not_letrec_bound = noBinderInfo -- Uninteresting variable @@ -613,28 +589,27 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) -> + = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) -> -- Do the bindings, setting live_in_cont to empty if -- we ain't in a let-no-escape world getVarsLiveInCont `thenLne` \ live_in_cont -> setVarsLiveInCont (if let_no_escape then live_in_cont - else emptyLVS) + else emptyLiveInfo) (vars_bind rec_body_fvs bind) - `thenLne` \ ( bind2, bind_fvs, bind_escs - , bind_lvs, bind_cafs, env_ext) -> + `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) -> -- Do the body extendVarEnvLne env_ext ( coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> - freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) -> + freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, - body2, body_fvs, body_escs, body_lvs) + returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, + body2, body_fvs, body_escs, getLiveVars body_lv_info) ) - ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs, + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, body2, body_fvs, body_escs, body_lvs) -> @@ -647,7 +622,7 @@ coreToStgLet let_no_escape bind body = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) live_in_whole_let - = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders) + = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders) real_bind_escs = if let_no_escape then bind_escs @@ -655,7 +630,7 @@ coreToStgLet let_no_escape bind body getFVSet bind_fvs -- Everything escapes which is free in the bindings - let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders + let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of -- this let(rec) @@ -684,27 +659,21 @@ coreToStgLet let_no_escape bind body )) where set_of_binders = mkVarSet binders - binders = case bind of - NonRec binder rhs -> [binder] - Rec pairs -> map fst pairs + binders = bindersOf bind - mk_binding bind_lvs bind_cafs binder rhs - = (binder, LetBound NotTopLevelBound -- Not top level - live_vars (predictArity rhs) - ) + mk_binding bind_lv_info binder rhs + = (binder, LetBound (NestedLet live_vars) (predictArity rhs)) where - live_vars = if let_no_escape then - (extendVarSet bind_lvs binder, bind_cafs) - else - (unitVarSet binder, emptyVarSet) + live_vars | let_no_escape = addLiveVar bind_lv_info binder + | otherwise = unitLiveVar binder + -- c.f. the invariant on NestedLet vars_bind :: FreeVarsInfo -- Free var info for body of binding -> CoreBind -> LneM (StgBinding, FreeVarsInfo, EscVarsSet, -- free vars; escapee vars - StgLiveVars, -- vars live in binding - IdSet, -- CAFs live in binding + LiveInfo, -- Vars and CAFs live in binding [(Id, HowBound)]) -- extension to environment @@ -712,20 +681,20 @@ coreToStgLet let_no_escape bind body = coreToStgRhs body_fvs NotTopLevel (binder,rhs) `thenLne` \ (rhs2, bind_fvs, escs) -> - freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> + freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info -> let - env_ext_item = mk_binding bind_lvs bind_cafs binder rhs + env_ext_item = mk_binding bind_lv_info binder rhs in - returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2, - bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item]) + returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2, + bind_fvs, escs, bind_lv_info, [env_ext_item]) vars_bind body_fvs (Rec pairs) - = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) -> + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) -> let rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs binders = map fst pairs - env_ext = [ mk_binding bind_lvs bind_cafs b rhs + env_ext = [ mk_binding bind_lv_info b rhs | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( @@ -736,10 +705,10 @@ coreToStgLet let_no_escape bind body escs = unionVarSets escss in freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) - `thenLne` \ (bind_lvs, bind_cafs) -> + `thenLne` \ bind_lv_info -> - returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), - bind_fvs, escs, bind_lvs, bind_cafs, env_ext) + returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2), + bind_fvs, escs, bind_lv_info, env_ext) ) ) @@ -783,41 +752,90 @@ help. All the stuff here is only passed *down*. \begin{code} type LneM a = IdEnv HowBound - -> (StgLiveVars, -- vars live in continuation - IdSet) -- cafs live in continuation + -> LiveInfo -- Vars and CAFs live in continuation -> a +type LiveInfo = (StgLiveVars, -- Dynamic live variables; + -- i.e. ones with a nested (non-top-level) binding + CafSet) -- Static live variables; + -- i.e. top-level variables that are CAFs or refer to them + +type EscVarsSet = IdSet +type CafSet = IdSet + data HowBound = ImportBound -- Used only as a response to lookupBinding; never -- exists in the range of the (IdEnv HowBound) - | CaseBound - | LambdaBound - | LetBound - TopLevelCafInfo - (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below - Arity -- its arity (local Ids don't have arity info at this point) - -isLetBound (LetBound _ _ _) = True -isLetBound other = False + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + +data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live? + -- Invariant: the binder itself is always a member of + -- the dynamic set of its own LiveInfo + | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one? + +isLetBound (LetBound _ _) = True +isLetBound other = False + +topLevelBound ImportBound = True +topLevelBound (LetBound (TopLet _) _) = True +topLevelBound other = False \end{code} -For a let(rec)-bound variable, x, we record StgLiveVars, the set of -variables that are live if x is live. For "normal" variables that is -just x alone. If x is a let-no-escaped variable then x is represented -by a code pointer and a stack pointer (well, one for each stack). So -all of the variables needed in the execution of x are live if x is, -and are therefore recorded in the LetBound constructor; x itself -*is* included. +For a let(rec)-bound variable, x, we record LiveInfo, the set of +variables that are live if x is live. This LiveInfo comprises + (a) dynamic live variables (ones with a non-top-level binding) + (b) static live variabes (CAFs or things that refer to CAFs) -The set of live variables is guaranteed ot have no further let-no-escaped +For "normal" variables (a) is just x alone. If x is a let-no-escaped +variable then x is represented by a code pointer and a stack pointer +(well, one for each stack). So all of the variables needed in the +execution of x are live if x is, and are therefore recorded in the +LetBound constructor; x itself *is* included. + +The set of dynamic live variables is guaranteed ot have no further let-no-escaped variables in it. +\begin{code} +emptyLiveInfo :: LiveInfo +emptyLiveInfo = (emptyVarSet,emptyVarSet) + +unitLiveVar :: Id -> LiveInfo +unitLiveVar lv = (unitVarSet lv, emptyVarSet) + +unitLiveCaf :: Id -> LiveInfo +unitLiveCaf caf = (emptyVarSet, unitVarSet caf) + +addLiveVar :: LiveInfo -> Id -> LiveInfo +addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs) + +deleteLiveVar :: LiveInfo -> Id -> LiveInfo +deleteLiveVar (lvs, cafs) id = (lvs `delVarSet` id, cafs) + +unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo +unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2) + +unionLiveInfos :: [LiveInfo] -> LiveInfo +unionLiveInfos lvs = foldr unionLiveInfo emptyLiveInfo lvs + +mkSRT :: LiveInfo -> SRT +mkSRT (_, cafs) = SRTEntries cafs + +getLiveVars :: LiveInfo -> StgLiveVars +getLiveVars (lvs, _) = lvs +\end{code} + + The std monad functions: \begin{code} initLne :: IdEnv HowBound -> LneM a -> a -initLne env m = m env emptyLVS +initLne env m = m env emptyLiveInfo + -emptyLVS = (emptyVarSet,emptyVarSet) {-# INLINE thenLne #-} {-# INLINE returnLne #-} @@ -862,10 +880,10 @@ fixLne expr env lvs_cont Functions specific to this monad: \begin{code} -getVarsLiveInCont :: LneM (StgLiveVars, IdSet) +getVarsLiveInCont :: LneM LiveInfo getVarsLiveInCont env lvs_cont = lvs_cont -setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a +setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr env lvs_cont = expr env new_lvs_cont @@ -886,29 +904,25 @@ lookupBinding env v = case lookupVarEnv env v of -- only ever tacked onto a decorated expression. It is never used as -- the basis of a control decision, which might give a black hole. -freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet) +freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo freeVarsToLiveVars fvs env live_in_cont - = returnLne (lvs, cafs) env live_in_cont + = returnLne live_info env live_in_cont where - (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! - - (lvs_from_fvs, caf_from_fvs) = unzip (map do_one (allFreeIds fvs)) - - lvs = unionVarSets lvs_from_fvs `unionVarSet` lvs_cont - cafs = unionVarSets caf_from_fvs `unionVarSet` cafs_cont + live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs + lvs_from_fvs = map do_one (allFreeIds fvs) - do_one v - = case lookupBinding env v of - LetBound caf_ness (lvs,cafs) _ -> - case caf_ness of - TopLevelHasCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, unitVarSet v) - TopLevelNoCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, emptyVarSet) - NotTopLevelBound -> (extendVarSet lvs v, cafs) + do_one (v, how_bound) + = case how_bound of + ImportBound -> unitLiveCaf v -- Only CAF imports are + -- recorded in fvs + LetBound (TopLet caf_info) _ + | mayHaveCafRefs caf_info -> unitLiveCaf v + | otherwise -> emptyLiveInfo - ImportBound | mayHaveCafRefs (idCafInfo v) -> (emptyVarSet, unitVarSet v) - | otherwise -> (emptyVarSet, emptyVarSet) + LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v + -- (see the invariant on NestedLet) - _nested_binding -> (unitVarSet v, emptyVarSet) -- Bound by lambda or case + _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case \end{code} %************************************************************************ @@ -918,7 +932,18 @@ freeVarsToLiveVars fvs env live_in_cont %************************************************************************ \begin{code} -type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) +type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) + -- The Var is so we can gather up the free variables + -- as a set. + -- + -- The HowBound info just saves repeated lookups; + -- we look up just once when we encounter the occurrence. + -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids + -- Imported Ids without CAF refs are simply + -- not put in the FreeVarsInfo for an expression; + -- see singletonFVInfo + -- + -- StgBinderInfo -- If f is mapped to noBinderInfo, that means -- that f *is* mentioned (else it wouldn't be in the -- IdEnv at all), but perhaps in an unsaturated applications. @@ -929,14 +954,6 @@ type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo) -- -- For ILX we track free var info for type variables too; -- hence VarEnv not IdEnv - -data TopLevelCafInfo - = NotTopLevelBound - | TopLevelNoCafs - | TopLevelHasCafs - deriving Eq - -type EscVarsSet = IdSet \end{code} \begin{code} @@ -944,18 +961,17 @@ emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +-- Don't record non-CAF imports at all, to keep free-var sets small singletonFVInfo id ImportBound info - | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) | otherwise = emptyVarEnv -singletonFVInfo id (LetBound top_level _ _) info - = unitVarEnv id (id, top_level, info) -singletonFVInfo id other info - = unitVarEnv id (id, NotTopLevelBound, info) +singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) tyvarFVInfo :: TyVarSet -> FreeVarsInfo tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs where - add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo) + add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo) + -- Type variables must be lambda-bound unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -986,20 +1002,33 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only -allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id] +allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] --- Non-top-level things only, both type variables and ids (type variables --- only if opt_RuntimeTypes. +-- Non-top-level things only, both type variables and ids +-- (type variables only if opt_RuntimeTypes) getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs] +getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, + not (topLevelBound how_bound) ] getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) -plusFVInfo (id1,top1,info1) (id2,top2,info2) - = ASSERT (id1 == id2 && top1 == top2) - (id1, top1, combineStgBinderInfo info1 info2) +plusFVInfo (id1,hb1,info1) (id2,hb2,info2) + = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2) + (id1, hb1, combineStgBinderInfo info1 info2) + +#ifdef DEBUG +-- The HowBound info for a variable in the FVInfo should be consistent +check_eq_how_bound ImportBound ImportBound = True +check_eq_how_bound LambdaBound LambdaBound = True +check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2 +check_eq_how_bound hb1 hb2 = False + +check_eq_li (NestedLet _) (NestedLet _) = True +check_eq_li (TopLet _) (TopLet _) = True +check_eq_li li1 li2 = False +#endif \end{code} Misc. @@ -1082,19 +1111,16 @@ hasCafRefss p exprs cafRefs p (Var id) = case lookupVarEnv p id of - Just (LetBound TopLevelHasCafs _ _) -> fastBool True -- Top level - Just (LetBound TopLevelNoCafs _ _) -> fastBool False -- Top level - Nothing | isLocalId id -> fastBool False -- Nested binder - | otherwise -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported - Just _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env - + Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info) + Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported + | otherwise -> fastBool False -- Nested binder + _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env cafRefs p (Lit l) = fastBool False cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a cafRefs p (Lam x e) = cafRefs p e cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e -cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) - (cafRefss p) (rhssOfAlts alts) +cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) cafRefs p (Note n e) = cafRefs p e cafRefs p (Type t) = fastBool False -- 1.7.10.4