diff options
30 files changed, 1280 insertions, 1339 deletions
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index f53e85d906..cda2d5c310 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -48,7 +48,7 @@ module Id ( setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, - setIdCafInfo, + setIdCgInfo, setIdCprInfo, setIdOccInfo, @@ -59,7 +59,9 @@ module Id ( idWorkerInfo, idUnfolding, idSpecialisation, + idCgInfo, idCafInfo, + idCgArity, idCprInfo, idLBVarInfo, idOccInfo, @@ -97,7 +99,6 @@ import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, getNumBuiltinUniques ) -import Outputable infixl 1 `setIdUnfolding`, `setIdArityInfo`, @@ -132,7 +133,7 @@ mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc) (addFreeTyVars ty) - noCafIdInfo + vanillaIdInfo mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info @@ -140,7 +141,7 @@ mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) \begin{code} mkLocalId :: Name -> Type -> Id -mkLocalId name ty = mkLocalIdWithInfo name ty noCafIdInfo +mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... @@ -355,12 +356,23 @@ setIdSpecialisation :: Id -> CoreRules -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- + -- CG INFO +idCgInfo :: Id -> CgInfo +idCgInfo id = cgInfo (idInfo id) + +setIdCgInfo :: Id -> CgInfo -> Id +setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id + + --------------------------------- -- CAF INFO idCafInfo :: Id -> CafInfo -idCafInfo id = cafInfo (idInfo id) +idCafInfo id = cgCafInfo (idCgInfo id) + + --------------------------------- + -- CG ARITY -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id +idCgArity :: Id -> Arity +idCgArity id = cgArity (idCgInfo id) --------------------------------- -- CPR INFO diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index cde3737301..bef0d4a95f 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -11,7 +11,7 @@ module IdInfo ( GlobalIdDetails(..), notGlobalId, -- Not abstract IdInfo, -- Abstract - vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, noCafIdInfo, + vanillaIdInfo, noCafNoTyGenIdInfo, seqIdInfo, megaSeqIdInfo, -- Zapping @@ -57,8 +57,14 @@ module IdInfo ( -- Specialisation specInfo, setSpecInfo, + -- CG info + CgInfo(..), cgInfo, setCgInfo, cgMayHaveCafRefs, pprCgInfo, + cgArity, cgCafInfo, vanillaCgInfo, + CgInfoEnv, lookupCgInfo, + setCgArity, + -- CAF info - CafInfo(..), cafInfo, setCafInfo, mayHaveCafRefs, ppCafInfo, + CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs, -- Constructed Product Result Info CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, @@ -73,6 +79,8 @@ module IdInfo ( import CoreSyn import Type ( Type, usOnce ) import PrimOp ( PrimOp ) +import NameEnv ( NameEnv, lookupNameEnv ) +import Name ( Name ) import Var ( Id ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, InsideLam, insideLam, notInsideLam, @@ -96,8 +104,10 @@ infixl 1 `setDemandInfo`, `setCprInfo`, `setWorkerInfo`, `setLBVarInfo`, + `setOccInfo`, + `setCgInfo`, `setCafInfo`, - `setOccInfo` + `setCgArity` -- infixl so you can say (id `set` a `set` b) \end{code} @@ -168,7 +178,7 @@ data IdInfo strictnessInfo :: StrictnessInfo, -- Strictness properties workerInfo :: WorkerInfo, -- Pointer to Worker Function unfoldingInfo :: Unfolding, -- Its unfolding - cafInfo :: CafInfo, -- whether it refers (indirectly) to any CAFs + cgInfo :: CgInfo, -- Code generator info (arity, CAF info) cprInfo :: CprInfo, -- Function always constructs a product result lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable inlinePragInfo :: InlinePragInfo, -- Inline pragma @@ -191,7 +201,9 @@ megaSeqIdInfo info -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all - seqCaf (cafInfo info) `seq` +-- CgInfo is involved in a loop, so we have to be careful not to seq it +-- too early. +-- seqCg (cgInfo info) `seq` seqCpr (cprInfo info) `seq` seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) @@ -228,7 +240,7 @@ setUnfoldingInfo info uf setDemandInfo info dd = info { demandInfo = dd } setArityInfo info ar = info { arityInfo = ar } -setCafInfo info cf = info { cafInfo = cf } +setCgInfo info cg = info { cgInfo = cg } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } \end{code} @@ -238,7 +250,7 @@ setLBVarInfo info lb = info { lbvarInfo = lb } vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { - cafInfo = MayHaveCafRefs, -- Safe! + cgInfo = noCgInfo, arityInfo = UnknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, @@ -252,15 +264,11 @@ vanillaIdInfo occInfo = NoOccInfo } -noTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever +noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever + `setCgInfo` (CgInfo 0 NoCafRefs) + -- Used for built-in type Ids in MkId. -- Many built-in things have fixed types, so we shouldn't -- run around generalising them - -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Local things don't refer to Cafs - -noCafOrTyGenIdInfo = noTyGenIdInfo `setCafInfo` NoCafRefs - -- Most also guarantee not to refer to CAFs \end{code} @@ -309,8 +317,8 @@ hasArity UnknownArity = False hasArity other = True ppArityInfo UnknownArity = empty -ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("__A"), int arity] -ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("__AL"), int arity] +ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("ArityExactly"), int arity] +ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("ArityAtLeast"), int arity] \end{code} %************************************************************************ @@ -445,6 +453,23 @@ There might not be a worker, even for a strict function, because: for w/w split (b) the strictness info might be "SSS" or something, so no w/w split. +Sometimes the arity of a wrapper changes from the original arity from +which it was generated, so we always emit the "original" arity into +the interface file, as part of the worker info. + +How can this happen? Sometimes we get + f = coerce t (\x y -> $wf x y) +at the moment of w/w split; but the eta reducer turns it into + f = coerce t $wf +which is perfectly fine except that the exposed arity so far as +the code generator is concerned (zero) differs from the arity +when we did the split (2). + +All this arises because we use 'arity' to mean "exactly how many +top level lambdas are there" in interface files; but during the +compilation of this module it means "how many things can I apply +this to". + \begin{code} data WorkerInfo = NoWorker @@ -473,14 +498,42 @@ wrapperArity (HasWorker _ a) = a %************************************************************************ %* * -\subsection[CAF-IdInfo]{CAF-related information} +\subsection[CG-IdInfo]{Code generator-related information} %* * %************************************************************************ -This information is used to build Static Reference Tables (see -simplStg/ComputeSRT.lhs). +CgInfo encapsulates calling-convention information produced by the code +generator. It is pasted into the IdInfo of each emitted Id by CoreTidy, +but only as a thunk --- the information is only actually produced further +downstream, by the code generator. \begin{code} +data CgInfo = CgInfo + !Arity -- Exact arity for calling purposes + !CafInfo + +cgArity (CgInfo arity _) = arity +cgCafInfo (CgInfo _ caf_info) = caf_info + +setCafInfo info caf_info = + case cgInfo info of { CgInfo arity _ -> + info `setCgInfo` CgInfo arity caf_info } + +setCgArity info arity = + case cgInfo info of { CgInfo _ caf_info -> + info `setCgInfo` CgInfo arity caf_info } + + -- Used for local Ids, which shouldn't need any CgInfo +noCgInfo = panic "noCgInfo!" + +cgMayHaveCafRefs (CgInfo _ caf_info) = mayHaveCafRefs caf_info + +seqCg c = c `seq` () -- fields are strict anyhow + +vanillaCgInfo = CgInfo 0 MayHaveCafRefs -- Definitely safe + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). + data CafInfo = MayHaveCafRefs -- either: -- (1) A function or static constructor @@ -490,19 +543,29 @@ data CafInfo | NoCafRefs -- A function or static constructor -- that refers to no CAFs. --- LATER: not sure how easy this is... --- | OneCafRef Id +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False +seqCaf c = c `seq` () -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False +pprCgInfo (CgInfo arity caf_info) = ppArity arity <+> ppCafInfo caf_info -seqCaf c = c `seq` () +ppArity 0 = empty +ppArity n = hsep [ptext SLIT("__A"), int n] ppCafInfo NoCafRefs = ptext SLIT("__C") ppCafInfo MayHaveCafRefs = empty \end{code} +\begin{code} +type CgInfoEnv = NameEnv CgInfo + +lookupCgInfo :: NameEnv CgInfo -> Name -> CgInfo +lookupCgInfo env n = case lookupNameEnv env n of + Just info -> info + Nothing -> pprTrace "Urk! Not in CgInfo env" (ppr n) vanillaCgInfo +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index e5a2a497e8..443d75fa50 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -71,11 +71,12 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, idCprInfo ) -import IdInfo ( IdInfo, vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, - exactArity, setUnfoldingInfo, setCafInfo, setCprInfo, - setArityInfo, setSpecInfo, +import IdInfo ( IdInfo, noCafNoTyGenIdInfo, + exactArity, setUnfoldingInfo, setCprInfo, + setArityInfo, setSpecInfo, setCgInfo, mkStrictnessInfo, setStrictnessInfo, - GlobalIdDetails(..), CafInfo(..), CprInfo(..) + GlobalIdDetails(..), CafInfo(..), CprInfo(..), + CgInfo(..), setCgArity ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType @@ -137,7 +138,8 @@ mkDataConId :: Name -> DataCon -> Id mkDataConId work_name data_con = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info where - info = noCafOrTyGenIdInfo + info = noCafNoTyGenIdInfo + `setCgArity` arity `setArityInfo` exactArity arity `setStrictnessInfo` strict_info `setCprInfo` cpr_info @@ -199,11 +201,12 @@ mkDataConWrapId data_con wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info work_id = dataConId data_con - info = noCafOrTyGenIdInfo + info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) `setCprInfo` cpr_info -- The Cpr info can be important inside INLINE rhss, where the -- wrapper constructor isn't inlined + `setCgArity` arity `setArityInfo` exactArity arity -- It's important to specify the arity, so that partial -- applications are treated as values @@ -393,8 +396,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id mkFunTy data_ty field_tau arity = 1 + n_dict_tys + n_field_dict_tys - info = noTyGenIdInfo - `setCafInfo` caf_info + info = noCafNoTyGenIdInfo + `setCgInfo` (CgInfo arity caf_info) `setArityInfo` exactArity arity `setUnfoldingInfo` unfolding -- ToDo: consider adding further IdInfo @@ -519,7 +522,8 @@ mkDictSelId name clas field_lbl = mkFieldLabel name tycon ty tag tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id - info = noCafOrTyGenIdInfo + info = noCafNoTyGenIdInfo + `setCgArity` 1 `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding @@ -563,8 +567,9 @@ mkPrimOpId prim_op name = mkPrimOpIdName prim_op id = mkGlobalId (PrimOpId prim_op) name ty info - info = noCafOrTyGenIdInfo + info = noCafNoTyGenIdInfo `setSpecInfo` rules + `setCgArity` arity `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -594,7 +599,8 @@ mkCCallOpId uniq ccall ty name = mkCCallName uniq occ_str prim_op = CCallOp ccall - info = noCafOrTyGenIdInfo + info = noCafNoTyGenIdInfo + `setCgArity` arity `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -613,7 +619,7 @@ mkCCallOpId uniq ccall ty \begin{code} mkDefaultMethodId dm_name ty - = mkVanillaGlobal dm_name ty noTyGenIdInfo + = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo mkDictFunId :: Name -- Name to use for the dict fun; -> Class @@ -623,10 +629,10 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta - = mkVanillaGlobal dfun_name dfun_ty noTyGenIdInfo + = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - info = noTyGenIdInfo + info = noCafNoTyGenIdInfo -- Type is wired-in (see comment at TcClassDcl.tcClassSig), -- so do not generalise it @@ -680,7 +686,7 @@ another gun with which to shoot yourself in the foot. unsafeCoerceId = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info where - info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] @@ -698,7 +704,7 @@ evaluate its argument and call the dataToTag# primitive. getTagId = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info where - info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- We don't provide a defn for this; you must inline it ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy) @@ -716,7 +722,7 @@ nasty as-is, change it back to a literal (@Literal@). realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") realWorldStatePrimTy - (noCafOrTyGenIdInfo `setUnfoldingInfo` mkOtherCon []) + (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon []) -- The mkOtherCon makes it look that realWorld# is evaluated -- which in turn makes Simplify.interestingArg return True, -- which in turn makes INLINE things applied to realWorld# likely @@ -769,7 +775,7 @@ aBSENT_ERROR_ID pAR_ERROR_ID = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError") - (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafOrTyGenIdInfo + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo \end{code} @@ -796,9 +802,9 @@ pcMiscPrelId key mod str ty info pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where - bottoming_info = noCafOrTyGenIdInfo + bottoming_info = noCafNoTyGenIdInfo `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True) - + -- these "bottom" out, no matter what their arguments generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 7f01cd99f4..a47eb92b50 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.41 2001/02/20 09:38:59 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $ % %******************************************************** %* * @@ -208,14 +208,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts) \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@} \begin{code} -cgExpr (StgLet (StgNonRec name rhs) expr) - = cgRhs name rhs `thenFC` \ (name, info) -> +cgExpr (StgLet (StgNonRec srt name rhs) expr) + = cgRhs srt name rhs `thenFC` \ (name, info) -> addBindC name info `thenC` cgExpr expr -cgExpr (StgLet (StgRec pairs) expr) +cgExpr (StgLet (StgRec srt pairs) expr) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` - listFCs [ cgRhs b e | (b,e) <- pairs ] + listFCs [ cgRhs srt b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> addBindsC new_bindings `thenC` @@ -274,17 +274,15 @@ We rely on the support code in @CgCon@ (to do constructors) and in @CgClosure@ (to do closures). \begin{code} -cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up -cgRhs name (StgRhsCon maybe_cc con args) +cgRhs srt name (StgRhsCon maybe_cc con args) = getArgAmodes args `thenFC` \ amodes -> buildDynCon name maybe_cc con amodes `thenFC` \ idinfo -> returnFC (name, idinfo) -cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body) - = mkRhsClosure name cc bi srt fvs upd_flag args body -cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body) +cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body) = mkRhsClosure name cc bi srt fvs upd_flag args body \end{code} @@ -391,17 +389,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body %* * %******************************************************** \begin{code} -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot + (StgNonRec srt binder rhs) = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot - NonRecursive binder rhs + NonRecursive srt binder rhs `thenFC` \ (binder, info) -> addBindC binder info -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot + (StgRec srt pairs) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` listFCs [ cgLetNoEscapeRhs full_live_in_rhss - rhs_eob_info maybe_cc_slot Recursive b e + rhs_eob_info maybe_cc_slot Recursive srt b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> @@ -416,25 +416,27 @@ cgLetNoEscapeRhs -> EndOfBlockInfo -> Maybe VirtualSpOffset -> RecFlag + -> SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsClosure cc bi srt _ upd_flag args body) +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder + (StgRhsClosure cc bi _ upd_flag args body) = -- We could check the update flag, but currently we don't switch it off -- for let-no-escaped things, so we omit the check too! -- case upd_flag of -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update! -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body - cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body + cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info + maybe_cc_slot rec args body -- For a constructor RHS we want to generate a single chunk of code which -- can be jumped to from many places, which will return the constructor. -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT + = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function (StgConApp con args) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index d1a40acb24..467f44b036 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.45 2001/02/20 09:38:59 simonpj Exp $ +% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -79,7 +79,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) -import Id ( Id, idType, idArityInfo ) +import Id ( Id, idType, idCgArity ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isNullaryDataCon, dataConName ) @@ -261,16 +261,11 @@ mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case idArityInfo id of - ArityExactly 0 -> LFThunk (idType id) - TopLevel True{-no fvs-} - True{-updatable-} NonStandardThunk - (error "mkLFImported: no srt label") - (error "mkLFImported: no srt") - ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0 - (error "mkLFImported: no srt label") - (error "mkLFImported: no srt") - other -> LFImported -- Not sure of exact arity + = 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} %************************************************************************ diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index bf6177df7f..5db06d0bb4 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -188,7 +188,7 @@ variable. \begin{code} cgTopBinding :: (StgBinding,[Id]) -> Code -cgTopBinding (StgNonRec id rhs, srt) +cgTopBinding (StgNonRec srt_info id rhs, srt) = absC maybeSplitCode `thenC` maybeGlobaliseId id `thenFC` \ id' -> let @@ -196,11 +196,11 @@ cgTopBinding (StgNonRec id rhs, srt) in mkSRT srt_label srt [] `thenC` setSRTLabel srt_label ( - cgTopRhs id' rhs `thenFC` \ (id, info) -> + cgTopRhs id' rhs srt_info `thenFC` \ (id, info) -> addBindC id info ) -cgTopBinding (StgRec pairs, srt) +cgTopBinding (StgRec srt_info pairs, srt) = absC maybeSplitCode `thenC` let (bndrs, rhss) = unzip pairs @@ -214,7 +214,7 @@ cgTopBinding (StgRec pairs, srt) setSRTLabel srt_label ( fixC (\ new_binds -> addBindsC new_binds `thenC` - mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' + mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs' ) `thenFC` \ new_binds -> nopC ) @@ -256,18 +256,18 @@ maybeSplitCode -- to enclose the listFCs in cgTopBinding, but that tickled the -- statics "error" call in initC. I DON'T UNDERSTAND WHY! -cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... -cgTopRhs bndr (StgRhsCon cc con args) +cgTopRhs bndr (StgRhsCon cc con args) srt = maybeGlobaliseId bndr `thenFC` \ bndr' -> forkStatics (cgTopRhsCon bndr con args) -cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) +cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt = -- There should be no free variables ASSERT(null fvs) -- If the closure is a thunk, then the binder must be recorded as such. - ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr) +-- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr) getSRTLabel `thenFC` \srt_label -> let lf_info = diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index f1bf15cbeb..6b3877df6d 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -4,13 +4,13 @@ \section{Core pass to saturate constructors and PrimOps} \begin{code} -module CoreSat ( - coreSatPgm, coreSatExpr +module CorePrep ( + corePrepPgm, corePrepExpr ) where #include "HsVersions.h" -import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity ) +import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand ) import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn @@ -18,13 +18,16 @@ import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, isUnLiftedType, isUnboxedTupleType, repType, uaUTy, usOnce, usMany, seqType ) import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) -import PrimOp ( PrimOp(..) ) -import Var ( Id, TyVar, setTyVarUnique ) +import PrimOp ( PrimOp(..), setCCallUnique ) +import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails ) import VarSet +import VarEnv import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity, - isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding + setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo, + hasNoBinding ) - +import IdInfo ( GlobalIdDetails(..) ) +import HscTypes ( ModDetails(..) ) import UniqSupply import Maybes import OrdList @@ -37,21 +40,7 @@ import Outputable -- Overview -- --------------------------------------------------------------------------- -MAJOR CONSTRAINT: - By the time this pass happens, we have spat out tidied Core into - the interface file, including all IdInfo. - - So we must not change the arity of any top-level function, - because we've already fixed it and put it out into the interface file. - Nor must we change a value (e.g. constructor) into a thunk. - - It's ok to introduce extra bindings, which don't appear in the - interface file. We don't put arity info on these extra bindings, - because they are never fully applied, so there's no chance of - compiling just-a-fast-entry point for them. - -Most of the contents of this pass used to be in CoreToStg. The -primary goals here are: +The goal of this pass is to prepare for code generation. 1. Saturate constructor and primop applications. @@ -74,9 +63,17 @@ primary goals here are: 5. Do the seq/par munging. See notes with mkCase below. +6. Clone all local Ids. This means that Tidy Core has the property + that all Ids are unique, rather than the weaker guarantee of + no clashes which the simplifier provides. + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. + @@ -85,19 +82,20 @@ any trivial or useless bindings. -- ----------------------------------------------------------------------------- \begin{code} -coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] -coreSatPgm dflags binds - = do showPass dflags "CoreSat" +corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails +corePrepPgm dflags mod_details + = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_binds = initUs_ us (coreSatTopBinds binds) - endPass dflags "CoreSat" Opt_D_dump_sat new_binds + let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details)) + endPass dflags "CorePrep" Opt_D_dump_sat new_binds + return (mod_details { md_binds = new_binds }) -coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr -coreSatExpr dflags expr - = do showPass dflags "CoreSat" +corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr +corePrepExpr dflags expr + = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_expr = initUs_ us (coreSatAnExpr expr) - dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:" + let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep" (ppr new_expr) return new_expr @@ -108,86 +106,53 @@ coreSatExpr dflags expr data FloatingBind = FloatLet CoreBind | FloatCase Id CoreExpr +type CloneEnv = IdEnv Id -- Clone local Ids + allLazy :: OrdList FloatingBind -> Bool allLazy floats = foldOL check True floats where check (FloatLet _) y = y check (FloatCase _ _) y = False -coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind] --- Very careful to preserve the arity of top-level functions -coreSatTopBinds [] = returnUs [] +corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind] +corePrepTopBinds env [] = returnUs [] -coreSatTopBinds (NonRec b r : binds) - = coreSatTopRhs b r `thenUs` \ (floats, r') -> - coreSatTopBinds binds `thenUs` \ binds' -> - returnUs (floats ++ NonRec b r' : binds') - -coreSatTopBinds (Rec prs : binds) - = mapAndUnzipUs do_pair prs `thenUs` \ (floats_s, prs') -> - coreSatTopBinds binds `thenUs` \ binds' -> - returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds') +corePrepTopBinds env (bind : binds) + = corePrepBind env bind `thenUs` \ (env', floats) -> + ASSERT( allLazy floats ) + corePrepTopBinds env' binds `thenUs` \ binds' -> + returnUs (foldOL add binds' floats) where - do_pair (b,r) = coreSatTopRhs b r `thenUs` \ (floats, r') -> - returnUs (floats, (b, r')) - -coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr) --- The trick here is that if we see --- x = $wC p $wJust q --- we want to transform to --- sat = \a -> $wJust a --- x = $wC p sat q --- and NOT to --- x = let sat = \a -> $wJust a in $wC p sat q --- --- The latter is bad because the thing was a value before, but --- is a thunk now, and that's wrong because now x may need to --- be in other bindings' SRTs. --- This has to be right for recursive as well as non-recursive bindings --- --- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs --- --- You might worry that arity might increase, thus --- x = $wC a ==> x = \ b c -> $wC a b c --- but the simpifier does eta expansion vigorously, so I don't think this --- can occur. If it did, it would be a problem, because x's arity changes, --- so we have an ASSERT to check. (I use WARN so we can see the output.) - -coreSatTopRhs b rhs - = coreSatExprFloat rhs `thenUs` \ (floats, rhs1) -> - if exprIsValue rhs then - ASSERT( allLazy floats ) - WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b ) - returnUs ([bind | FloatLet bind <- fromOL floats], rhs1) - else - mkBinds floats rhs1 `thenUs` \ rhs2 -> - WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b ) - returnUs ([], rhs2) - - -coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind) + add (FloatLet bind) binds = bind : binds + + +-- --------------------------------------------------------------------------- +-- Bindings +-- --------------------------------------------------------------------------- + +corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) -- Used for non-top-level bindings --- We return a *list* of bindings because we may start with +-- We return a *list* of bindings, because we may start with -- x* = f (g y) -- where x is demanded, in which case we want to finish with -- a = g y -- x* = f a -- And then x will actually end up case-bound -coreSatBind (NonRec binder rhs) - = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> - mkNonRec binder (bdrDem binder) floats new_rhs - -- NB: if there are any lambdas at the top of the RHS, - -- the floats will be empty, so the arity won't be affected +corePrepBind env (NonRec bndr rhs) + = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') -> + cloneBndr env bndr `thenUs` \ (env', bndr') -> + mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' -> + returnUs (env', floats') -coreSatBind (Rec pairs) +corePrepBind env (Rec pairs) -- Don't bother to try to float bindings out of RHSs -- (compare mkNonRec, which does try) - = mapUs do_rhs pairs `thenUs` \ new_pairs -> - returnUs (unitOL (FloatLet (Rec new_pairs))) + = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> + mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' -> + returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss')))) where - do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' -> - returnUs (bndr,new_rhs') + (bndrs, rhss) = unzip pairs -- --------------------------------------------------------------------------- @@ -195,9 +160,10 @@ coreSatBind (Rec pairs) -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg) -coreSatArg arg dem - = coreSatExprFloat arg `thenUs` \ (floats, arg') -> +corePrepArg :: CloneEnv -> CoreArg -> RhsDemand + -> UniqSM (OrdList FloatingBind, CoreArg) +corePrepArg env arg dem + = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> if needs_binding arg' then returnUs (floats, arg') else newVar (exprType arg') `thenUs` \ v -> @@ -211,13 +177,13 @@ needs_binding | opt_KeepStgTypes = exprIsAtom -- Dealing with expressions -- --------------------------------------------------------------------------- -coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr -coreSatAnExpr expr - = coreSatExprFloat expr `thenUs` \ (floats, expr) -> +corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr +corePrepAnExpr env expr + = corePrepExprFloat env expr `thenUs` \ (floats, expr) -> mkBinds floats expr -coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) +corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) -- If -- e ===> (bs, e') -- then @@ -226,48 +192,52 @@ coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) -- For example -- f (g x) ===> ([v = g x], f v) -coreSatExprFloat (Var v) - = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app -> +corePrepExprFloat env (Var v) + = fiddleCCall v `thenUs` \ v1 -> + let v2 = lookupVarEnv env v1 `orElse` v1 in + maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app -> returnUs (nilOL, app) -coreSatExprFloat (Lit lit) - = returnUs (nilOL, Lit lit) +corePrepExprFloat env expr@(Type _) + = returnUs (nilOL, expr) -coreSatExprFloat (Let bind body) - = coreSatBind bind `thenUs` \ new_binds -> - coreSatExprFloat body `thenUs` \ (floats, new_body) -> - returnUs (new_binds `appOL` floats, new_body) +corePrepExprFloat env expr@(Lit lit) + = returnUs (nilOL, expr) -coreSatExprFloat (Note n@(SCC _) expr) - = coreSatAnExpr expr `thenUs` \ expr -> - deLam expr `thenUs` \ expr -> - returnUs (nilOL, Note n expr) +corePrepExprFloat env (Let bind body) + = corePrepBind env bind `thenUs` \ (env', new_binds) -> + corePrepExprFloat env' body `thenUs` \ (floats, new_body) -> + returnUs (new_binds `appOL` floats, new_body) -coreSatExprFloat (Note other_note expr) - = coreSatExprFloat expr `thenUs` \ (floats, expr) -> - returnUs (floats, Note other_note expr) +corePrepExprFloat env (Note n@(SCC _) expr) + = corePrepAnExpr env expr `thenUs` \ expr1 -> + deLam expr1 `thenUs` \ expr2 -> + returnUs (nilOL, Note n expr2) -coreSatExprFloat expr@(Type _) - = returnUs (nilOL, expr) +corePrepExprFloat env (Note other_note expr) + = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> + returnUs (floats, Note other_note expr') -coreSatExprFloat expr@(Lam _ _) - = coreSatAnExpr body `thenUs` \ body' -> +corePrepExprFloat env expr@(Lam _ _) + = corePrepAnExpr env body `thenUs` \ body' -> returnUs (nilOL, mkLams bndrs body') where (bndrs,body) = collectBinders expr -coreSatExprFloat (Case scrut bndr alts) - = coreSatExprFloat scrut `thenUs` \ (floats, scrut) -> - mapUs sat_alt alts `thenUs` \ alts -> - returnUs (floats, mkCase scrut bndr alts) +corePrepExprFloat env (Case scrut bndr alts) + = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') -> + cloneBndr env bndr `thenUs` \ (env', bndr') -> + mapUs (sat_alt env') alts `thenUs` \ alts' -> + returnUs (floats, mkCase scrut' bndr' alts') where - sat_alt (con, bs, rhs) - = coreSatAnExpr rhs `thenUs` \ rhs -> - deLam rhs `thenUs` \ rhs -> - returnUs (con, bs, rhs) - -coreSatExprFloat expr@(App _ _) - = collect_args expr 0 `thenUs` \ (app,(head,depth),ty,floats,ss) -> + sat_alt env (con, bs, rhs) + = cloneBndrs env bs `thenUs` \ (env', bs') -> + corePrepAnExpr env' rhs `thenUs` \ rhs1 -> + deLam rhs1 `thenUs` \ rhs2 -> + returnUs (con, bs', rhs2) + +corePrepExprFloat env expr@(App _ _) + = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) -> ASSERT(null ss) -- make sure we used all the strictness info -- Now deal with the function @@ -305,14 +275,16 @@ coreSatExprFloat expr@(App _ _) (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (wwLazy, []) - (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $ + (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $ splitFunTy_maybe fun_ty in - coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> + corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest) collect_args (Var v) depth - = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts) + = fiddleCCall v `thenUs` \ v1 -> + let v2 = lookupVarEnv env v1 `orElse` v1 in + returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts) where stricts = case idStrictness v of StrictnessInfo demands _ @@ -322,8 +294,9 @@ coreSatExprFloat expr@(App _ _) -- If depth < length demands, then we have too few args to -- satisfy strictness info so we have to ignore all the -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + collect_args (Note (Coerce ty1 ty2) fun) depth = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> @@ -336,7 +309,7 @@ coreSatExprFloat expr@(App _ _) -- non-variable fun, better let-bind it collect_args fun depth - = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) -> + = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) -> newVar ty `thenUs` \ fn_id -> mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats -> returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) @@ -349,21 +322,6 @@ coreSatExprFloat expr@(App _ _) -- we don't ignore SCCs, since they require some code generation ------------------------------------------------------------------------------ --- Generating new binders --- --------------------------------------------------------------------------- - -newVar :: Type -> UniqSM Id -newVar ty - = getUniqueUs `thenUs` \ uniq -> - seqType ty `seq` - returnUs (mkSysLocal SLIT("sat") uniq ty) - -cloneTyVar :: TyVar -> UniqSM TyVar -cloneTyVar tv - = getUniqueUs `thenUs` \ uniq -> - returnUs (setTyVarUnique tv uniq) - ------------------------------------------------------------------------------- -- Building the saturated syntax -- --------------------------------------------------------------------------- @@ -372,7 +330,7 @@ cloneTyVar tv maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr maybeSaturate fn expr n_args ty | hasNoBinding fn = saturate_it - | otherwise = returnUs expr + | otherwise = returnUs expr where fn_arity = idArity fn excess_arity = fn_arity - n_args @@ -383,7 +341,7 @@ maybeSaturate fn expr n_args ty -- Precipitating the floating bindings -- --------------------------------------------------------------------------- --- mkNonRec is used for local bindings only, not top level +-- mkNonRec is used for both top level and local bindings mkNonRec :: Id -> RhsDemand -- Lhs: id with demand -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body -> UniqSM (OrdList FloatingBind) @@ -399,19 +357,27 @@ mkNonRec bndr dem floats rhs -- then the strictness analyser may say that f has strictness "S" -- Later the eta expander will transform to -- f x y = case x of { (a,b) -> a } - -- So now f has arity 2. Now CoreSat may see + -- So now f has arity 2. Now CorePrep may see -- v = f E -- so the E argument will turn into a FloatCase. -- Indeed we should end up with -- v = case E of { r -> f r } -- That is, we should not float, even though (f r) is a value + -- + -- Similarly, given + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early returnUs (floats `snocOL` FloatLet (NonRec bndr rhs)) | isUnLiftedType bndr_rep_ty || isStrictDem dem + -- It's a strict let, or the binder is unlifted, + -- so we definitely float all the bindings = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) returnUs (floats `snocOL` FloatCase bndr rhs) | otherwise + -- Don't float = mkBinds floats rhs `thenUs` \ rhs' -> returnUs (unitOL (FloatLet (NonRec bndr rhs'))) @@ -473,7 +439,7 @@ tryEta bndrs expr@(App _ _) -- we can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False --safe. ToDo: generalise + ok_to_eta_reduce _ = False --safe. ToDo: generalise tryEta bndrs (Let bind@(NonRec b r) body) | not (any (`elemVarSet` fvs) bndrs) @@ -519,8 +485,7 @@ rhs is strict --- but that would defeat the purpose of seq and par. mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts = case isPrimOpId_maybe fn of Just ParOp -> Case scrut bndr [deflt_alt] - Just SeqOp -> - Case arg new_bndr [deflt_alt] + Just SeqOp -> Case arg new_bndr [deflt_alt] other -> Case scrut bndr alts where (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts] @@ -576,3 +541,56 @@ onceDem = RhsDemand False True -- used at most once \end{code} + + +%************************************************************************ +%* * +\subsection{Cloning} +%* * +%************************************************************************ + +\begin{code} +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var]) +cloneBndrs env bs = mapAccumLUs cloneBndr env bs + +cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var) +cloneBndr env bndr + | isId bndr && isLocalId bndr -- Top level things, which we don't want + -- to clone, have become ConstantIds by now + = getUniqueUs `thenUs` \ uniq -> + let + bndr' = setVarUnique bndr uniq + in + returnUs (extendVarEnv env bndr bndr', bndr') + + | otherwise = returnUs (env, bndr) + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + = case globalIdDetails id of + PrimOpId (CCallOp ccall) -> + -- Make a guaranteed unique name for a dynamic ccall. + getUniqueUs `thenUs` \ uniq -> + returnUs (setGlobalIdDetails id + (PrimOpId (CCallOp (setCCallUnique ccall uniq)))) + other -> returnUs id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: Type -> UniqSM Id +newVar ty + = getUniqueUs `thenUs` \ uniq -> + seqType ty `seq` + returnUs (mkSysLocal SLIT("sat") uniq ty) +\end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 5cd70ea37c..d22cc00335 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -14,44 +14,39 @@ module CoreTidy ( import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) -import CoreUtils ( exprArity ) -import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, ruleSomeLhsFreeVars ) +import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, + ruleSomeLhsFreeVars ) import CoreLint ( showPass, endPass ) import VarEnv import VarSet -import Var ( Id, Var, varName, globalIdDetails, setGlobalIdDetails ) -import Id ( idType, idInfo, idName, isExportedId, idSpecialisation, - idCafInfo, mkVanillaGlobal, isLocalId, isImplicitId, - modifyIdInfo, idArity, hasNoBinding, mkLocalIdWithInfo +import Var ( Id, Var, varName ) +import Id ( idType, idInfo, idName, isExportedId, + idSpecialisation, idUnique, + mkVanillaGlobal, isLocalId, isImplicitId, + hasNoBinding, mkUserLocal ) import IdInfo {- loads of stuff -} import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, mkLocalName, isGlobalName, isDllName, isLocalName + localiseName, isGlobalName, isLocalName ) import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType, tidyType, tidyTyVar ) import Module ( Module, moduleName ) -import PrimOp ( PrimOp(..), setCCallUnique ) import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), NameSupply( nsNames ), OrigNameCache, TypeEnv, extendTypeEnvList, - DFunId, ModDetails(..), TyThing(..) + ModDetails(..), TyThing(..) ) -import UniqSupply -import DataCon ( DataCon, dataConName ) -import Literal ( isLitLitLit ) import FiniteMap ( lookupFM, addToFM ) import Maybes ( maybeToBool, orElse ) import ErrUtils ( showPass ) -import PprCore ( pprIdCoreRule ) import SrcLoc ( noSrcLoc ) import UniqFM ( mapUFM ) -import Outputable -import FastTypes import List ( partition ) import Util ( mapAccumL ) +import Outputable \end{code} @@ -96,13 +91,6 @@ binder - Give external Ids the same Unique as they had before if the name is in the renamer's name cache - - Clone all local Ids. This means that Tidy Core has the property - that all Ids are unique, rather than the weaker guarantee of - no clashes which the simplifier provides. - - - Give each dynamic CCall occurrence a fresh unique; this is - rather like the cloning step above. - - Give the Id its UTTERLY FINAL IdInfo; in ptic, * Its IdDetails becomes VanillaGlobal, reflecting the fact that from now on we regard it as a global, not local, Id @@ -121,23 +109,24 @@ RHSs, so that they print nicely in interfaces. \begin{code} tidyCorePgm :: DynFlags -> Module -> PersistentCompilerState - -> TypeEnv -> [DFunId] - -> [CoreBind] -> [IdCoreRule] - -> IO (PersistentCompilerState, [CoreBind], ModDetails) - -tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in + -> CgInfoEnv -- Information from the back end, + -- to be splatted into the IdInfo + -> ModDetails + -> IO (PersistentCompilerState, ModDetails) + +tidyCorePgm dflags mod pcs cg_info_env + (ModDetails { md_types = env_tc, md_insts = insts_tc, + md_binds = binds_in, md_rules = orphans_in }) = do { showPass dflags "Tidy Core" - ; let ext_ids = findExternalSet binds_in orphans_in + ; let ext_ids = findExternalSet binds_in orphans_in + ; let ext_rules = findExternalRules binds_in orphans_in ext_ids - ; us <- mkSplitUniqSupply 't' -- for "tidy" + ; let ((orig_env', occ_env, subst_env), tidy_binds) + = mapAccumL (tidyTopBind mod ext_ids cg_info_env) + init_tidy_env binds_in - ; let ((us1, orig_env', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - (init_tidy_env us) binds_in - - ; let (orphans_out, _) - = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in) + ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } } pcs' = pcs { pcs_PRS = prs' } @@ -152,17 +141,17 @@ tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in pprPanic "lookup_dfun_id" (ppr id) - ; let final_rules = mkFinalRules orphans_out final_ids - final_type_env = mkFinalTypeEnv env_tc final_ids - final_dfun_ids = map lookup_dfun_id insts_tc + ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids + tidy_dfun_ids = map lookup_dfun_id insts_tc - ; let new_details = ModDetails { md_types = final_type_env, - md_rules = final_rules, - md_insts = final_dfun_ids } + ; let tidy_details = ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_dfun_ids, + md_binds = tidy_binds } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds - ; return (pcs', tidy_binds, new_details) + ; return (pcs', tidy_details) } where -- We also make sure to avoid any exported binders. Consider @@ -177,17 +166,12 @@ tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in orig = prsOrig prs orig_env = nsNames orig - init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv) + init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv) avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, isGlobalName (idName bndr)] - tidyCoreExpr :: CoreExpr -> IO CoreExpr -tidyCoreExpr expr - = do { us <- mkSplitUniqSupply 't' -- for "tidy" - ; let (expr',_) = initUs us (tidyExpr emptyTidyEnv expr) - ; return expr' - } +tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) \end{code} @@ -228,35 +212,40 @@ mkFinalTypeEnv type_env final_ids \end{code} \begin{code} -mkFinalRules :: [IdCoreRule] -- Orphan rules - -> [Id] -- Ids that are exported, so we need their rules - -> [IdCoreRule] +findExternalRules :: [CoreBind] + -> [IdCoreRule] -- Orphan rules + -> IdEnv a -- Ids that are exported, so we need their rules + -> [IdCoreRule] -- The complete rules are gotten by combining -- a) the orphan rules -- b) rules embedded in the top-level Ids -mkFinalRules orphan_rules emitted +findExternalRules binds orphan_rules ext_ids | opt_OmitInterfacePragmas = [] | otherwise = orphan_rules ++ local_rules where - local_rules = [ (fn, rule) - | fn <- emitted, - rule <- rulesRules (idSpecialisation fn), + local_rules = [ (id, rule) + | id <- bindersOfBinds binds, + id `elemVarEnv` ext_ids, + rule <- rulesRules (idSpecialisation id), not (isBuiltinRule rule), -- We can't print builtin rules in interface files -- Since they are built in, an importing module -- will have access to them anyway - -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules - -- from coming out, and to make it work properly we need to add ???? + -- Sept 00: I've disabled this test. It doesn't stop + -- many, if any, rules from coming out, and to make it + -- work properly we need to add ???? -- (put it back in for now) isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule) - -- Spit out a rule only if none of its LHS free vars are - -- LocalName things i.e. things that aren't visible to importing modules - -- This is a good reason not to do it when we emit the Id itself - ] -\end{code} + -- Spit out a rule only if none of its LHS free + -- vars are LocalName things i.e. things that + -- aren't visible to importing modules This is a + -- good reason not to do it when we emit the Id + -- itself + ] +\end{code} %************************************************************************ %* * @@ -266,7 +255,8 @@ mkFinalRules orphan_rules emitted \begin{code} findExternalSet :: [CoreBind] -> [IdCoreRule] - -> IdEnv Bool -- True <=> show unfolding + -> IdEnv Bool -- In domain => external + -- Range = True <=> show unfolding -- Step 1 from the notes above findExternalSet binds orphan_rules = foldr find init_needed binds @@ -356,7 +346,7 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var) +type TopTidyEnv = (OrigNameCache, TidyOccEnv, VarEnv Var) -- TopTidyEnv: when tidying we need to know -- * orig_env: Any pre-ordained Names. These may have arisen because the @@ -370,9 +360,6 @@ type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old --- --- * uniqsuppy: so we can clone any Ids with non-preordained names. --- \end{code} @@ -380,47 +367,50 @@ type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var) tidyTopBind :: Module -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too + -> CgInfoEnv -> TopTidyEnv -> CoreBind -> (TopTidyEnv, CoreBind) -tidyTopBind mod ext_ids env (NonRec bndr rhs) - = ((us2,orig,occ,subst) , NonRec bndr' rhs') +tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs) + = ((orig,occ,subst) , NonRec bndr' rhs') where - ((us1,orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr - tidy_env = (occ,subst) - caf_info = hasCafRefs (const True) rhs' - (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs) + ((orig,occ,subst), bndr') + = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr + rec_tidy_env = (occ,subst) + rhs' = tidyExpr rec_tidy_env rhs -tidyTopBind mod ext_ids env (Rec prs) +tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) = (final_env, Rec prs') where - (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs - final_tidy_env = (occ,subst) + (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs + rec_tidy_env = (occ,subst) - do_one env (bndr,rhs) - = ((us',orig,occ,subst), (bndr',rhs')) + do_one top_tidy_env (bndr,rhs) + = ((orig,occ,subst), (bndr',rhs')) where - ((us,orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr - (rhs', us') = initUs us (tidyExpr final_tidy_env rhs) + ((orig,occ,subst), bndr') + = tidyTopBinder mod ext_ids cg_info_env + rec_tidy_env rhs' top_tidy_env bndr + + rhs' = tidyExpr rec_tidy_env rhs -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). (bndrs, rhss) = unzip prs' - caf_info = hasCafRefss pred rhss pred v = v `notElem` bndrs tidyTopBinder :: Module -> IdEnv Bool - -> TidyEnv -> CoreExpr -> CafInfo + -> CgInfoEnv + -> TidyEnv -> CoreExpr -- The TidyEnv is used to tidy the IdInfo -- The expr is the already-tided RHS -- Both are knot-tied: don't look at them! -> TopTidyEnv -> Id -> (TopTidyEnv, Id) + -- NB: tidyTopBinder doesn't affect the unique supply -tidyTopBinder mod ext_ids tidy_env rhs caf_info - env@(us, orig_env2, occ_env2, subst_env2) id +tidyTopBinder mod ext_ids cg_info_env tidy_env rhs + env@(orig_env2, occ_env2, subst_env2) id | isImplicitId id -- Don't mess with constructors, = (env, id) -- record selectors, and the like @@ -434,16 +424,14 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info -- The rhs is already tidied - = ((us_r, orig_env', occ_env', subst_env'), id') + = ((orig_env', occ_env', subst_env'), id') where - (us_l, us_r) = splitUniqSupply us - (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2 is_external (idName id) - ty' = tidyTopType (idType id) - idinfo' = tidyIdInfo us_l tidy_env - is_external unfold_info arity_info caf_info id + ty' = tidyTopType (idType id) + cg_info = lookupCgInfo cg_info_env name' + idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id id' = mkVanillaGlobal name' ty' idinfo' subst_env' = extendVarEnv subst_env2 id id' @@ -456,36 +444,29 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info unfold_info | show_unfold = mkTopUnfolding rhs | otherwise = noUnfolding - arity_info = exprArity rhs - -tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id +tidyIdInfo tidy_env is_external unfold_info cg_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O = vanillaIdInfo - `setCafInfo` caf_info + `setCgInfo` cg_info `setStrictnessInfo` strictnessInfo core_idinfo - `setArityInfo` ArityExactly arity_info - -- Keep strictness, arity and CAF info; it's used by the code generator + -- Keep strictness; it's used by CorePrep | otherwise - = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo)) - in - vanillaIdInfo - `setCafInfo` caf_info + = vanillaIdInfo + `setCgInfo` cg_info `setCprInfo` cprInfo core_idinfo `setStrictnessInfo` strictnessInfo core_idinfo `setInlinePragInfo` inlinePragInfo core_idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo) - `setSpecInfo` rules' - `setArityInfo` ArityExactly arity_info - -- this is the final IdInfo, it must agree with the - -- code finally generated (i.e. NO more transformations - -- after this!). + `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules where core_idinfo = idInfo id + -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name -- was previously local, we have to give it a unique occurrence name if @@ -517,55 +498,25 @@ tidyTopName mod orig_env occ_env external name internal = not external ------------ Worker -------------- --- We only treat a function as having a worker if --- the exported arity (which is now the number of visible lambdas) --- is the same as the arity at the moment of the w/w split --- If so, we can safely omit the unfolding inside the wrapper, and --- instead re-generate it from the type/arity/strictness info --- But if the arity has changed, we just take the simple path and --- put the unfolding into the interface file, forgetting the fact --- that it's a wrapper. --- --- How can this happen? Sometimes we get --- f = coerce t (\x y -> $wf x y) --- at the moment of w/w split; but the eta reducer turns it into --- f = coerce t $wf --- which is perfectly fine except that the exposed arity so far as --- the code generator is concerned (zero) differs from the arity --- when we did the split (2). --- --- All this arises because we use 'arity' to mean "exactly how many --- top level lambdas are there" in interface files; but during the --- compilation of this module it means "how many things can I apply --- this to". -tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity) - | real_arity == wrap_arity +tidyWorker tidy_env (HasWorker work_id wrap_arity) = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity -tidyWorker tidy_env real_arity other +tidyWorker tidy_env other = NoWorker ------------ Rules -------------- -tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule] -tidyIdRules env [] = returnUs [] +tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] +tidyIdRules env [] = [] tidyIdRules env ((fn,rule) : rules) - = tidyRule env rule `thenUs` \ rule -> - tidyIdRules env rules `thenUs` \ rules -> - returnUs ((tidyVarOcc env fn, rule) : rules) - -tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules -tidyRules env (Rules rules fvs) - = mapUs (tidyRule env) rules `thenUs` \ rules -> - returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs)) - where - tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var) + = tidyRule env rule =: \ rule -> + tidyIdRules env rules =: \ rules -> + ((tidyVarOcc env fn, rule) : rules) -tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule -tidyRule env rule@(BuiltinRule _) = returnUs rule +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule env rule@(BuiltinRule _) = rule tidyRule env (Rule name vars tpl_args rhs) - = tidyBndrs env vars `thenUs` \ (env', vars) -> - mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args -> - tidyExpr env' rhs `thenUs` \ rhs -> - returnUs (Rule name vars tpl_args rhs) + = tidyBndrs env vars =: \ (env', vars) -> + map (tidyExpr env') tpl_args =: \ tpl_args -> + (Rule name vars tpl_args (tidyExpr env' rhs)) \end{code} %************************************************************************ @@ -577,54 +528,40 @@ tidyRule env (Rule name vars tpl_args rhs) \begin{code} tidyBind :: TidyEnv -> CoreBind - -> UniqSM (TidyEnv, CoreBind) + -> (TidyEnv, CoreBind) + tidyBind env (NonRec bndr rhs) - = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') -> - tidyExpr env' rhs `thenUs` \ rhs' -> - returnUs (env', NonRec bndr' rhs') + = tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) tidyBind env (Rec prs) - = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') -> - mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' -> - returnUs (env', Rec (zip bndrs' rhss')) - -tidyExpr env (Var v) - = fiddleCCall v `thenUs` \ v -> - returnUs (Var (tidyVarOcc env v)) + = mapAccumL tidyBndrWithRhs env prs =: \ (env', bndrs') -> + map (tidyExpr env') (map snd prs) =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) -tidyExpr env (Type ty) = returnUs (Type (tidyType env ty)) -tidyExpr env (Lit lit) = returnUs (Lit lit) -tidyExpr env (App f a) - = tidyExpr env f `thenUs` \ f -> - tidyExpr env a `thenUs` \ a -> - returnUs (App f a) - -tidyExpr env (Note n e) - = tidyExpr env e `thenUs` \ e -> - returnUs (Note (tidyNote env n) e) +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) tidyExpr env (Let b e) - = tidyBind env b `thenUs` \ (env', b') -> - tidyExpr env' e `thenUs` \ e -> - returnUs (Let b' e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) tidyExpr env (Case e b alts) - = tidyExpr env e `thenUs` \ e -> - tidyBndr env b `thenUs` \ (env', b) -> - mapUs (tidyAlt env') alts `thenUs` \ alts -> - returnUs (Case e b alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (map (tidyAlt env') alts) tidyExpr env (Lam b e) - = tidyBndr env b `thenUs` \ (env', b) -> - tidyExpr env' e `thenUs` \ e -> - returnUs (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) tidyAlt env (con, vs, rhs) - = tidyBndrs env vs `thenUs` \ (env', vs) -> - tidyExpr env' rhs `thenUs` \ rhs -> - returnUs (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2) tidyNote env note = note @@ -643,165 +580,36 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of Nothing -> v -- tidyBndr is used for lambda and case binders -tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var) +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyVar var = returnUs (tidyTyVar env var) - | otherwise = tidyId env var noCafIdInfo + | isTyVar var = tidyTyVar env var + | otherwise = tidyId env var -tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var]) -tidyBndrs env vars = mapAccumLUs tidyBndr env vars +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars -- tidyBndrWithRhs is used for let binders -tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var) -tidyBndrWithRhs env (id,rhs) - = tidyId env id idinfo - where - idinfo = noCafIdInfo `setArityInfo` ArityExactly (exprArity rhs) - -- NB: This throws away the IdInfo of the Id, which we - -- no longer need. That means we don't need to - -- run over it with env, nor renumber it. - -tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id) -tidyId env@(tidy_env, var_env) id idinfo +tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var) +tidyBndrWithRhs env (id,rhs) = tidyId env id + +tidyId :: TidyEnv -> Id -> (TidyEnv, Id) +tidyId env@(tidy_env, var_env) id = -- Non-top-level variables - getUniqueUs `thenUs` \ uniq -> let -- Give the Id a fresh print-name, *and* rename its type -- The SrcLoc isn't important now, -- though we could extract it from the Id - name' = mkLocalName uniq occ' noSrcLoc + -- + -- All local Ids now have the same IdInfo, which should save some + -- space. (tidy_env', occ') = tidyOccName tidy_env (getOccName id) ty' = tidyType (tidy_env,var_env) (idType id) - id' = mkLocalIdWithInfo name' ty' idinfo + id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc var_env' = extendVarEnv var_env id id' in - returnUs ((tidy_env', var_env'), id') - - -fiddleCCall id - = case globalIdDetails id of - PrimOpId (CCallOp ccall) -> - -- Make a guaranteed unique name for a dynamic ccall. - getUniqueUs `thenUs` \ uniq -> - returnUs (setGlobalIdDetails id - (PrimOpId (CCallOp (setCCallUnique ccall uniq)))) - other -> returnUs id + ((tidy_env', var_env'), id') \end{code} -%************************************************************************ -%* * -\subsection{Figuring out CafInfo for an expression} -%* * -%************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - \begin{code} -hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo --- Only called for the RHS of top-level lets -hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo - -- predicate returns True for a given Id if we look at this Id when - -- calculating the result. Used to *avoid* looking at the CafInfo - -- field for an Id that is part of the current recursive group. - -hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr) - then MayHaveCafRefs - else NoCafRefs - - -- used for recursive groups. The whole group is set to - -- "MayHaveCafRefs" if at least one of the group is a CAF or - -- refers to any CAFs. -hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs) - then MayHaveCafRefs - else NoCafRefs - -cafRefs p (Var id) - | p id - = case idCafInfo id of - NoCafRefs -> fastBool False - MayHaveCafRefs -> fastBool True - | otherwise - = fastBool False - -cafRefs p (Lit l) = fastBool False -cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a -cafRefs p (Lam x e) = cafRefs p e -cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e -cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts) -cafRefs p (Note n e) = cafRefs p e -cafRefs p (Type t) = fastBool False - -cafRefss p [] = fastBool False -cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es - - -isCAF :: CoreExpr -> Bool --- Only called for the RHS of top-level lets -isCAF e = not (rhsIsNonUpd e) - {- ToDo: check type for onceness, i.e. non-updatable thunks? -} - -rhsIsNonUpd :: CoreExpr -> Bool - -- True => Value-lambda, constructor, PAP - -- This is a bit like CoreUtils.exprIsValue, with the following differences: - -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) - -- - -- b) (C x xs), where C is a contructors is updatable if the application is - -- dynamic: see isDynConApp - -- - -- c) don't look through unfolding of f in (f x). I'm suspicious of this one - -rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e -rhsIsNonUpd (Note (SCC _) e) = False -rhsIsNonUpd (Note _ e) = rhsIsNonUpd e -rhsIsNonUpd other_expr - = go other_expr 0 [] - where - go (Var f) n_args args = idAppIsNonUpd f n_args args - - go (App f a) n_args args - | isTypeArg a = go f n_args args - | otherwise = go f (n_args + 1) (a:args) - - go (Note (SCC _) f) n_args args = False - go (Note _ f) n_args args = go f n_args args - - go other n_args args = False - -idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool -idAppIsNonUpd id n_val_args args - = case globalIdDetails id of - DataConId con | not (isDynConApp con args) -> True - other -> n_val_args < idArity id - -isDynConApp :: DataCon -> [CoreExpr] -> Bool -isDynConApp con args = isDllName (dataConName con) || any isDynArg args --- Top-level constructor applications can usually be allocated --- statically, but they can't if --- a) the constructor, or any of the arguments, come from another DLL --- b) any of the arguments are LitLits --- (because we can't refer to static labels in other DLLs). --- If this happens we simply make the RHS into an updatable thunk, --- and 'exectute' it rather than allocating it statically. --- All this should match the decision in (see CoreToStg.coreToStgRhs) - - -isDynArg :: CoreExpr -> Bool -isDynArg (Var v) = isDllName (idName v) -isDynArg (Note _ e) = isDynArg e -isDynArg (Lit lit) = isLitLitLit lit -isDynArg (App e _) = isDynArg e -- must be a type app -isDynArg (Lam _ e) = isDynArg e -- must be a type lam +m =: k = m `seq` k m \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 9ab7fd5d4c..85bab12fde 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,7 @@ import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, specInfo, cprInfo, ppCprInfo, - strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, + strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo, cprInfo, ppCprInfo, workerInfo, ppWorkerInfo, tyGenInfo, ppTyGenInfo @@ -345,7 +345,7 @@ ppIdInfo b info ppTyGenInfo g, ppWorkerInfo (workerInfo info), ppStrictnessInfo s, - ppCafInfo c, +-- pprCgInfo c, ppCprInfo m, pprCoreRules b p -- Inline pragma, occ, demand, lbvar info @@ -356,7 +356,7 @@ ppIdInfo b info a = arityInfo info g = tyGenInfo info s = strictnessInfo info - c = cafInfo info + c = cgInfo info m = cprInfo info p = specInfo info \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 0765a94f95..aa0fde2c06 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -9,6 +9,7 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) +import HscTypes ( ModDetails(..) ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) @@ -50,20 +51,27 @@ deSugar :: DynFlags -> PersistentCompilerState -> HomeSymbolTable -> Module -> PrintUnqualified -> TcResults - -> IO ([CoreBind], [(Id,CoreRule)], (SDoc, SDoc, [CoreBndr])) + -> IO (ModDetails, (SDoc, SDoc, [CoreBndr])) deSugar dflags pcs hst mod_name unqual - (TcResults {tc_env = local_type_env, + (TcResults {tc_env = type_env, tc_binds = all_binds, + tc_insts = insts, tc_rules = rules, tc_fords = fo_decls}) = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' -- Do desugaring - ; let (result, ds_warns) = initDs dflags us lookup mod_name - (dsProgram mod_name all_binds rules fo_decls) - (ds_binds, ds_rules, _) = result + ; let (ds_result, ds_warns) = initDs dflags us lookup mod_name + (dsProgram mod_name all_binds rules fo_decls) + + (ds_binds, ds_rules, foreign_stuff) = ds_result + + mod_details = ModDetails { md_types = type_env, + md_insts = insts, + md_rules = ds_rules, + md_binds = ds_binds } -- Display any warnings ; doIfSet (not (isEmptyBag ds_warns)) @@ -76,7 +84,7 @@ deSugar dflags pcs hst mod_name unqual ; doIfSet (dopt Opt_D_dump_ds dflags) (printDump (ppr_ds_rules ds_rules)) - ; return result + ; return (mod_details, foreign_stuff) } where @@ -88,7 +96,7 @@ deSugar dflags pcs hst mod_name unqual lookup n = case lookupType hst pte n of { Just (AnId v) -> v ; other -> - case lookupNameEnv local_type_env n of + case lookupNameEnv type_env n of Just (AnId v) -> v ; other -> pprPanic "Desugar: lookup:" (ppr n) } diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 23d4d01e9f..1b377cb8a6 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -48,6 +48,7 @@ import PrimOp ( CCall, pprCCallOp ) import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) import Type ( Kind ) +import BasicTypes ( Arity ) import FiniteMap ( lookupFM ) import CostCentre import Outputable @@ -379,21 +380,22 @@ pprHsIdInfo [] = empty pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}") data HsIdInfo name - = HsArity ArityInfo + = HsArity Arity | HsStrictness StrictnessInfo | HsUnfold InlinePragInfo (UfExpr name) | HsNoCafRefs | HsCprInfo - | HsWorker name -- Worker, if any + | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. deriving( Eq ) -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf) -ppr_hs_info (HsArity arity) = ppArityInfo arity +ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str ppr_hs_info HsNoCafRefs = ptext SLIT("__C") ppr_hs_info HsCprInfo = ptext SLIT("__M") -ppr_hs_info (HsWorker w) = ptext SLIT("__P") <+> ppr w +ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a \end{code} diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index bd1b1762df..639668a806 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.6 2001/02/27 15:25:18 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.7 2001/03/13 12:50:31 simonmar Exp $ -- -- GHC Driver -- @@ -38,12 +38,9 @@ data Phase = MkDependHS -- haskell dependency generation | Unlit | Cpp - | Hsc + | Hsc -- ToDo: HscTargetLang | Cc | HCc -- Haskellised C (as opposed to vanilla C) compilation -#ifdef ILX - | Ilx -- .NET extended IL -#endif | Mangle -- assembly mangling, now done by a separate script. | SplitMangle -- after mangler if splitting | SplitAs @@ -71,9 +68,6 @@ phaseInputExt Cpp = "lpp" -- intermediate only phaseInputExt Hsc = "hspp" phaseInputExt HCc = "hc" phaseInputExt Cc = "c" -#ifdef ILX -phaseInputExt Ilx = "ilx" -#endif phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index a262bd685f..5d3609cb76 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -12,6 +12,7 @@ module ErrUtils ( printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, + printError, ghcExit, doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, @@ -27,7 +28,7 @@ import Outputable import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, stderr ) +import IO ( hPutStr, hPutStrLn, stderr ) \end{code} \begin{code} @@ -69,6 +70,10 @@ dontAddErrLoc msg = (noSrcLoc, msg) \end{code} +\begin{code} +printError :: String -> IO () +printError str = hPutStrLn stderr str +\end{code} \begin{code} type Messages = (Bag WarnMsg, Bag ErrMsg) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2e2fcff3b9..f8f43d47cb 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -19,29 +19,32 @@ import ByteCodeGen ( byteCodeGen ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) import HscTypes ( InteractiveContext(..), TyThing(..) ) +import PrelNames ( iINTERACTIVE ) +import CoreTidy ( tidyCoreExpr ) +import StringBuffer ( stringToStringBuffer ) #endif import HsSyn -import StringBuffer ( hGetStringBuffer, - stringToStringBuffer, freeStringBuffer ) +import Id ( idName ) +import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) +import StringBuffer ( hGetStringBuffer, freeStringBuffer ) import Parser import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) -import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE ) +import PrelNames ( vanillaSyntaxMap, knownKeyNames ) import MkIface ( completeIface, writeIface, pprIface ) -import Type ( Type ) import TcModule import InstEnv ( emptyInstEnv ) import Desugar import SimplCore import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) -import CoreSat -import CoreTidy ( tidyCoreExpr ) +import CorePrep ( corePrepPgm ) +import StgSyn import CoreToStg ( coreToStg ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -50,7 +53,7 @@ import CodeOutput ( codeOutput ) import Module ( ModuleName, moduleName, mkHomeModule, moduleUserString ) import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) @@ -59,17 +62,15 @@ import Outputable import Interpreter import CmStaticInfo ( GhciMode(..) ) import HscStats ( ppSourceStats ) -import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), - PersistentRenamerState(..), ModuleLocation(..), - HomeSymbolTable, - NameSupply(..), PackageRuleBase, HomeIfaceTable, - typeEnvClasses, typeEnvTyCons, emptyIfaceTable - ) +import HscTypes import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) import Name ( Name, nameModule, nameOccName, getName, isGlobalName ) -import NameEnv ( emptyNameEnv ) +import NameEnv ( emptyNameEnv, mkNameEnv ) import Module ( Module, lookupModuleEnvByName ) +import Maybes ( orElse ) + +import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) import Monad ( when ) import Maybe ( isJust ) @@ -223,71 +224,146 @@ hscRecomp ghci_mode dflags mod location maybe_checked_iface hst hit pcs_ch Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); Just (pcs_tc, tc_result) -> do { - ; let env_tc = tc_env tc_result - insts_tc = tc_insts tc_result - ------------------- -- DESUGAR ------------------- - ; (ds_binds, ds_rules, foreign_stuff) + ; (ds_details, foreign_stuff) <- _scc_ "DeSugar" deSugar dflags pcs_tc hst this_mod print_unqualified tc_result ------------------- -- SIMPLIFY ------------------- - ; (simplified, orphan_rules) + ; simpl_details <- _scc_ "Core2Core" - core2core dflags pcs_tc hst dont_discard ds_binds ds_rules + core2core dflags pcs_tc hst dont_discard ds_details ------------------- -- TIDY ------------------- - ; (pcs_simpl, tidy_binds, new_details) - <- tidyCorePgm dflags this_mod pcs_tc env_tc insts_tc - simplified orphan_rules + ; cg_info_ref <- newIORef Nothing ; + ; let cg_info :: CgInfoEnv + cg_info = unsafePerformIO $ do { + maybe_cg_env <- readIORef cg_info_ref ; + case maybe_cg_env of + Just env -> return env + Nothing -> do { printError "Urk! Looked at CgInfo too early!"; + return emptyNameEnv } } + -- cg_info_ref will be filled in just after restOfCodeGeneration + -- Meanwhile, tidyCorePgm is careful not to look at cg_info! + + ; (pcs_simpl, tidy_details) + <- tidyCorePgm dflags this_mod pcs_tc cg_info simpl_details ------------------- - -- BUILD THE NEW ModDetails AND ModIface + -- PREPARE FOR CODE GENERATION ------------------- - ; final_iface <- _scc_ "MkFinalIface" - mkFinalIface ghci_mode dflags location - maybe_checked_iface new_iface new_details + -- Do saturation and convert to A-normal form + ; prepd_details <- corePrepPgm dflags tidy_details ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ------------------- - -- Do saturation and convert to A-normal form - ; saturated <- coreSatPgm dflags tidy_binds + ; let + ModDetails{md_binds=binds, md_types=env_tc} = prepd_details + + local_tycons = typeEnvTyCons env_tc + local_classes = typeEnvClasses env_tc + + imported_module_names = map ideclName (hsModuleImports rdr_module) + imported_modules = map mod_name_to_Module imported_module_names + + (h_code,c_code,fe_binders) = foreign_stuff + + pit = pcs_PIT pcs_simpl + + mod_name_to_Module :: ModuleName -> Module + mod_name_to_Module nm + = let str_mi = lookupModuleEnvByName hit nm `orElse` + lookupModuleEnvByName pit nm `orElse` + pprPanic "mod_name_to_Module: no hst or pst mapping for" + (ppr nm) + in mi_module str_mi + + ; (maybe_stub_h_filename, maybe_stub_c_filename, + maybe_bcos, final_iface ) + <- if toInterp + then do + ----------------- Generate byte code ------------------ + (bcos,itbl_env) <- byteCodeGen dflags binds + local_tycons local_classes + + -- Fill in the code-gen info + writeIORef cg_info_ref (Just emptyNameEnv) + + ------------------ BUILD THE NEW ModIface ------------ + final_iface <- _scc_ "MkFinalIface" + mkFinalIface ghci_mode dflags location + maybe_checked_iface new_iface tidy_details + + return ( Nothing, Nothing, + Just (bcos,itbl_env), final_iface ) + + else do + ----------------- Convert to STG ------------------ + (stg_binds, cost_centre_info, stg_back_end_info) + <- _scc_ "CoreToStg" + myCoreToStg dflags this_mod binds + + -- Fill in the code-gen info for the earlier tidyCorePgm + writeIORef cg_info_ref (Just stg_back_end_info) + + ------------------ BUILD THE NEW ModIface ------------ + final_iface <- _scc_ "MkFinalIface" + mkFinalIface ghci_mode dflags location + maybe_checked_iface new_iface tidy_details + + ------------------ Code generation ------------------ + abstractC <- _scc_ "CodeGen" + codeGen dflags this_mod imported_modules + cost_centre_info fe_binders + local_tycons stg_binds + + ------------------ Code output ----------------------- + (maybe_stub_h_name, maybe_stub_c_name) + <- codeOutput dflags this_mod local_tycons + binds stg_binds + c_code h_code abstractC + + return ( maybe_stub_h_name, maybe_stub_c_name, + Nothing, final_iface ) + + ; let final_details = tidy_details {md_binds = []} - ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos) - <- restOfCodeGeneration dflags toInterp this_mod - (map ideclName (hsModuleImports rdr_module)) - foreign_stuff env_tc saturated - hit (pcs_PIT pcs_simpl) -- and the answer is ... - ; return (HscRecomp pcs_simpl new_details final_iface + ; return (HscRecomp pcs_simpl + final_details + final_iface maybe_stub_h_filename maybe_stub_c_filename maybe_bcos) }}}}}}} -mkFinalIface ghci_mode dflags location maybe_old_iface new_iface new_details +mkFinalIface ghci_mode dflags location + maybe_old_iface new_iface new_details = case completeIface maybe_old_iface new_iface new_details of + (new_iface, Nothing) -- no change in the interfacfe -> do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED")) dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface) return new_iface + (new_iface, Just sdoc_diffs) -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface) - -- Write the interface file + + -- Write the interface file, if not in interactive mode when (ghci_mode /= Interactive) (writeIface (unJust "hscRecomp:hi" (ml_hi_file location)) new_iface) @@ -324,71 +400,30 @@ myParseModule dflags src_filename }} -restOfCodeGeneration dflags toInterp this_mod imported_module_names - foreign_stuff env_tc tidy_binds - hit pit -- these last two for mapping ModNames to Modules - | toInterp - = do (bcos,itbl_env) - <- byteCodeGen dflags tidy_binds local_tycons local_classes - return (Nothing, Nothing, Just (bcos,itbl_env)) - - | otherwise - = do - -------------------------- Convert to STG ------------------------------- - (stg_binds, cost_centre_info) - <- _scc_ "CoreToStg" - myCoreToStg dflags this_mod tidy_binds env_tc - - -------------------------- Code generation ------------------------------ - abstractC <- _scc_ "CodeGen" - codeGen dflags this_mod imported_modules - cost_centre_info fe_binders - local_tycons stg_binds - - -------------------------- Code output ------------------------------- - (maybe_stub_h_name, maybe_stub_c_name) - <- codeOutput dflags this_mod local_tycons - tidy_binds stg_binds - c_code h_code abstractC - - return (maybe_stub_h_name, maybe_stub_c_name, Nothing) - where - local_tycons = typeEnvTyCons env_tc - local_classes = typeEnvClasses env_tc - imported_modules = map mod_name_to_Module imported_module_names - (h_code,c_code,fe_binders) = foreign_stuff - - mod_name_to_Module :: ModuleName -> Module - mod_name_to_Module nm - = let str_mi = case lookupModuleEnvByName hit nm of - Just mi -> mi - Nothing -> case lookupModuleEnvByName pit nm of - Just mi -> mi - Nothing -> barf nm - in mi_module str_mi - barf nm = pprPanic "mod_name_to_Module: no hst or pst mapping for" - (ppr nm) - - -myCoreToStg dflags this_mod tidy_binds env_tc +myCoreToStg dflags this_mod tidy_binds = do () <- coreBindsSize tidy_binds `seq` return () -- TEMP: the above call zaps some space usage allocated by the -- simplifier, which for reasons I don't understand, persists -- thoroughout code generation - --let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes - - - stg_binds <- _scc_ "Core2Stg" coreToStg dflags this_mod tidy_binds + stg_binds <- _scc_ "Core2Stg" coreToStg dflags tidy_binds (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds - return (stg_binds2, cost_centre_info) + let env_rhs :: CgInfoEnv + env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info) + | (bind,_) <- stg_binds2, + let caf_info + | stgBindHasCafRefs bind = MayHaveCafRefs + | otherwise = NoCafRefs, + (bndr,rhs) <- stgBindPairs bind ] + + return (stg_binds2, cost_centre_info, env_rhs) where - local_tycons = typeEnvTyCons env_tc - local_classes = typeEnvClasses env_tc + stgBindPairs (StgNonRec _ b r) = [(b,r)] + stgBindPairs (StgRec _ prs) = prs \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c358e8ef35..95904c9f77 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -59,6 +59,7 @@ import Module ( Module, ModuleName, ModuleEnv, ) import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) import Id ( Id ) import Class ( Class, classSelIds ) import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) @@ -167,27 +168,42 @@ data ModDetails -- The next three fields are created by the typechecker md_types :: TypeEnv, md_insts :: [DFunId], -- Dfun-ids for the instances in this module - md_rules :: [IdCoreRule] -- Domain may include Ids from other modules + md_rules :: [IdCoreRule], -- Domain may include Ids from other modules + md_binds :: [CoreBind] } --- NOT YET IMPLEMENTED -- The ModDetails takes on several slightly different forms: -- -- After typecheck + desugar --- md_types contains TyCons, Classes, and hasNoBinding Ids --- md_insts all instances from this module (incl derived ones) --- md_rules all rules from this module --- md_binds desugared bindings +-- md_types Contains TyCons, Classes, and hasNoBinding Ids +-- md_insts All instances from this module (incl derived ones) +-- md_rules All rules from this module +-- md_binds Desugared bindings -- -- After simplification --- md_types same as after typecheck --- md_insts ditto --- md_rules orphan rules only (local ones attached to binds) --- md_binds with rules attached +-- md_types Same as after typecheck +-- md_insts Ditto +-- md_rules Orphan rules only (local ones now attached to binds) +-- md_binds With rules attached -- --- After tidy --- md_types now contains Ids as well, replete with correct IdInfo --- apart from +-- After CoreTidy +-- md_types Now contains Ids as well, replete with final IdInfo +-- The Ids are only the ones that are visible from +-- importing modules. Without -O that means only +-- exported Ids, but with -O importing modules may +-- see ids mentioned in unfoldings of exported Ids +-- +-- md_insts Same DFunIds as before, but with final IdInfo, +-- and the unique might have changed; remember that +-- CoreTidy links up the uniques of old and new versions +-- +-- md_rules All rules for exported things, substituted with final Ids +-- +-- md_binds Tidied +-- +-- Passed back to compilation manager +-- Just as after CoreTidy, but with md_binds nuked + \end{code} \begin{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 11a70b8b3d..923448aa70 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -28,10 +28,12 @@ import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), ) import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, isLocalId, idName ) +import Id ( idType, idInfo, isImplicitId, idCgInfo, + isLocalId, idName, + ) import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots -import CoreSyn ( CoreBind, CoreRule(..) ) +import CoreSyn ( CoreRule(..) ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) import PprCore ( pprIdCoreRule ) import Name ( getName, nameModule, toRdrName, isGlobalName, Name, NamedThing(..) ) @@ -69,7 +71,7 @@ completeIface :: Maybe ModIface -- The old interface, if we have it -- NB: 'Nothing' means that even the usages havn't changed, so there's no -- need to write a new interface file. But even if the usages have -- changed, the module version may not have. -completeIface maybe_old_iface new_iface mod_details +completeIface maybe_old_iface new_iface mod_details = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls }) where new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls @@ -171,18 +173,20 @@ ifaceTyCls (AnId id) so_far id_type = idType id id_info = idInfo id + cg_info = idCgInfo id + arity_info = cgArity cg_info + caf_info = cgCafInfo cg_info hs_idinfo | opt_OmitInterfacePragmas = [] | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo ------------ Arity -------------- - arity_hsinfo = case arityInfo id_info of - a@(ArityExactly n) -> [HsArity a] - other -> [] + arity_hsinfo | arity_info == 0 = [] + | otherwise = [HsArity arity_info] ------------ Caf Info -------------- - caf_hsinfo = case cafInfo id_info of + caf_hsinfo = case caf_info of NoCafRefs -> [HsNoCafRefs] otherwise -> [] @@ -200,8 +204,9 @@ ifaceTyCls (AnId id) so_far work_info = workerInfo id_info has_worker = case work_info of { HasWorker _ _ -> True; other -> False } wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> [HsWorker (getName work_id)] - NoWorker -> [] + HasWorker work_id wrap_arity -> + [HsWorker (getName work_id) wrap_arity] + NoWorker -> [] ------------ Unfolding -------------- -- The unfolding is redundant if there is a worker diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 483854748c..00b1921b60 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -81,18 +81,18 @@ stgMassageForProfiling mod_name us stg_binds do_top_bindings [] = returnMM [] - do_top_bindings (StgNonRec b rhs : bs) + do_top_bindings (StgNonRec srt b rhs : bs) = do_top_rhs b rhs `thenMM` \ rhs' -> addTopLevelIshId b ( do_top_bindings bs `thenMM` \bs' -> - returnMM (StgNonRec b rhs' : bs') + returnMM (StgNonRec srt b rhs' : bs') ) - do_top_bindings (StgRec pairs : bs) + do_top_bindings (StgRec srt pairs : bs) = addTopLevelIshIds binders ( mapMM do_pair pairs `thenMM` \ pairs2 -> do_top_bindings bs `thenMM` \ bs' -> - returnMM (StgRec pairs2 : bs') + returnMM (StgRec srt pairs2 : bs') ) where binders = map fst pairs @@ -103,7 +103,7 @@ stgMassageForProfiling mod_name us stg_binds ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgConApp con args))) + do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC cc (StgConApp con args))) | not (isSccCountCostCentre cc) && not (isDllConApp con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon @@ -112,17 +112,17 @@ stgMassageForProfiling mod_name us stg_binds = returnMM (StgRhsCon dontCareCCS con args) {- Can't do this one with cost-centre stacks: --SDM - do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] (StgSCC ty cc expr)) + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr)) | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc) && not (isSccCountCostCentre cc) -- Top level CAF without a cost centre attached -- Attach and collect cc of trivial _scc_ in body = collectCC cc `thenMM_` set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> - returnMM (StgRhsClosure cc bi srt fv u [] expr') + returnMM (StgRhsClosure cc bi fv u [] expr') -} - do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] body) + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body) | noCCSAttached no_cc || currentOrSubsumedCCS no_cc -- Top level CAF without a cost centre attached -- Attach CAF cc (collect if individual CAF ccs) @@ -136,28 +136,18 @@ stgMassageForProfiling mod_name us stg_binds else returnMM all_cafs_ccs) `thenMM` \ caf_ccs -> set_prevailing_cc caf_ccs (do_expr body) `thenMM` \ body' -> - returnMM (StgRhsClosure caf_ccs bi srt fv u [] body') + returnMM (StgRhsClosure caf_ccs bi fv u [] body') - do_top_rhs binder (StgRhsClosure cc bi srt fv u [] body) + do_top_rhs binder (StgRhsClosure cc bi fv u [] body) -- Top level CAF with cost centre attached -- Should this be a CAF cc ??? Does this ever occur ??? = pprPanic "SCCfinal: CAF with cc:" (ppr cc) -{- can't do this with cost-centre stacks: --SDM - do_top_rhs binder (StgRhsClosure _ bi srt fv u args (StgSCC cc expr)) - | not (isSccCountCostCentre cc) - -- Top level function with trivial _scc_ in body - -- Attach and collect cc of trivial _scc_ - = collectCC cc `thenMM_` - set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> - returnMM (StgRhsClosure cc bi srt fv u args expr') --} - - do_top_rhs binder (StgRhsClosure no_ccs bi srt fv u args body) + do_top_rhs binder (StgRhsClosure no_ccs bi fv u args body) -- Top level function, probably subsumed | noCCSAttached no_ccs = set_lambda_cc (do_expr body) `thenMM` \ body' -> - returnMM (StgRhsClosure subsumedCCS bi srt fv u args body') + returnMM (StgRhsClosure subsumedCCS bi fv u args body') | otherwise = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs) @@ -225,18 +215,18 @@ stgMassageForProfiling mod_name us stg_binds ---------------------------------- - do_let (StgNonRec b rhs) e + do_let (StgNonRec srt b rhs) e = do_rhs rhs `thenMM` \ rhs' -> addTopLevelIshId b ( do_expr e `thenMM` \ e' -> - returnMM (StgNonRec b rhs',e') + returnMM (StgNonRec srt b rhs',e') ) - do_let (StgRec pairs) e + do_let (StgRec srt pairs) e = addTopLevelIshIds binders ( mapMM do_pair pairs `thenMM` \ pairs' -> do_expr e `thenMM` \ e' -> - returnMM (StgRec pairs', e') + returnMM (StgRec srt pairs', e') ) where binders = map fst pairs @@ -250,28 +240,28 @@ stgMassageForProfiling mod_name us stg_binds -- but we don't have to worry about cafs etc. {- - do_rhs (StgRhsClosure closure_cc bi srt fv u [] (StgSCC ty cc (StgCon (DataCon con) args _))) + do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _))) | not (isSccCountCostCentre cc) = collectCC cc `thenMM_` returnMM (StgRhsCon cc con args) -} {- - do_rhs (StgRhsClosure _ bi srt fv u args (StgSCC ty cc expr)) + do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr)) | not (isSccCountCostCentre cc) = collectCC cc `thenMM_` set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> - returnMM (StgRhsClosure cc bi srt fv u args expr') + returnMM (StgRhsClosure cc bi fv u args expr') -} - do_rhs (StgRhsClosure cc bi srt fv u [] body) + do_rhs (StgRhsClosure cc bi fv u [] body) = do_expr body `thenMM` \ body' -> - returnMM (StgRhsClosure currentCCS bi srt fv u [] body') + returnMM (StgRhsClosure currentCCS bi fv u [] body') - do_rhs (StgRhsClosure cc bi srt fv u args body) + do_rhs (StgRhsClosure cc bi fv u args body) = set_lambda_cc (do_expr body) `thenMM` \ body' -> get_prevailing_cc `thenMM` \ prev_ccs -> - returnMM (StgRhsClosure currentCCS bi srt fv u args body') + returnMM (StgRhsClosure currentCCS bi fv u args body') do_rhs (StgRhsCon cc con args) = returnMM (StgRhsCon currentCCS con args) @@ -324,9 +314,9 @@ boxHigherOrderArgs almost_expr args mk_stg_let cc (new_var, old_var) body = let rhs_body = StgApp old_var [{-args-}] - rhs_closure = StgRhsClosure cc stgArgOcc NoSRT [{-fvs-}] ReEntrant [{-args-}] rhs_body + rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body in - StgLet (StgNonRec new_var rhs_closure) body + StgLet (StgNonRec NoSRT{-eeek!!!-} new_var rhs_closure) body where bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 6e0187269a..7fa4cd352e 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -44,7 +44,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import CallConv ( cCallConv ) import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) -import IdInfo ( exactArity, InlinePragInfo(..) ) +import IdInfo ( InlinePragInfo(..) ) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex @@ -742,12 +742,12 @@ id_info :: { [HsIdInfo RdrName] } | id_info_item id_info { $1 : $2 } id_info_item :: { HsIdInfo RdrName } - : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) } + : '__A' INTEGER { HsArity (fromInteger $2) } | '__U' inline_prag core_expr { HsUnfold $2 $3 } | '__M' { HsCprInfo } | '__S' { HsStrictness (mkStrictnessInfo $1) } | '__C' { HsNoCafRefs } - | '__P' qvar_name { HsWorker $2 } + | '__P' qvar_name INTEGER { HsWorker $2 (fromInteger $3) } inline_prag :: { InlinePragInfo } : {- empty -} { NoInlinePragInfo } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 25b86e747b..4269aad2e1 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -30,7 +30,6 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs, ) -import MkIface ( pprUsage ) import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 7d12987a46..04531edfdd 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -184,7 +184,7 @@ bangTyFVs bty = extractHsTyNames (getBangType bty) ---------------- hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf -hsIdInfoFVs (HsWorker n) = unitFV n +hsIdInfoFVs (HsWorker n a) = unitFV n hsIdInfoFVs other = emptyFVs ---------------- diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 9bcad7ee7b..fe24db11ab 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -688,9 +688,9 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar %********************************************************* \begin{code} -rnIdInfo (HsWorker worker) +rnIdInfo (HsWorker worker arity) = lookupOccRn worker `thenRn` \ worker' -> - returnRn (HsWorker worker') + returnRn (HsWorker worker' arity) rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> returnRn (HsUnfold inline expr') diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 47addf32eb..7197e77a72 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -62,24 +62,25 @@ core2core :: DynFlags -- includes spec of what core-to-core passes to do -> PersistentCompilerState -> HomeSymbolTable -> IsExported - -> [CoreBind] -- Binds in - -> [IdCoreRule] -- Rules defined in this module - -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out + -> ModDetails + -> IO ModDetails -core2core dflags pcs hst is_exported binds rules +core2core dflags pcs hst is_exported + mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in }) = do let core_todos = dopt_CoreToDo dflags let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages + us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) - <- prepareRules dflags pkg_rule_base hst ru_us binds rules + <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in -- PREPARE THE BINDINGS - let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds + let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in -- DO THE BUSINESS (stats, processed_binds) @@ -92,7 +93,7 @@ core2core dflags pcs hst is_exported binds rules -- Return results -- We only return local orphan rules, i.e., local rules not attached to an Id -- The bindings cotain more rules, embedded in the Ids - return (processed_binds, orphan_rules) + return (mod_details { md_binds = processed_binds, md_rules = orphan_rules}) simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index f6de6efa54..7029b6e815 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -7,17 +7,14 @@ each let-binding. At the same time, we figure out which top-level bindings have no CAF references, and record the fact in their IdInfo. \begin{code} -module SRT where +module SRT( computeSRTs ) where #include "HsVersions.h" -import Id ( Id, idCafInfo ) -import IdInfo ( mayHaveCafRefs ) import StgSyn - -import UniqFM -import UniqSet -import Panic +import Id ( Id ) +import VarSet ( varSetElems ) +import Util ( mapAccumL ) #ifdef DEBUG import Outputable @@ -26,6 +23,9 @@ import Outputable \begin{code} computeSRTs :: [StgBinding] -> [(StgBinding,[Id])] + -- The incoming bindingd are filled with SRTEntries in their SRT slots + -- the outgoing ones have NoSRT/SRT values instead + computeSRTs binds = map srtTopBind binds \end{code} @@ -34,19 +34,12 @@ Algorithm for figuring out SRT layout. Our functions have type - :: SrtOffset -- next free offset within the SRT - -> (UniqSet Id, -- global refs in the continuation - UniqFM (UniqSet Id))-- global refs in let-no-escaped variables -{- * -} -> StgExpr -- expression to analyse - +srtExpr :: SrtOffset -- Next free offset within the SRT + -> StgExpr -- Expression to analyse -> (StgExpr, -- (e) newly annotated expression - UniqSet Id, -- (g) global refs from this expression - [Id], -- (s) SRT required for this expression + SrtIds, -- (s) SRT required for this expression (reversed) SrtOffset) -- (o) new offset -(g) is a set containing all local top-level and imported ids referred -to by the expression (e), which have MayHaveCafRefs in their CafInfo. - We build a single SRT for a recursive binding group, which is why the SRT building is done at the binding level rather than the StgRhsClosure level. @@ -82,221 +75,94 @@ it done this way? Hmm, that probably makes no sense. \begin{code} -srtTopBind - :: StgBinding - -> (StgBinding, -- the new binding - [Id]) -- the SRT for this binding +type SrtOffset = Int +type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT -srtTopBind (StgNonRec binder rhs) = +srtTopBind :: StgBinding -> (StgBinding, SrtIds) - -- no need to use circularity for non-recursive bindings - srtRhs (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs - =: \(rhs, g, srt, off) -> - let - filtered_g = uniqSetToList g - extra_refs = filter (`notElem` srt) filtered_g - bind_srt = reverse (extra_refs ++ srt) - in - ASSERT2(null bind_srt || idMayHaveCafRefs binder, ppr binder) +srtTopBind bind + = srtBind 0 bind =: \ (bind', srt, off) -> + (bind', reverse srt) -- The 'reverse' is because the SRT is + -- built up reversed, for efficiency's sake - case rhs of - StgRhsClosure _ _ _ _ _ _ _ -> - (StgNonRec binder (attach_srt_rhs rhs 0 (length bind_srt)), - bind_srt) +srtBind :: SrtOffset -> StgBinding -> (StgBinding, SrtIds, SrtOffset) - -- don't output an SRT for the constructor - StgRhsCon _ _ _ -> (StgNonRec binder rhs, []) - - -srtTopBind (StgRec bs) = - ASSERT(null bind_srt || all idMayHaveCafRefs binders) - (attach_srt_bind (StgRec new_bs) 0 (length bind_srt), bind_srt) +srtBind off (StgNonRec (SRTEntries rhs_cafs) binder rhs) + = (StgNonRec srt_info binder new_rhs, this_srt, body_off) where - (binders,rhss) = unzip bs + (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs + (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off - non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ] - - (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0 - - -- filter out ourselves from the global references: it makes no - -- sense to refer recursively to our SRT unless the recursive - -- reference is required by a nested SRT. - filtered_g = filter (\id -> id `notElem` non_caf_binders) (uniqSetToList g) - extra_refs = filter (`notElem` srt) filtered_g - bind_srt = reverse (extra_refs ++ srt) - - doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off) - doBinds ((binder,rhs):binds) new_binds g srt off = - srtRhs (emptyUniqSet,emptyUFM) off rhs - =: \(rhs, rhs_g, rhs_srt, off) -> - let - g' = unionUniqSets rhs_g g - srt' = rhs_srt ++ srt - in - doBinds binds ((binder,rhs):new_binds) g' srt' off - -caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True -caf_rhs _ = False -\end{code} - ------------------------------------------------------------------------------ -Non-top-level bindings -\begin{code} -srtBind :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int) +srtBind off (StgRec (SRTEntries rhss_cafs) pairs) + = (StgRec srt_info new_pairs, this_srt, body_off) + where + ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs -srtBind cont_refs off (StgNonRec binder rhs) = - srtRhs cont_refs off rhs =: \(rhs, g, srt, off) -> - (StgNonRec binder rhs, g, srt, off) + do_bind (off,srt) (bndr,rhs) + = srtRhs off rhs =: \(rhs', srt', off') -> + ((off', srt'++srt), (bndr, rhs')) -srtBind cont_refs off (StgRec binds) = - (StgRec new_binds, g, srt, new_off) - where - -- process each binding - (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off [] - - doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off) - doBinds ((binder,rhs):binds) g srt off new_binds = - srtRhs cont_refs off rhs =: \(rhs, g', srt', off) -> - doBinds binds (unionUniqSets g g') (srt'++srt) off - ((binder,rhs):new_binds) + (srt_info, this_srt, body_off) + = constructSRT rhss_cafs rhss_srt off rhss_off \end{code} ----------------------------------------------------------------------------- Right Hand Sides \begin{code} -srtRhs :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int) +srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset) -srtRhs cont off (StgRhsClosure cc bi old_srt free_vars u args body) = - srtExpr cont off body =: \(body, g, srt, off) -> - (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off) +srtRhs off (StgRhsClosure cc bi free_vars u args body) + = srtExpr off body =: \(body, srt, off) -> + (StgRhsClosure cc bi free_vars u args body, srt, off) -srtRhs cont off e@(StgRhsCon cc con args) = - (e, getGlobalRefs args, [], off) +srtRhs off e@(StgRhsCon cc con args) = (e, [], off) \end{code} ----------------------------------------------------------------------------- Expressions \begin{code} -srtExpr :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int) - -srtExpr (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off) - where global_refs = - cont `unionUniqSets` - getGlobalRefs (StgVarArg f:args) `unionUniqSets` - lookupPossibleLNE lne f - -srtExpr (cont,lne) off e@(StgLit l) = (e, cont, [], off) +srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset) -srtExpr (cont,lne) off e@(StgConApp con args) = - (e, cont `unionUniqSets` getGlobalRefs args, [], off) +srtExpr off e@(StgApp f args) = (e, [], off) +srtExpr off e@(StgLit l) = (e, [], off) +srtExpr off e@(StgConApp con args) = (e, [], off) +srtExpr off e@(StgPrimApp op args ty) = (e, [], off) -srtExpr (cont,lne) off e@(StgPrimApp op args ty) = - (e, cont `unionUniqSets` getGlobalRefs args, [], off) +srtExpr off (StgSCC cc expr) = + srtExpr off expr =: \(expr, srt, off) -> + (StgSCC cc expr, srt, off) -srtExpr c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) = - srtCaseAlts c off alts =: \(alts, alts_g, alts_srt, alts_off) -> - - -- construct the SRT for this case - let (this_srt, scrut_off) = construct_srt alts_g alts_srt alts_off in - - -- global refs in the continuation is alts_g. - srtExpr (alts_g,lne) scrut_off scrut - =: \(scrut, scrut_g, scrut_srt, case_off) -> +srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts) + = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) -> let - g = unionUniqSets alts_g scrut_g - srt = scrut_srt ++ this_srt - srt_info = case length this_srt of - 0 -> NoSRT - len -> SRT off len + (srt_info, this_srt, scrut_off) + = constructSRT cafs_in_alts alts_srt off alts_off in - (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off) - -srtExpr cont off (StgLet bind body) = - srtLet cont off bind body StgLet (\_ cont -> cont) - -srtExpr cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body) - = srtLet cont off b body (StgLetNoEscape live1 live2) calc_cont - where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g) - --- for recursive let-no-escapes, we do *two* passes, the first time --- just to extract the list of global refs, and the second time we actually --- construct the SRT now that we know what global refs should be in --- the various let-no-escape continuations. -srtExpr conts@(cont,lne) off - (StgLetNoEscape live1 live2 bind@(StgRec pairs) body) - = srtBind conts off bind =: \(_, g, _, _) -> - let - lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ] - calc_cont _ conts = conts - in - srtLet (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont - - -srtExpr cont off (StgSCC cc expr) = - srtExpr cont off expr =: \(expr, g, srt, off) -> - (StgSCC cc expr, g, srt, off) + srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) -> + + (StgCase scrut live1 live2 uniq srt_info alts, + scrut_srt ++ this_srt, + case_off) + +srtExpr off (StgLet bind body) + = srtBind off bind =: \ (bind', bind_srt, body_off) -> + srtExpr body_off body =: \ (body', expr_srt, let_off) -> + (StgLet bind' body', expr_srt ++ bind_srt, let_off) + +srtExpr off (StgLetNoEscape live1 live2 bind body) + = srtBind off bind =: \ (bind', bind_srt, body_off) -> + srtExpr body_off body =: \ (body', expr_srt, let_off) -> + (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off) #ifdef DEBUG -srtExpr cont off expr = pprPanic "srtExpr" (ppr expr) -#else -srtExpr cont off expr = panic "srtExpr" +srtExpr off expr = pprPanic "srtExpr" (ppr expr) #endif \end{code} ----------------------------------------------------------------------------- -Let-expressions - -This is quite complicated stuff... - -\begin{code} -srtLet cont off bind body let_constr calc_cont - - -- If the bindings are all constructors, then we don't need to - -- buid an SRT at all... - | all_con_binds bind = - srtBind cont off bind =: \(bind, bind_g, bind_srt, off) -> - srtExpr cont off body =: \(body, body_g, body_srt, off) -> - let - g = unionUniqSets bind_g body_g - srt = body_srt ++ bind_srt - in - (let_constr bind body, g, srt, off) - - -- we have some closure bindings... - | otherwise = - - -- first, find the sub-SRTs in the binding - srtBind cont off bind =: \(bind, bind_g, bind_srt, bind_off) -> - - -- construct the SRT for this binding - let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in - - -- get the new continuation information (if a let-no-escape) - let new_cont = calc_cont bind_g cont in - - -- now find the SRTs in the body - srtExpr new_cont body_off body =: \(body, body_g, body_srt, let_off) -> - - let - -- union all the global references together - let_g = unionUniqSets bind_g body_g - - -- concatenate the sub-SRTs - let_srt = body_srt ++ this_srt - - -- attach the SRT info to the binding - bind' = attach_srt_bind bind off (length this_srt) - in - (let_constr bind' body, let_g, let_srt, let_off) -\end{code} - ------------------------------------------------------------------------------ Construct an SRT. Construct the SRT at this point from its sub-SRTs and any new global @@ -304,163 +170,57 @@ references which aren't already contained in one of the sub-SRTs (and which are "live"). \begin{code} -construct_srt global_refs sub_srt current_offset +constructSRT caf_refs sub_srt initial_offset current_offset = let - extra_refs = filter (`notElem` sub_srt) (uniqSetToList global_refs) - this_srt = extra_refs ++ sub_srt + extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs) + this_srt = extra_refs ++ sub_srt -- Add the length of the new entries to the -- current offset to get the next free offset in the global SRT. new_offset = current_offset + length extra_refs - in (this_srt, new_offset) -\end{code} - ------------------------------------------------------------------------------ -Case Alternatives - -\begin{code} -srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int) + srt_length = new_offset - initial_offset -srtCaseAlts cont off (StgAlgAlts t alts dflt) = - srtAlgAlts cont off alts [] emptyUniqSet [] - =: \(alts, alts_g, alts_srt, off) -> - srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) -> - let - g = unionUniqSets alts_g dflt_g - srt = dflt_srt ++ alts_srt - in - (StgAlgAlts t alts dflt, g, srt, off) - -srtCaseAlts cont off (StgPrimAlts t alts dflt) = - srtPrimAlts cont off alts [] emptyUniqSet [] - =: \(alts, alts_g, alts_srt, off) -> - srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) -> - let - g = unionUniqSets alts_g dflt_g - srt = dflt_srt ++ alts_srt - in - (StgPrimAlts t alts dflt, g, srt, off) + srt_info | srt_length == 0 = NoSRT + | otherwise = SRT initial_offset srt_length -srtAlgAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off) -srtAlgAlts cont off ((con,args,used,rhs):alts) new_alts g srt = - srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) -> - let - g' = unionUniqSets rhs_g g - srt' = rhs_srt ++ srt - in - srtAlgAlts cont off alts ((con,args,used,rhs) : new_alts) g' srt' - -srtPrimAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off) -srtPrimAlts cont off ((lit,rhs):alts) new_alts g srt = - srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) -> - let - g' = unionUniqSets rhs_g g - srt' = rhs_srt ++ srt - in - srtPrimAlts cont off alts ((lit,rhs) : new_alts) g' srt' - -srtDefault cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off) -srtDefault cont off (StgBindDefault rhs) = - srtExpr cont off rhs =: \(rhs, g, srt, off) -> - (StgBindDefault rhs, g, srt, off) + in ASSERT( srt_length == length this_srt ) + (srt_info, this_srt, new_offset) \end{code} ----------------------------------------------------------------------------- - -Here we decide which Id's to place in the static reference table. An -internal top-level id will be in the environment with the appropriate -CafInfo, so we use that if available. An imported top-level Id will -have the CafInfo attached. Otherwise, we just ignore the Id. +Case Alternatives \begin{code} -getGlobalRefs :: [StgArg] -> UniqSet Id -getGlobalRefs args = mkUniqSet (concat (map globalRefArg args)) - -globalRefArg :: StgArg -> [Id] -globalRefArg (StgVarArg id) - | idMayHaveCafRefs id = [id] - | otherwise = [] -globalRefArg _ = [] - -idMayHaveCafRefs id = mayHaveCafRefs (idCafInfo id) +srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset) + +srtCaseAlts off (StgAlgAlts t alts dflt) + = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') -> + mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') -> + (StgAlgAlts t alts' dflt', alts_srt, alts_off) + +srtCaseAlts off (StgPrimAlts t alts dflt) + = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') -> + mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') -> + (StgPrimAlts t alts' dflt', alts_srt, alts_off) + +srtAlgAlt (off,srt) (con,args,used,rhs) + = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) -> + ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs')) + +srtPrimAlt (off,srt) (lit,rhs) + = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) -> + ((rhs_off, rhs_srt ++ srt), (lit, rhs')) + +srtDefault off StgNoDefault + = ((off,[]), StgNoDefault) +srtDefault off (StgBindDefault rhs) + = srtExpr off rhs =: \(rhs', srt, off) -> + ((off,srt), StgBindDefault rhs') \end{code} ----------------------------------------------------------------------------- Misc stuff \begin{code} -attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding -attach_srt_bind (StgNonRec binder rhs) off len = - StgNonRec binder (attach_srt_rhs rhs off len) -attach_srt_bind (StgRec binds) off len = - StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ] - -attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs -attach_srt_rhs (StgRhsCon cc con args) off length - = StgRhsCon cc con args -attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length - = StgRhsClosure cc bi srt free upd args rhs - where - srt | length == 0 = NoSRT - | otherwise = SRT off length - - -all_con_binds (StgNonRec x rhs) = con_rhs rhs -all_con_binds (StgRec bs) = all con_rhs (map snd bs) - -con_rhs (StgRhsCon _ _ _) = True -con_rhs _ = False - - a =: k = k a \end{code} - ------------------------------------------------------------------------------ -Fix up the SRT's in a let-no-escape. - -(for a description of let-no-escapes, see CgLetNoEscape.lhs) - -Here's the problem: a let-no-escape isn't represented by an activation -record on the stack. It seems either very difficult or impossible to -get the liveness bitmap right in the info table, so we don't do it -this way (the liveness mask isn't constant). - -So, the question is how does the garbage collector get access to the -SRT for the rhs of the let-no-escape? It can't see an info table, so -it must get the SRT from somewhere else. Here's an example: - - let-no-escape x = .... f .... - in case blah of - p -> .... x ... g .... - -(f and g are global). Suppose we garbage collect while evaluating -'blah'. The stack will contain an activation record for the case, -which will point to an SRT containing [g] (according to our SRT -algorithm above). But, since the case continuation can call x, and -hence f, the SRT should really be [f,g]. - -another example: - - let-no-escape {-rec-} z = \x -> case blah of - p1 -> .... f ... - p2 -> case blah2 of - p -> .... (z x') ... - in .... - -if we GC while evaluating blah2, then the case continuation on the -stack needs to refer to [f] in its SRT, because we can reach f by -calling z recursively. - -FIX: - -We keep track of the global references made by each let-no-escape in -scope, so we can expand them every time the let-no-escape is -referenced. - -\begin{code} -lookupPossibleLNE lne_env f = - case lookupUFM lne_env f of - Nothing -> emptyUniqSet - Just refs -> refs -\end{code} diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 7233ee9945..e0c71bb82e 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -84,16 +84,11 @@ stg2stg dflags module_name binds end_pass us2 "ProfMassage" collected_CCs binds3 end_pass us2 what ccs binds2 - = -- report verbosely, if required - (if dopt Opt_D_verbose_stg2stg dflags then - hPutStr stdout (showSDoc - (text ("*** "++what++":") $$ vcat (map ppr binds2) - )) - else return ()) >> - let - linted_binds = stg_linter what binds2 - in - return (linted_binds, us2, ccs) + = do -- report verbosely, if required + dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + (vcat (map ppr binds2)) + let linted_binds = stg_linter what binds2 + return (linted_binds, us2, ccs) -- return: processed binds -- UniqueSupply for the next guy to use -- cost-centres to be declared/registered (specialised) diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index fd5946a3fe..e958122ed9 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -117,10 +117,10 @@ statBinding :: Bool -- True <=> top-level; False <=> nested -> StgBinding -> StatEnv -statBinding top (StgNonRec b rhs) +statBinding top (StgNonRec _srt b rhs) = statRhs top (b, rhs) -statBinding top (StgRec pairs) +statBinding top (StgRec _srt pairs) = combineSEs (map (statRhs top) pairs) statRhs :: Bool -> (Id, StgRhs) -> StatEnv @@ -128,7 +128,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv statRhs top (b, StgRhsCon cc con args) = countOne (ConstructorBinds top) -statRhs top (b, StgRhsClosure cc bi srt fv u args body) +statRhs top (b, StgRhsClosure cc bi fv u args body) = statExpr body `combineSE` countN FreeVariables (length fv) `combineSE` countOne ( diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 4040280998..07054ff647 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,13 +12,12 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreFVs import CoreUtils -import SimplUtils import StgSyn import Type import TyCon ( isAlgTyCon ) +import Literal import Id import Var ( Var, globalIdDetails ) import IdInfo @@ -28,16 +27,17 @@ import VarSet import VarEnv import DataCon ( dataConWrapId ) import IdInfo ( OccInfo(..) ) -import PrimOp ( PrimOp(..), ccallMayGC ) import TysPrim ( foreignObjPrimTyCon ) -import Maybes ( maybeToBool, orElse ) -import Name ( getOccName, isExternallyVisibleName ) -import Module ( Module ) +import Maybes ( maybeToBool ) +import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) import CmdLineOpts ( DynFlags, opt_KeepStgTypes ) +import FastTypes hiding ( fastOr ) import Outputable +import List ( partition ) + infixr 9 `thenLne` \end{code} @@ -92,64 +92,125 @@ if @v@ is. %************************************************************************ %* * +\subsection[caf-info]{Collecting live CAF info} +%* * +%************************************************************************ + +In this pass we also collect information on which CAFs are live for +constructing SRTs (see SRT.lhs). + +A top-level Id has CafInfo, which is + + - MayHaveCafRefs, if it may refer indirectly to + one or more CAFs, or + - NoCafRefs if it definitely doesn't + +we collect the CafInfo first by analysing the original Core expression, and +also place this information in the environment. + +During CoreToStg, we then pin onto each binding and case expression, a +list of Ids which represents the "live" CAFs at that point. The meaning +of "live" here is the same as for live variables, see above (which is +why it's convenient to collect CAF information here rather than elsewhere). + +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. + +%************************************************************************ +%* * \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} %* * %************************************************************************ \begin{code} -coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding] -coreToStg dflags this_mod pgm - = return (fst (initLne (coreTopBindsToStg pgm))) +coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] +coreToStg dflags pgm + = return pgm' + where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr - = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr) - --- For top-level guys, we basically aren't worried about this --- live-variable stuff; we do need to keep adding to the environment --- as we step through the bindings (using @extendVarEnv@). - -coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo) - -coreTopBindsToStg [] = returnLne ([], emptyFVInfo) -coreTopBindsToStg (bind:binds) - = let - binders = bindersOf bind - env_extension = binders `zip` repeat how_bound - how_bound = LetrecBound True {- top level -} - emptyVarSet - in - - extendVarEnvLne env_extension ( - coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) -> - coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) -> - returnLne ( - (bind' : binds'), - binders `minusFVBinders` (fv_binds `unionFVInfo` fv_bind) - ) - ) + = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) + + +coreTopBindsToStg + :: IdEnv HowBound -- environment for the bindings + -> [CoreBind] + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) + +coreTopBindsToStg env [] = (env, emptyFVInfo, []) +coreTopBindsToStg env (b:bs) + = (env2, fvs1, b':bs') + where + -- env accumulates down the list of binds, fvs accumulates upwards + (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg env1 bs coreTopBindToStg - :: [Id] -- New binders (with correct arity) + :: IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind - -> LneM (StgBinding, FreeVarsInfo) + -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg [binder] body_fvs (NonRec _ rhs) - = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> - returnLne (StgNonRec binder rhs2, fvs) +coreTopBindToStg env body_fvs (NonRec id rhs) + = let + caf_info = hasCafRefs env rhs -coreTopBindToStg binders body_fvs (Rec pairs) - = fixLne (\ ~(_, rec_rhs_fvs) -> - let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs - in - mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs - `thenLne` \ (rhss2, fvss, _) -> - let fvs = unionFVInfos fvss - in - returnLne (StgRec (binders `zip` rhss2), fvs) - ) + env' = extendVarEnv env id (LetBound how_bound emptyVarSet) + + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs + + (stg_rhs, fvs', cafs) = + initLne env ( + coreToStgRhs body_fvs TopLevel (id,rhs) + `thenLne` \ (stg_rhs, fvs', _) -> + freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) -> + returnLne (stg_rhs, fvs', cafs) + ) + + bind = StgNonRec (SRTEntries cafs) id stg_rhs + in + ASSERT2(consistent caf_info bind, ppr id) +-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +coreTopBindToStg env body_fvs (Rec pairs) + = let + (binders, rhss) = unzip pairs + + -- to calculate caf_info, we initially map all the binders to + -- TopLevelNoCafs. + env1 = extendVarEnvList env + [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ] + + caf_info = hasCafRefss env1{-NB: not env'-} rhss + + env' = extendVarEnvList env + [ (b, LetBound how_bound emptyVarSet) | b <- binders ] + + how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs + | otherwise = TopLevelNoCafs + + (stg_rhss, fvs', cafs) + = 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) + ) + + bind = StgRec (SRTEntries cafs) (zip binders stg_rhss) + in + ASSERT2(consistent caf_info bind, ppr binders) +-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) + (env', fvs' `unionFVInfo` body_fvs, bind) + +-- assertion helper +consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind \end{code} \begin{code} @@ -166,11 +227,14 @@ coreToStgRhs scope_fv_info top (binder, rhs) where binder_info = lookupFVInfo scope_fv_info binder +bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr +bogus_expr = (StgLit (MachInt 1)) + mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) - = StgRhsClosure noCCS binder_info noSRT + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant bndrs body @@ -180,7 +244,7 @@ mkStgRhs top rhs_fvs binder_info (StgConApp con args) = StgRhsCon noCCS con args mkStgRhs top rhs_fvs binder_info rhs - = StgRhsClosure noCCS binder_info noSRT + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) (updatable [] rhs) [] rhs @@ -273,10 +337,10 @@ coreToStgExpr expr@(Lam _ _) set_of_args = mkVarSet args' fvs = args' `minusFVBinders` body_fvs escs = body_escs `minusVarSet` set_of_args + result_expr | null args' = body + | otherwise = StgLam (exprType expr) args' body in - if null args' - then returnLne (body, fvs, escs) - else returnLne (StgLam (exprType expr) args' body, fvs, escs) + returnLne (result_expr, fvs, escs) coreToStgExpr (Note (SCC cc) expr) = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> @@ -289,10 +353,9 @@ coreToStgExpr (Note other_note expr) -- Cases require a little more real work. coreToStgExpr (Case scrut bndr alts) - = getVarsLiveInCont `thenLne` \ live_in_cont -> - extendVarEnvLne [(bndr, CaseBound)] $ - vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> - lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> + = extendVarEnvLne [(bndr, CaseBound)] $ + vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) -> + freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) -> let -- determine whether the default binder is dead or not -- This helps the code generator to avoid generating an assignment @@ -301,41 +364,29 @@ coreToStgExpr (Case scrut bndr alts) then bndr else bndr `setIdOccInfo` IAmDead - -- for a _ccall_GC_, some of the *arguments* need to live across the - -- call (see findLiveArgs comments.), so we annotate them as being live - -- in the alts to achieve the desired effect. - mb_live_across_case = - case scrut of - -- ToDo: Notes? - e@(App _ _) | (v, args) <- myCollectArgs e, - PrimOpId (CCallOp ccall) <- globalIdDetails v, - ccallMayGC ccall - -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) - _ -> Nothing - -- 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 = orElse (FMAP unionVarSet mb_live_across_case) id $ - live_in_cont `unionVarSet` - (alts_lvs `minusVarSet` unitVarSet bndr) + live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr) in -- we tell the scrutinee that everything live in the alts -- is live in it, too. - setVarsLiveInCont live_in_alts ( - coreToStgExpr scrut - ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> - - lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> - let - live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs + setVarsLiveInCont (live_in_alts,alts_caf_refs) ( + coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) -> + returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs) + ) + `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) -> + + let srt = SRTEntries alts_caf_refs in returnLne ( - StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2, + 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 - -- 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. + -- 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 @@ -464,13 +515,12 @@ coreToStgApp -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) coreToStgApp maybe_thunk_body f args - = getVarsLiveInCont `thenLne` \ live_in_cont -> - coreToStgArgs args `thenLne` \ (args', args_fvs) -> + = coreToStgArgs args `thenLne` \ (args', args_fvs) -> lookupVarLne f `thenLne` \ how_bound -> let n_args = length args - not_letrec_bound = not (isLetrecBound how_bound) + not_letrec_bound = not (isLetBound how_bound) fun_fvs = singletonFVInfo f how_bound fun_occ -- Mostly, the arity info of a function is in the fn's IdInfo @@ -568,38 +618,28 @@ coreToStgLet -- is among the escaping vars coreToStgLet let_no_escape bind body - = fixLne (\ ~(_, _, _, rec_bind_lvs, _, 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 emptyVarSet) - (vars_bind rec_bind_lvs rec_body_fvs bind) - `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> - - -- The live variables of this binding are the ones which are live - -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs) - -- together with the live_in_cont ones - lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs) - `thenLne` \ lvs_from_fvs -> - let - bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont - in - - -- bind_fvs and bind_escs still include the binders of the let(rec) - -- but bind_lvs does not + setVarsLiveInCont (if let_no_escape + then live_in_cont + else (emptyVarSet,emptyVarSet)) + (vars_bind rec_body_fvs bind) + `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) -> -- Do the body extendVarEnvLne env_ext ( - coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) -> - lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> + freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) -> - returnLne (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) + ) - )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, - body2, body_fvs, body_escs, body_lvs) -> + ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) -> -- Compute the new let-expression @@ -653,7 +693,7 @@ coreToStgLet let_no_escape bind body Rec pairs -> map fst pairs mk_binding bind_lvs binder - = (binder, LetrecBound False -- Not top level + = (binder, LetBound NotTopLevelBound -- Not top level live_vars ) where @@ -662,40 +702,47 @@ coreToStgLet let_no_escape bind body else unitVarSet binder - vars_bind :: StgLiveVars - -> FreeVarsInfo -- Free var info for body of binding + vars_bind :: FreeVarsInfo -- Free var info for body of binding -> CoreBind -> LneM (StgBinding, - FreeVarsInfo, EscVarsSet, -- free vars; escapee vars - [(Id, HowBound)]) - -- extension to environment + FreeVarsInfo, + EscVarsSet, -- free vars; escapee vars + StgLiveVars, -- vars live in binding + [(Id, HowBound)]) -- extension to environment + - vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs) - = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs) - `thenLne` \ (rhs2, fvs, escs) -> - let - env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder - in - returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item]) + vars_bind body_fvs (NonRec binder rhs) + = coreToStgRhs body_fvs NotTopLevel (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, escs) -> - vars_bind rec_bind_lvs rec_body_fvs (Rec pairs) - = let - binders = map fst pairs - env_ext = map (mk_binding rec_bind_lvs) binders + freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) -> + let + env_ext_item@(binder', _) = mk_binding bind_lvs binder in - extendVarEnvLne env_ext ( - fixLne (\ ~(_, rec_rhs_fvs, _, _) -> - let - rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs - in - mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs + returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2, + bind_fvs, escs, bind_lvs, [env_ext_item]) + + + vars_bind body_fvs (Rec pairs) + = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, _) -> + let + rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + binders = map fst pairs + env_ext = map (mk_binding bind_lvs) binders + in + extendVarEnvLne env_ext ( + mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs `thenLne` \ (rhss2, fvss, escss) -> - let - fvs = unionFVInfos fvss - escs = unionVarSets escss - in - returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) - )) + let + bind_fvs = unionFVInfos fvss + escs = unionVarSets escss + in + freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) + `thenLne` \ (bind_lvs, bind_cafs) -> + returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2), + bind_fvs, escs, bind_lvs, env_ext) + ) + ) is_join_var :: Id -> Bool -- A hack (used only for compiler debuggging) to tell if @@ -710,23 +757,24 @@ is_join_var j = occNameUserString (getOccName j) == "$j" %************************************************************************ There's a lot of stuff to pass around, so we use this @LneM@ monad to -help. All the stuff here is only passed {\em down}. +help. All the stuff here is only passed *down*. \begin{code} type LneM a = IdEnv HowBound - -> StgLiveVars -- vars live in continuation + -> (StgLiveVars, -- vars live in continuation + IdSet) -- cafs live in continuation -> a data HowBound = ImportBound | CaseBound | LambdaBound - | LetrecBound - Bool -- True <=> bound at top level + | LetBound + TopLevelCafInfo StgLiveVars -- Live vars... see notes below -isLetrecBound (LetrecBound _ _) = True -isLetrecBound other = False +isLetBound (LetBound _ _) = True +isLetBound other = False \end{code} For a let(rec)-bound variable, x, we record StgLiveVars, the set of @@ -734,7 +782,7 @@ 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 LetrecBound constructor; x itself +and are therefore recorded in the LetBound constructor; x itself *is* included. The set of live variables is guaranteed ot have no further let-no-escaped @@ -742,8 +790,8 @@ variables in it. The std monad functions: \begin{code} -initLne :: LneM a -> a -initLne m = m emptyVarEnv emptyVarSet +initLne :: IdEnv HowBound -> LneM a -> a +initLne env m = m env (emptyVarSet,emptyVarSet) {-# INLINE thenLne #-} {-# INLINE returnLne #-} @@ -752,7 +800,7 @@ returnLne :: a -> LneM a returnLne e env lvs_cont = e thenLne :: LneM a -> (a -> LneM b) -> LneM b -thenLne m k env lvs_cont +thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont mapLne :: (a -> LneM b) -> [a] -> LneM [b] @@ -788,10 +836,10 @@ fixLne expr env lvs_cont Functions specific to this monad: \begin{code} -getVarsLiveInCont :: LneM StgLiveVars +getVarsLiveInCont :: LneM (StgLiveVars, IdSet) getVarsLiveInCont env lvs_cont = lvs_cont -setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a +setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a setVarsLiveInCont new_lvs_cont expr env lvs_cont = expr env new_lvs_cont @@ -811,22 +859,34 @@ lookupVarLne v env lvs_cont -- only ever tacked onto a decorated expression. It is never used as -- the basis of a control decision, which might give a black hole. -lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars - -lookupLiveVarsForSet fvs env lvs_cont - = returnLne (unionVarSets (map do_one (getFVs fvs))) - env lvs_cont +freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet) +freeVarsToLiveVars fvs env live_in_cont + = returnLne (lvs `unionVarSet` lvs_cont, + mkVarSet cafs `unionVarSet` cafs_cont) + env live_in_cont where + (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! + (local, global) = partition isLocalId (allFVs fvs) + + cafs = filter is_caf_one global + lvs = unionVarSets (map do_one local) + do_one v = if isLocalId v then case (lookupVarEnv env v) of - Just (LetrecBound _ lvs) -> extendVarSet lvs v - Just _ -> unitVarSet v - Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v) + Just (LetBound _ lvs) -> extendVarSet lvs v + Just _ -> unitVarSet v + Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) else emptyVarSet -\end{code} + is_caf_one v + = case lookupVarEnv env v of + Just (LetBound TopLevelHasCafs lvs) -> + ASSERT( isEmptyVarSet lvs ) True + Just (LetBound _ _) -> False + _otherwise -> mayHaveCafRefs (idCafInfo v) +\end{code} %************************************************************************ %* * @@ -835,7 +895,7 @@ lookupLiveVarsForSet fvs env lvs_cont %************************************************************************ \begin{code} -type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo) +type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, 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. @@ -844,11 +904,15 @@ type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo) -- noBinderInfo, since we aren't interested in their -- occurence info. -- - -- The Bool is True <=> the Id is top level letrec bound - -- -- 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} @@ -857,14 +921,18 @@ emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo -singletonFVInfo id ImportBound info = emptyVarEnv -singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info) -singletonFVInfo id other info = unitVarEnv id (id, False, info) +singletonFVInfo id ImportBound info + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info) + | otherwise = emptyVarEnv +singletonFVInfo id (LetBound top_level _) info + = unitVarEnv id (id, top_level, info) +singletonFVInfo id other info + = unitVarEnv id (id, NotTopLevelBound, info) tyvarFVInfo :: TyVarSet -> FreeVarsInfo tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs - where - add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo) + where + add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo) unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 @@ -895,8 +963,11 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info +allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs] + getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only -getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs] +getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs] getFVSet :: FreeVarsInfo -> IdSet getFVSet fvs = mkVarSet (getFVs fvs) @@ -937,3 +1008,126 @@ myCollectArgs expr go (Note n e) as = go e as go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} + +%************************************************************************ +%* * +\subsection{Figuring out CafInfo for an expression} +%* * +%************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +\begin{code} +hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo +-- Only called for the RHS of top-level lets +hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo + -- predicate returns True for a given Id if we look at this Id when + -- calculating the result. Used to *avoid* looking at the CafInfo + -- field for an Id that is part of the current recursive group. + +hasCafRefs p expr + | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs + | otherwise = NoCafRefs + + -- used for recursive groups. The whole group is set to + -- "MayHaveCafRefs" if at least one of the group is a CAF or + -- refers to any CAFs. +hasCafRefss p exprs + | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs + | otherwise = NoCafRefs + +-- cafRefs compiles to beautiful code :) + +cafRefs p (Var id) + | isLocalId id = fastBool False + | otherwise = + case lookupVarEnv p id of + Just (LetBound TopLevelHasCafs _) -> fastBool True + Just (LetBound _ _) -> fastBool False + Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids + +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 (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es + +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) + +isCAF :: CoreExpr -> Bool +-- Only called for the RHS of top-level lets +isCAF e = not (rhsIsNonUpd e) + {- ToDo: check type for onceness, i.e. non-updatable thunks? -} + + +rhsIsNonUpd :: CoreExpr -> Bool + -- True => Value-lambda, constructor, PAP + -- This is a bit like CoreUtils.exprIsValue, with the following differences: + -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) + -- + -- b) (C x xs), where C is a contructors is updatable if the application is + -- dynamic: see isDynConApp + -- + -- c) don't look through unfolding of f in (f x). I'm suspicious of this one + +rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e +rhsIsNonUpd (Note (SCC _) e) = False +rhsIsNonUpd (Note _ e) = rhsIsNonUpd e +rhsIsNonUpd other_expr + = go other_expr 0 [] + where + go (Var f) n_args args = idAppIsNonUpd f n_args args + + go (App f a) n_args args + | isTypeArg a = go f n_args args + | otherwise = go f (n_args + 1) (a:args) + + go (Note (SCC _) f) n_args args = False + go (Note _ f) n_args args = go f n_args args + + go other n_args args = False + +idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool +idAppIsNonUpd id n_val_args args + | Just con <- isDataConId_maybe id = not (isDynConApp con args) + | otherwise = n_val_args < idArity id + +isDynConApp :: DataCon -> [CoreExpr] -> Bool +isDynConApp con args = isDllName (dataConName con) || any isDynArg args +-- Top-level constructor applications can usually be allocated +-- statically, but they can't if +-- a) the constructor, or any of the arguments, come from another DLL +-- b) any of the arguments are LitLits +-- (because we can't refer to static labels in other DLLs). +-- If this happens we simply make the RHS into an updatable thunk, +-- and 'exectute' it rather than allocating it statically. +-- All this should match the decision in (see CoreToStg.coreToStgRhs) + + +isDynArg :: CoreExpr -> Bool +isDynArg (Var v) = isDllName (idName v) +isDynArg (Note _ e) = isDynArg e +isDynArg (Lit lit) = isLitLitLit lit +isDynArg (App e _) = isDynArg e -- must be a type app +isDynArg (Lam _ e) = isDynArg e -- must be a type lam +\end{code} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index bfae2959c1..0eda05d6e4 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -89,11 +89,11 @@ lintStgVar v = checkInScope v `thenL_` \begin{code} lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders -lintStgBinds (StgNonRec binder rhs) +lintStgBinds (StgNonRec _srt binder rhs) = lint_binds_help (binder,rhs) `thenL_` returnL [binder] -lintStgBinds (StgRec pairs) +lintStgBinds (StgRec _srt pairs) = addInScopeVars binders ( mapL lint_binds_help pairs `thenL_` returnL binders @@ -127,10 +127,10 @@ lint_binds_help (binder, rhs) \begin{code} lintStgRhs :: StgRhs -> LintM (Maybe Type) -lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ _ [] expr) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ _ binders expr) = addLoc (LambdaBodyOf binders) ( addInScopeVars binders ( lintStgExpr expr `thenMaybeL` \ body_ty -> diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index e0efc58eae..633d5beabc 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -30,10 +30,12 @@ module StgSyn ( -- SRTs SRT(..), noSRT, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, - getArgPrimRep, pprStgAlts, + -- utils + stgBindHasCafRefs, stgRhsArity, getArgPrimRep, isLitLitArg, isDllConApp, isStgTypeArg, - stgArity, stgArgType + stgArgType, stgBinders, + + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts #ifdef DEBUG , pprStgLVs @@ -43,6 +45,7 @@ module StgSyn ( #include "HsVersions.h" import CostCentre ( CostCentreStack, CostCentre ) +import VarSet ( IdSet, isEmptyVarSet ) import Id ( Id, idName, idPrimRep, idType ) import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) @@ -52,6 +55,7 @@ import Outputable import Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) +import CmdLineOpts ( opt_SccProfilingOn ) \end{code} %************************************************************************ @@ -65,10 +69,16 @@ are the boring things [except note the @GenStgRhs@], parameterised with respect to binder and occurrence information (just as in @CoreSyn@): +There is one SRT for each group of bindings. + \begin{code} data GenStgBinding bndr occ - = StgNonRec bndr (GenStgRhs bndr occ) - | StgRec [(bndr, GenStgRhs bndr occ)] + = StgNonRec SRT bndr (GenStgRhs bndr occ) + | StgRec SRT [(bndr, GenStgRhs bndr occ)] + +stgBinders :: GenStgBinding bndr occ -> [bndr] +stgBinders (StgNonRec _ b _) = [b] +stgBinders (StgRec _ bs) = map fst bs \end{code} %************************************************************************ @@ -348,10 +358,9 @@ data GenStgRhs bndr occ = StgRhsClosure CostCentreStack -- CCS to be attached (default is CurrentCCS) StgBinderInfo -- Info about how this binder is used (see below) - SRT -- The closures's SRT [occ] -- non-global free vars; a list, rather than -- a set, because order is important - UpdateFlag -- ReEntrant | Updatable | SingleEntry + !UpdateFlag -- ReEntrant | Updatable | SingleEntry [bndr] -- arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr bndr occ) -- body @@ -380,6 +389,23 @@ The second flavour of right-hand-side is for constructors (simple but important) [GenStgArg occ] -- args \end{code} +\begin{code} +stgRhsArity :: GenStgRhs bndr occ -> Int +stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args +stgRhsArity (StgRhsCon _ _ _) = 0 +\end{code} + +\begin{code} +stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool +stgBindHasCafRefs (StgNonRec srt _ rhs) + = nonEmptySRT srt || rhsIsUpdatable rhs +stgBindHasCafRefs (StgRec srt binds) + = nonEmptySRT srt || any rhsIsUpdatable (map snd binds) + +rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd +rhsIsUpdatable _ = False +\end{code} + Here's the @StgBinderInfo@ type, and its combining op: \begin{code} data StgBinderInfo @@ -515,14 +541,23 @@ There is one SRT per top-level function group. Each local binding and case expression within this binding group has a subrange of the whole SRT, expressed as an offset and length. +In CoreToStg we collect the list of CafRefs at each SRT site, which is later +converted into the length and offset form by the SRT pass. + \begin{code} data SRT = NoSRT - | SRT !Int{-offset-} !Int{-length-} + | SRTEntries IdSet -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs noSRT :: SRT noSRT = NoSRT +nonEmptySRT NoSRT = False +nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs) +nonEmptySRT _ = True + pprSRT (NoSRT) = ptext SLIT("_no_srt_") +pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len) \end{code} @@ -539,13 +574,14 @@ hoping he likes terminators instead... Ditto for case alternatives. pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc -pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [ppr bndr, equals]) - 4 ((<>) (ppr rhs) semi) +pprGenStgBinding (StgNonRec srt bndr rhs) + = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr rhs) semi) -pprGenStgBinding (StgRec pairs) +pprGenStgBinding (StgRec srt pairs) = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : - (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) + pprMaybeSRT srt : + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where ppr_bind (bndr, expr) = hang (hsep [ppr bndr, equals]) @@ -627,7 +663,8 @@ pprStgExpr (StgLam _ bndrs body) -- -- Very special! Suspicious! (SLPJ) -pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs)) +{- +pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) = ($$) (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "), @@ -638,12 +675,14 @@ pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag a interppSP args, char ']']) 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]])) (ppr expr) +-} -- special case: let ... in let ... pprStgExpr (StgLet bind expr@(StgLet _ _)) = ($$) - (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])]) + (sep [hang (ptext SLIT("let {")) + 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])]) (ppr expr) -- general case @@ -724,20 +763,18 @@ pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func [])) +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) = hcat [ ppr cc, pp_binder_info bi, - pprMaybeSRT srt, brackets (ifPprDebug (ppr free_var)), ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ] -- general case -pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body) - = hang (hcat [ppr cc, +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) + = hang (hsep [if opt_SccProfilingOn then ppr cc else empty, pp_binder_info bi, - pprMaybeSRT srt, - brackets (ifPprDebug (interppSP free_vars)), - ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)]) + ifPprDebug (brackets (interppSP free_vars)), + char '\\' <> ppr upd_flag, brackets (interppSP args)]) 4 (ppr body) pprStgRhs (StgRhsCon cc con args) @@ -745,15 +782,5 @@ pprStgRhs (StgRhsCon cc con args) space, ppr con, ptext SLIT("! "), brackets (interppSP args)] pprMaybeSRT (NoSRT) = empty -pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt -\end{code} - -Collect @IdInfo@ stuff that is most easily just snaffled straight -from the STG bindings. - -\begin{code} -stgArity :: StgRhs -> Int - -stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied -stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args +pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 8ffe3c3b53..b922e62852 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -79,12 +79,19 @@ tcInterfaceSigs unf_env mod decls \begin{code} tcIdInfo unf_env in_scope_vars name ty info_ins - = foldlTc tcPrag vanillaIdInfo info_ins + = foldlTc tcPrag init_info info_ins where - tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) + -- set the CgInfo to something sensible but uninformative before + -- we start, because the default CgInfo is a panic. + init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo + tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) + tcPrag info (HsArity arity) = + returnTc (info `setArityInfo` (ArityExactly arity) + `setCgArity` arity) + tcPrag info (HsUnfold inline_prag expr) = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> let @@ -101,35 +108,34 @@ tcIdInfo unf_env in_scope_vars name ty info_ins tcPrag info (HsStrictness strict_info) = returnTc (info `setStrictnessInfo` strict_info) - tcPrag info (HsWorker nm) - = tcWorkerInfo unf_env ty info nm + tcPrag info (HsWorker nm arity) + = tcWorkerInfo unf_env ty info nm arity \end{code} \begin{code} -tcWorkerInfo unf_env ty info worker_name - | not (hasArity arity_info) - = pprPanic "Worker with no arity info" (ppr worker_name) - - | otherwise +tcWorkerInfo unf_env ty info worker_name arity = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! info' = case tcLookupRecId_maybe unf_env worker_name of - Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) - `setWorkerInfo` HasWorker worker_id arity + Just worker_id -> + info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) + `setWorkerInfo` HasWorker worker_id arity - Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info + Nothing -> pprTrace "tcWorkerInfo failed:" + (ppr worker_name) info in returnTc info' where - -- We are relying here on arity, cpr and strictness info always appearing + -- We are relying here on cpr and strictness info always appearing -- before worker info, fingers crossed .... - arity_info = arityInfo info - arity = arityLowerBound arity_info cpr_info = cprInfo info - (demands, res_bot) = case strictnessInfo info of - StrictnessInfo d r -> (d,r) - _ -> (take arity (repeat wwLazy),False) -- Noncommittal + + (demands, res_bot) + = case strictnessInfo info of + StrictnessInfo d r -> (d,r) + _ -> (take arity (repeat wwLazy),False) + -- Noncommittal \end{code} For unfoldings we try to do the job lazily, so that we never type check diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index da2b7d86ec..44fd27a757 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -31,7 +31,7 @@ import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon ) -import IdInfo ( noCafOrTyGenIdInfo, setUnfoldingInfo ) +import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo ) import CoreUnfold ( mkTopUnfolding ) import Unique ( mkBuiltinUnique ) @@ -258,8 +258,8 @@ mkTyConGenInfo tycon [from_name, to_name] tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c tyvar_tys = mkTyVarTys tyvars - from_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - to_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn + to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) |