From: simonmar Date: Wed, 6 Dec 2000 13:19:49 +0000 (+0000) Subject: [project @ 2000-12-06 13:19:49 by simonmar] X-Git-Tag: Approximately_9120_patches~3196 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b5a7f58434f9e79c54707d9036122ceaeacf4a63;p=ghc-hetmet.git [project @ 2000-12-06 13:19:49 by simonmar] Re-engineer the transition from Core to STG syntax. Main changes in this commit: - a new pass, CoreSat, handles saturation of constructors and PrimOps, and puts the syntax into STG-like normal form (applications to atoms only, etc), modulo type applications and Notes. - CoreToStg is now done at the same time as StgVarInfo. Most of the contents of StgVarInfo.lhs have been copied into CoreToStg.lhs and some simplifications made. less major changes: - globalisation of names for the purposes of object splitting is now done by the C code generator (which is the Right Place in principle, but it was a bit fiddly). - CoreTidy now does cloning of local binders and collection of arity info. The IdInfo from CoreTidy is now *almost* the final IdInfo we put in the interface file, except for CafInfo. I'm going to move the CafInfo collection into CoreTidy in due course too. - and some other minor tidyups while I was in cluster-bomb commit mode. --- diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index efb4c80..7727c99 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -38,7 +38,7 @@ import CLabel ( mkClosureLabel, import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) import BitSet ( mkBS, emptyBS ) import PrimRep ( isFollowableRep, getPrimRepSize ) -import Id ( Id, idPrimRep, idType, isDataConWrapId ) +import Id ( Id, idPrimRep, idType ) import Type ( typePrimRep ) import VarEnv import VarSet ( varSetElems ) @@ -248,31 +248,19 @@ nukeVolatileBinds binds I {\em think} all looking-up is done through @getCAddrMode(s)@. \begin{code} -getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) +getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocalName name) || isDataConWrapId id - -- Why the isDataConWrapId? Because CoreToStg changes a call to - -- a nullary constructor worker fn to a call to its wrapper, - -- which may not be defined until later - - {- -- OLD: the unpack stuff isn't injected now Jan 2000 - Why the "isWiredInName"? - Imagine you are compiling PrelBase.hs (a module that - supplies some of the wired-in values). What can - happen is that the compiler will inject calls to - (e.g.) GHCbase.unpackPS, where-ever it likes -- it - assumes those values are ubiquitously available. - The main point is: it may inject calls to them earlier - in GHCbase.hs than the actual definition... - -} - = returnFC (global_amode, mkLFImported id) + | not (isLocalName name) + = returnFC (id, global_amode, mkLFImported id) + -- deals with imported or locally defined but externally visible ids + -- (CoreTidy makes all these into global names). | otherwise = -- *might* be a nested defn: in any case, it's something whose -- definition we will know about... - lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> + lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) -> idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode -> - returnFC (amode, lf_info) + returnFC (id', amode, lf_info) where name = getName id global_amode = CLbl (mkClosureLabel name) kind @@ -280,7 +268,7 @@ getCAddrModeAndInfo id getCAddrMode :: Id -> FCode CAddrMode getCAddrMode name - = getCAddrModeAndInfo name `thenFC` \ (amode, _) -> + = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) -> returnFC amode \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 1d58b62..b6a438e 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.50 2000/11/15 14:37:08 simonpj Exp $ +% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $ % %******************************************************** %* * @@ -27,9 +27,8 @@ import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, import CgUpdate ( reserveSeqFrame ) import CgBindery ( getVolatileRegs, getArgAmodes, bindNewToReg, bindNewToTemp, - bindNewPrimToAmode, - rebindToStack, getCAddrMode, - getCAddrModeAndInfo, getCAddrModeIfVolatile, + bindNewPrimToAmode, getCAddrModeAndInfo, + rebindToStack, getCAddrMode, getCAddrModeIfVolatile, buildContLivenessMask, nukeDeadBindings, ) import CgCon ( bindConArgs, bindUnboxedTupleComponents ) @@ -252,13 +251,11 @@ we can reuse/trim the stack slot holding the variable (if it is in one). \begin{code} cgCase (StgApp fun args) - live_in_whole_case live_in_alts bndr srt alts -- @(StgAlgAlts _ _ _) - -- SLPJ: Surely PrimAlts is ok too? - = - getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> - getArgAmodes args `thenFC` \ arg_amodes -> + live_in_whole_case live_in_alts bndr srt alts + = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> + getArgAmodes args `thenFC` \ arg_amodes -> - -- Squish the environment + -- Squish the environment nukeDeadBindings live_in_alts `thenC` saveVolatileVarsAndRegs live_in_alts `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> @@ -271,7 +268,7 @@ cgCase (StgApp fun args) `thenFC` \ scrut_eob_info -> setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $ - tailCallFun fun fun_amode lf_info arg_amodes save_assts + tailCallFun fun' fun_amode lf_info arg_amodes save_assts \end{code} Note about return addresses: we *always* push a return address, even diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 5fba8c0..6f139b1 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.43 2000/11/06 08:15:21 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -45,14 +45,14 @@ import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel, import ClosureInfo -- lots and lots of stuff import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling ) import CostCentre -import Id ( Id, idName, idType, idPrimRep ) -import Name ( Name, isLocalName ) +import Id ( Id, idName, idType, idPrimRep, setIdName ) +import Name ( Name, isLocalName, globaliseName ) import Module ( Module, pprModule ) import ListSetOps ( minusList ) import PrimRep ( PrimRep(..) ) import PprType ( showTypeCategory ) import Util ( isIn ) -import CmdLineOpts ( opt_SccProfilingOn ) +import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC ) import Outputable import Name ( nameOccName ) @@ -79,9 +79,13 @@ cgTopRhsClosure :: Id -> FCode (Id, CgIdInfo) cgTopRhsClosure id ccs binder_info args body lf_info - = -- LAY OUT THE OBJECT + = + -- LAY OUT THE OBJECT let - closure_info = layOutStaticNoFVClosure name lf_info + name = idName id + closure_info = layOutStaticNoFVClosure name lf_info + closure_label = mkClosureLabel name + cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info in -- BUILD THE OBJECT (IF NECESSARY) @@ -113,10 +117,7 @@ cgTopRhsClosure id ccs binder_info args body lf_info ) `thenC` returnFC (id, cg_id_info) - where - name = idName id - closure_label = mkClosureLabel name - cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info + \end{code} %******************************************************** @@ -190,21 +191,19 @@ cgRhsClosure binder cc binder_info fvs args body lf_info then fvs `minusList` [binder] else fvs in - mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info -> + mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info -> let - fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info - closure_info :: ClosureInfo - bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)] + bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)] (closure_info, bind_details) = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info - bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info + bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info - amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details] + amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details] - get_kind (id, amode_and_info) = idPrimRep id + get_kind (id, _, _) = idPrimRep id in -- BUILD ITS INFO TABLE AND CODE forkClosureBody ( diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 5ad6264..9b22fcc 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -68,7 +68,14 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (Id, CgIdInfo) cgTopRhsCon id con args - = ASSERT(not dynamic_con_or_args) -- checks for litlit args too + = ASSERT(not (isDllConApp con args)) -- checks for litlit args too + let + name = idName id + closure_label = mkClosureLabel name + lf_info = mkConLFInfo con + cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info + in + ( -- LAY IT OUT getArgAmodes args `thenFC` \ amodes -> @@ -82,22 +89,13 @@ cgTopRhsCon id con args absC (CStaticClosure closure_label -- Labelled with the name on lhs of defn closure_info -- Closure is static - top_ccc + (mkCCostCentreStack dontCareCCS) -- because it's static data (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs ) `thenC` -- RETURN returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info) - where - lf_info = mkConLFInfo con - closure_label = mkClosureLabel name - name = idName id - - top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data - - -- stuff needed by the assert pred only. - dynamic_con_or_args = isDllConApp con args \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 9a96edb..06e7ff5 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.28 2000/11/06 08:15:21 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.29 2000/12/06 13:19:49 simonmar Exp $ % %******************************************************** %* * @@ -42,8 +42,7 @@ import CgUpdate ( pushSeqFrame ) import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel, mkBlackHoleInfoTableLabel ) import ClosureInfo ( nodeMustPointToIt, - getEntryConvention, EntryConvention(..), - LambdaFormInfo + getEntryConvention, EntryConvention(..), LambdaFormInfo ) import CmdLineOpts ( opt_DoSemiTagging ) import Id ( Id, idType, idName ) @@ -322,38 +321,33 @@ returnUnboxedTuple amodes before_jump \end{code} \begin{code} -performTailCall :: Id -- Function - -> [StgArg] -- Args - -> Code - +performTailCall :: Id -> [StgArg] -> Code performTailCall fun args - = -- Get all the info we have about the function and args and go on to - -- the business end - getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> - getArgAmodes args `thenFC` \ arg_amodes -> - - tailCallFun - fun fun_amode lf_info arg_amodes - AbsCNop {- No pending assignments -} - - --- generating code for a tail call to a function (or closure) - -tailCallFun :: Id -> CAddrMode -- Function and its amode - -> LambdaFormInfo -- Info about the function - -> [CAddrMode] -- Arguments + = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> + getArgAmodes args `thenFC` \ arg_amodes -> + tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -} +\end{code} - -> AbstractC -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack - -- assignments. +Generating code for a tail call to a function (or closure) +\begin{code} +tailCallFun + :: Id -- Function + -> CAddrMode + -> LambdaFormInfo + -> [CAddrMode] -- Arguments + -> AbstractC -- Pending simultaneous assignments + -- *** GUARANTEED to contain only stack + -- assignments. -- In ptic, we don't need to look in -- here to discover all live regs - - -> Code + -> Code tailCallFun fun fun_amode lf_info arg_amodes pending_assts = nodeMustPointToIt lf_info `thenFC` \ node_points -> + -- we use the name of fun', the Id from the environment, rather than + -- fun from the STG tree, in case it is a top-level name that we globalised + -- (see cgTopRhsClosure). getEntryConvention (idName fun) lf_info (map getAmodeRep arg_amodes) `thenFC` \ entry_conv -> let diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 6ccd79e..05a05b4 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.43 2000/07/14 08:14:53 simonpj Exp $ +% $Id: ClosureInfo.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -686,7 +686,7 @@ getEntryConvention name lf_info arg_kinds -> StdEntry (mkReturnPtLabel (nameUnique name)) LFLetNoEscape arity - -> ASSERT(arity == length arg_kinds) + -> if (arity /= length arg_kinds) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs where (arg_regs, _) = assignRegs [] arg_kinds diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 2390765..66373b2 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -31,7 +31,7 @@ import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, flattenAbsC ) -import CgBindery ( CgIdInfo, addBindC, addBindsC ) +import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) @@ -39,7 +39,8 @@ import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) import CostCentre ( CostCentre, CostCentreStack ) -import Id ( Id, idName ) +import Id ( Id, idName, setIdName ) +import Name ( globaliseName ) import Module ( Module ) import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, isDataTyCon ) @@ -70,11 +71,11 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders ; fl_uniqs <- mkSplitUniqSupply 'f' ; let datatype_stuff = genStaticConBits cinfo data_tycons - code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) + code_stuff = initC cinfo (mapCs cgTopBinding stg_binds) init_stuff = mkModuleInit fe_binders mod_name imported_modules cost_centre_info - abstractC = mkAbstractCs [ maybe_split, + abstractC = mkAbstractCs [ maybeSplitCode, init_stuff, code_stuff, datatype_stuff] @@ -90,9 +91,6 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders where data_tycons = filter isDataTyCon tycons - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop cinfo = MkCompInfo mod_name \end{code} @@ -174,7 +172,7 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs) %* * %************************************************************************ -@cgTopBindings@ is only used for top-level bindings, since they need +@cgTopBinding@ is only used for top-level bindings, since they need to be allocated statically (not in the heap) and need to be labelled. No unboxed bindings can happen at top level. @@ -185,37 +183,70 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code - -cgTopBindings split bindings = mapCs (cgTopBinding split) bindings - -cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code - -cgTopBinding split ((StgNonRec name rhs), srt) - = absC split `thenC` - absC (mkSRT srt_label srt) `thenC` +cgTopBinding :: (StgBinding,[Id]) -> Code +cgTopBinding (StgNonRec id rhs, srt) + = absC maybeSplitCode `thenC` + maybeGlobaliseId id `thenFC` \ id' -> + let + srt_label = mkSRTLabel (idName id') + in + mkSRT srt_label srt [] `thenC` setSRTLabel srt_label ( - cgTopRhs name rhs `thenFC` \ (name, info) -> - addBindC name info + cgTopRhs id' rhs `thenFC` \ (id, info) -> + addBindC id info ) - where - srt_label = mkSRTLabel (idName name) -cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt) - = absC split `thenC` - absC (mkSRT srt_label srt) `thenC` +cgTopBinding (StgRec pairs, srt) + = absC maybeSplitCode `thenC` + let + (bndrs, rhss) = unzip pairs + in + mapFCs maybeGlobaliseId bndrs `thenFC` \ bndrs'@(id:_) -> + let + srt_label = mkSRTLabel (idName id) + pairs' = zip bndrs' rhss + in + mkSRT srt_label srt bndrs' `thenC` setSRTLabel srt_label ( - fixC (\ new_binds -> addBindsC new_binds `thenC` - mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs - ) `thenFC` \ new_binds -> - addBindsC new_binds + fixC (\ new_binds -> + addBindsC new_binds `thenC` + mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' + ) `thenFC` \ new_binds -> nopC ) - where - srt_label = mkSRTLabel (idName name) -mkSRT :: CLabel -> [Id] -> AbstractC -mkSRT lbl [] = AbsCNop -mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids) +mkSRT :: CLabel -> [Id] -> [Id] -> Code +mkSRT lbl [] these = nopC +mkSRT lbl ids these + = mapFCs remap ids `thenFC` \ ids -> + absC (CSRT lbl (map (mkClosureLabel . idName) ids)) + where + -- sigh, better map all the ids against the environment in case they've + -- been globalised (see maybeGlobaliseId below). + remap id = case filter (==id) these of + [] -> getCAddrModeAndInfo id + `thenFC` \ (id, _, _) -> returnFC id + (id':_) -> returnFC id' + +-- if we're splitting the object, we need to globalise all the top-level names +-- (and then make sure we only use the globalised one in any C label we use +-- which refers to this name). +maybeGlobaliseId :: Id -> FCode Id +maybeGlobaliseId id + = moduleName `thenFC` \ mod -> + let + name = idName id + + -- globalise the name for -split-objs, if necessary + real_name | opt_EnsureSplittableC = globaliseName name mod + | otherwise = name + + id' = setIdName id real_name + in + returnFC id' + +maybeSplitCode + | opt_EnsureSplittableC = CSplitMarker + | otherwise = AbsCNop -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the @@ -225,7 +256,8 @@ cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... cgTopRhs bndr (StgRhsCon cc con args) - = forkStatics (cgTopRhsCon bndr con args) + = maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsCon bndr con args) cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables @@ -233,5 +265,6 @@ cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) let lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt in - forkStatics (cgTopRhsClosure bndr cc bi args body lf_info) + maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info) \end{code}