From: simonpj Date: Mon, 9 Mar 1998 17:27:04 +0000 (+0000) Subject: [project @ 1998-03-09 17:26:31 by simonpj] X-Git-Tag: Approx_2487_patches~881 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=996573cd62a9dab5b3a7f7ab85567507422601bb;p=ghc-hetmet.git [project @ 1998-03-09 17:26:31 by simonpj] New specialiser again; I think the simpifier is OK --- diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 31ca5b6..85c5640 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -45,7 +45,7 @@ module IdInfo ( import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding ) -import {-# SOURCE #-} CoreSyn ( SimplifiableCoreExpr ) +import {-# SOURCE #-} CoreSyn ( CoreExpr ) -- for mkdependHS, CoreSyn.hi-boot refers to it: import BinderInfo ( BinderInfo ) @@ -198,7 +198,7 @@ ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), A @IdSpecEnv@ holds details of an @Id@'s specialisations. \begin{code} -type IdSpecEnv = SpecEnv SimplifiableCoreExpr +type IdSpecEnv = SpecEnv CoreExpr \end{code} For example, if \tr{f}'s @SpecEnv@ contains the mapping: diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot b/ghc/compiler/coreSyn/CoreSyn.hi-boot index 7d543d8..c49a4c4 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot @@ -1,9 +1,9 @@ _interface_ CoreSyn 1 _exports_ -CoreSyn SimplifiableCoreExpr ; +CoreSyn CoreExpr ; _declarations_ -- Needed by IdInfo -1 type SimplifiableCoreExpr = GenCoreExpr (Id!Id, BinderInfo.BinderInfo) Id!Id BasicTypes.Unused ; +1 type CoreExpr = GenCoreExpr Id!Id Id!Id BasicTypes.Unused ; 1 data GenCoreExpr a b c ; diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index eea46d1..8a1cb92 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -313,11 +313,15 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr = nukeScrutDiscount (size_up rhs) `addSize` size_up body + `addSizeN` + 1 -- For the allocation size_up (Let (Rec pairs) body) = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]) `addSize` size_up body + `addSizeN` + length pairs -- For the allocation size_up (Case scrut alts) = nukeScrutDiscount (size_up scrut) @@ -451,19 +455,21 @@ is more accurate (see @sizeExpr@ above for how this discount size is computed). \begin{code} -smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments +smallEnoughToInline :: Id -- The function (for trace msg only) + -> [Bool] -- Evaluated-ness of value arguments -> Bool -- Result is scrutinised -> UnfoldingGuidance -> Bool -- True => unfold it -smallEnoughToInline _ _ UnfoldAlways = True -smallEnoughToInline _ _ UnfoldNever = False -smallEnoughToInline arg_is_evald_s result_is_scruted +smallEnoughToInline _ _ _ UnfoldAlways = True +smallEnoughToInline _ _ _ UnfoldNever = False +smallEnoughToInline id arg_is_evald_s result_is_scruted (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount) = if enough_args n_vals_wanted arg_is_evald_s && size - discount <= opt_UnfoldingUseThreshold then - pprTrace "small enough" (int size <+> int discount) True + -- pprTrace "small enough" (ppr id <+> int size <+> int discount) + True else False where @@ -486,8 +492,8 @@ smallEnoughToInline arg_is_evald_s result_is_scruted | otherwise = 0 arg_discount no_of_constrs is_evald - | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount - | otherwise = 1 + | is_evald = no_of_constrs * opt_UnfoldingConDiscount + | otherwise = 0 \end{code} We use this one to avoid exporting inlinings that we ``couldn't possibly @@ -495,12 +501,11 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} ---UNUSED? -couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool -couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance +couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance -certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool -certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance +certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool +certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance \end{code} Predicates diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 9eeadaf..ca2f4e6 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -10,7 +10,8 @@ \begin{code} module PprCore ( pprCoreExpr, pprIfaceUnfolding, - pprCoreBinding, pprCoreBindings + pprCoreBinding, pprCoreBindings, + pprGenericBindings ) where #include "HsVersions.h" @@ -50,14 +51,70 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. +Un-annotated core dumps +~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprCoreBinding :: CoreBinding -> SDoc pprCoreBindings :: [CoreBinding] -> SDoc +pprCoreBinding :: CoreBinding -> SDoc +pprCoreExpr :: CoreExpr -> SDoc + +pprCoreBindings = pprTopBinds pprCoreEnv +pprCoreBinding = pprTopBind pprCoreEnv +pprCoreExpr = ppr_expr pprCoreEnv + +pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr +\end{code} + +Printer for unfoldings in interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +pprIfaceUnfolding :: CoreExpr -> SDoc +pprIfaceUnfolding = ppr_expr pprIfaceEnv + +pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr +\end{code} + +Generic Core (possibly annotated binders etc) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc +pprGenericBindings = pprTopBinds pprGenericEnv + +pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ +pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr + +pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ +pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where + ppr bind = ppr_bind pprGenericEnv bind + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where + ppr expr = ppr_expr pprGenericEnv expr + +instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where + ppr arg = ppr_arg pprGenericArgEnv arg + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where + ppr alts = ppr_alts pprGenericEnv alts + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where + ppr deflt = ppr_default pprGenericEnv deflt +\end{code} + +%************************************************************************ +%* * +\subsection{Instance declarations for Core printing} +%* * +%************************************************************************ + + +\begin{code} init_ppr_env tvbndr pbdr pocc = initPprEnv (Just ppr) -- literals - (Just ppr_con) -- data cons + (Just ppr) -- data cons (Just ppr_prim) -- primops (Just (\ cc -> text (showCostCentre True cc))) @@ -68,20 +125,6 @@ init_ppr_env tvbndr pbdr pocc (Just pbdr) (Just pocc) -- value vars where - ppr_con con = ppr con - -{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] - [We can't treat them as ordinary applications because the Con doesn't have - dictionaries in it, whereas the constructor Id does.] - - OLD VERSION: - -- ppr_con is used when printing Con expressions; we add a "!" - -- to distinguish them from ordinary applications. But not when - -- printing for interfaces, where they are treated as ordinary applications - ppr_con con | ifaceStyle sty = ppr sty con - | otherwise = ppr sty con <> char '!' --} - -- We add a "!" to distinguish Primitive applications from ordinary applications. -- But not when printing for interfaces, where they are treated -- as ordinary applications @@ -90,74 +133,27 @@ init_ppr_env tvbndr pbdr pocc else ppr prim <> char '!') --------------- -pprCoreBindings binds = vcat (map pprCoreBinding binds) - -pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr) - -pprCoreBinding (Rec binds) - = vcat [ptext SLIT("Rec {"), - vcat (map ppr_binding binds), - ptext SLIT("end Rec }")] - -ppr_binding (binder, expr) - = sep [pprCoreBinder LetBind binder, - nest 2 (equals <+> pprCoreExpr expr)] -\end{code} - -General expression printer - -\begin{code} -pprCoreExpr :: CoreExpr -> SDoc -pprCoreExpr = ppr_expr pprCoreEnv - -pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr -\end{code} - -Printer for unfoldings in interfaces - -\begin{code} -pprIfaceUnfolding :: CoreExpr -> SDoc -pprIfaceUnfolding = ppr_expr pprIfaceEnv - -pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr \end{code} %************************************************************************ %* * -\subsection{Instance declarations for Core printing} +\subsection{The guts} %* * %************************************************************************ \begin{code} -pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ -pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr - -pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ -pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr +pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) -instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where - ppr bind = ppr_bind pprGenEnv bind - -instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where - ppr expr = ppr_expr pprGenEnv expr - -instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where - ppr arg = ppr_arg pprGenArgEnv arg +pprTopBind pe (NonRec binder expr) + = sep [ppr_binding_pe pe (binder,expr)] $$ text "" -instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where - ppr alts = ppr_alts pprGenEnv alts - -instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where - ppr deflt = ppr_default pprGenEnv deflt +pprTopBind pe (Rec binds) + = vcat [ptext SLIT("Rec {"), + vcat (map (ppr_binding_pe pe) binds), + ptext SLIT("end Rec }"), + text ""] \end{code} -%************************************************************************ -%* * -\subsection{Workhorse routines (...????...)} -%* * -%************************************************************************ - \begin{code} ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr) ppr_bind pe (Rec binds) = vcat (map pp binds) diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 6737103..8a4b922 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -145,7 +145,7 @@ okToInline False small_enough (OneOcc _ NoDupDanger _ n_alts _) -- If the thing isn't a redex, there's no danger of duplicating work, -- so we can inline if it occurs once, or is small okToInline True small_enough occ_info - = small_enough || one_occ + = one_occ || small_enough where one_occ = case occ_info of OneOcc _ _ _ n_alts _ -> n_alts <= 1 diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index f5e2206..2d37a9d 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -22,13 +22,15 @@ import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) import CoreSyn import Digraph ( stronglyConnCompR, SCC(..) ) import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, + omitIfaceSigForId, idType, idUnique, Id, emptyIdSet, unionIdSets, mkIdSet, elementOfIdSet, addOneToIdSet, IdSet, - nullIdEnv, unitIdEnv, combineIdEnvs, + + IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs, delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, - mapIdEnv, lookupIdEnv, IdEnv + mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv ) import Specialise ( idSpecVars ) import Name ( isExported, isLocallyDefined ) @@ -44,116 +46,6 @@ import Outputable %************************************************************************ %* * -\subsection[OccurAnal-types]{Data types} -%* * -%************************************************************************ - -\begin{code} -data OccEnv = - OccEnv - Bool -- IgnoreINLINEPragma flag - -- False <=> OK to use INLINEPragma information - -- True <=> ignore INLINEPragma information - - (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting, - -- given the set of in-scope variables - - IdSet -- In-scope Ids - - -addNewCands :: OccEnv -> [Id] -> OccEnv -addNewCands (OccEnv ip ifun cands) ids - = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids) - -addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv ip ifun cands) id - = OccEnv ip ifun (addOneToIdSet cands id) - -isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv _ ifun cands) id = ifun id cands - -inlineMe :: OccEnv -> Id -> Bool -inlineMe env id - = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs - not ignore_inline_prag && - -} - idWantsToBeINLINEd id - - -type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage - -combineUsageDetails, combineAltsUsageDetails - :: UsageDetails -> UsageDetails -> UsageDetails - -combineUsageDetails usage1 usage2 - = combineIdEnvs addBinderInfo usage1 usage2 - -combineAltsUsageDetails usage1 usage2 - = combineIdEnvs orBinderInfo usage1 usage2 - -addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails -addOneOcc usage id info - = combineIdEnvs addBinderInfo usage (unitIdEnv id info) - -- ToDo: make this more efficient - -emptyDetails = (nullIdEnv :: UsageDetails) - -unitDetails id info = (unitIdEnv id info :: UsageDetails) - -tagBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [(Id,BinderInfo)]) -- Tagged binders - -tagBinders usage binders = - let - usage' = usage `delManyFromIdEnv` binders - uss = [ (binder, usage_of usage binder) | binder <- binders ] - in - if isNullIdEnv usage' then - (usage', uss) - else - (usage', uss) -{- - = (usage `delManyFromIdEnv` binders, - [ (binder, usage_of usage binder) | binder <- binders ] - ) --} -tagBinder :: UsageDetails -- Of scope - -> Id -- Binders - -> (UsageDetails, -- Details with binders removed - (Id,BinderInfo)) -- Tagged binders - -tagBinder usage binder = - let - usage' = usage `delOneFromIdEnv` binder - us = usage_of usage binder - cont = - if isNullIdEnv usage' then -- Bogus test to force evaluation. - (usage', (binder, us)) - else - (usage', (binder, us)) - in - if isDeadOcc us then -- Ditto - cont - else - cont - - -usage_of usage binder - | isExported binder - = noBinderInfo -- Visible-elsewhere things count as many - | otherwise - = case (lookupIdEnv usage binder) of - Nothing -> deadOccurrence - Just info -> info - -isNeeded env usage binder = not (isDeadOcc (usage_of usage binder)) -\end{code} - - -%************************************************************************ -%* * \subsection[OccurAnal-main]{Counting occurrences: main function} %* * %************************************************************************ @@ -168,38 +60,18 @@ occurAnalyseBinds occurAnalyseBinds binds simplifier_sw_chkr | opt_D_dump_occur_anal = pprTrace "OccurAnal:" - (vcat (map ppr_bind binds')) + (pprGenericBindings binds') binds' | otherwise = binds' where - (_, binds') = doo initial_env binds + (_, _, binds') = occAnalTop initial_env binds initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma) (\id in_scope -> isLocallyDefined id) -- Anything local is interesting emptyIdSet -- Not actually used - - doo env [] = (emptyDetails, []) - doo env (bind:binds) - = (final_usage, new_binds ++ the_rest) - where - new_env = env `addNewCands` (bindersOf bind) - (binds_usage, the_rest) = doo new_env binds - (final_usage, new_binds) = occAnalBind env bind binds_usage - - -- This really ought to be done properly by PprCore, but - -- it isn't. pprCoreBinding only works on Id binders, and - -- the general case is complicated by the fact that it has to work - -- for interface files too. Sigh - -ppr_bind bind@(NonRec binder expr) - = ppr bind - -ppr_bind bind@(Rec binds) - = vcat [ptext SLIT("Rec {"), - nest 2 (ppr bind), - ptext SLIT("end Rec }")] \end{code} + \begin{code} occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting -> CoreExpr @@ -220,6 +92,134 @@ occurAnalyseGlobalExpr expr snd (occurAnalyseExpr (\_ -> False) expr) \end{code} + +%************************************************************************ +%* * +\subsection{Top level stuff} +%* * +%************************************************************************ + +In @occAnalTop@ we do indirection-shorting. That is, if we have this: + + loc = + ... + exp = loc + +where exp is exported, and loc is not, then we replace it with this: + + loc = exp + exp = + ... + +Without this we never get rid of the exp = loc thing. +This save a gratuitous jump +(from \tr{x_exported} to \tr{x_local}), and makes strictness +information propagate better. +This used to happen in the final phase, but its tidier to do it here. + + +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might elminate a binding that's mentioned in the +unfolding for something. + + +\begin{code} +occAnalTop :: OccEnv -- What's in scope + -> [CoreBinding] + -> (IdEnv BinderInfo, -- Occurrence info + IdEnv Id, -- Indirection elimination info + [SimplifiableCoreBinding] + ) + +occAnalTop env [] = (emptyDetails, nullIdEnv, []) + +-- Special case for eliminating indirections +occAnalTop env (NonRec exported_id (Var local_id) : binds) + | isExported exported_id && -- Only if this is exported + + isLocallyDefined local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExported local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is + -- something like a constructor, whose + -- definition is implicitly exported and + -- which must not vanish. + -- To illustrate the preceding check consider + -- data T = MkT Int + -- mkT = MkT + -- f x = MkT (x+1) + -- Here, we'll make a local, non-exported, defn for MkT, and without the + -- above condition we'll transform it to: + -- mkT = \x. MkT [x] + -- f = \y. mkT (y+1) + -- This is bad because mkT will get the IdDetails of MkT, and won't + -- be exported. Also the code generator won't make a definition for + -- the MkT constructor. + -- Slightly gruesome, this. + + + not (maybeToBool (lookupIdEnv ind_env local_id)) + -- Only if not already substituted for + + = -- Aha! An indirection; let's eliminate it! + (scope_usage, ind_env', binds') + where + (scope_usage, ind_env, binds') = occAnalTop env binds + ind_env' = addOneToIdEnv ind_env local_id exported_id + +-- The normal case +occAnalTop env (bind : binds) + = (final_usage, ind_env, new_binds ++ binds') + where + new_env = env `addNewCands` (bindersOf bind) + (scope_usage, ind_env, binds') = occAnalTop new_env binds + (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage + + -- Deal with any indirections + zap_bind (NonRec bndr rhs) + | bndr `elemIdEnv` ind_env = Rec (zap (bndr,rhs)) + -- The Rec isn't strictly necessary, but it's convenient + zap_bind (Rec pairs) + | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs)) + + zap_bind bind = bind + + zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of + Nothing -> [pair] + Just exported_id -> [(bndr, Var exported_id), + (exported_id, rhs)] +\end{code} + + %************************************************************************ %* * \subsection[OccurAnal-main]{Counting occurrences: main function} @@ -514,7 +514,9 @@ occAnalRhs env id rhs where (rhs_usage, rhs') = occAnal env rhs total_usage = foldr add rhs_usage (idSpecVars id) - add v u = addOneOcc u v (argOccurrence 0) + add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info + -- (i.e manyOcc) because many copies + -- of the specialised thing can appear \end{code} Expressions @@ -686,3 +688,115 @@ occAnalArg env (VarArg v) | otherwise = emptyDetails occAnalArg _ _ = emptyDetails \end{code} + + +%************************************************************************ +%* * +\subsection[OccurAnal-types]{Data types} +%* * +%************************************************************************ + +\begin{code} +data OccEnv = + OccEnv + Bool -- IgnoreINLINEPragma flag + -- False <=> OK to use INLINEPragma information + -- True <=> ignore INLINEPragma information + + (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting, + -- given the set of in-scope variables + + IdSet -- In-scope Ids + + +addNewCands :: OccEnv -> [Id] -> OccEnv +addNewCands (OccEnv ip ifun cands) ids + = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids) + +addNewCand :: OccEnv -> Id -> OccEnv +addNewCand (OccEnv ip ifun cands) id + = OccEnv ip ifun (addOneToIdSet cands id) + +isCandidate :: OccEnv -> Id -> Bool +isCandidate (OccEnv _ ifun cands) id = ifun id cands + +inlineMe :: OccEnv -> Id -> Bool +inlineMe env id + = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs + not ignore_inline_prag && + -} + idWantsToBeINLINEd id + + +type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage + +combineUsageDetails, combineAltsUsageDetails + :: UsageDetails -> UsageDetails -> UsageDetails + +combineUsageDetails usage1 usage2 + = combineIdEnvs addBinderInfo usage1 usage2 + +combineAltsUsageDetails usage1 usage2 + = combineIdEnvs orBinderInfo usage1 usage2 + +addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails +addOneOcc usage id info + = combineIdEnvs addBinderInfo usage (unitIdEnv id info) + -- ToDo: make this more efficient + +emptyDetails = (nullIdEnv :: UsageDetails) + +unitDetails id info = (unitIdEnv id info :: UsageDetails) + +tagBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [(Id,BinderInfo)]) -- Tagged binders + +tagBinders usage binders = + let + usage' = usage `delManyFromIdEnv` binders + uss = [ (binder, usage_of usage binder) | binder <- binders ] + in + if isNullIdEnv usage' then + (usage', uss) + else + (usage', uss) +{- + = (usage `delManyFromIdEnv` binders, + [ (binder, usage_of usage binder) | binder <- binders ] + ) +-} +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + (Id,BinderInfo)) -- Tagged binders + +tagBinder usage binder = + let + usage' = usage `delOneFromIdEnv` binder + us = usage_of usage binder + cont = + if isNullIdEnv usage' then -- Bogus test to force evaluation. + (usage', (binder, us)) + else + (usage', (binder, us)) + in + if isDeadOcc us then -- Ditto + cont + else + cont + + +usage_of usage binder + | isExported binder + = noBinderInfo -- Visible-elsewhere things count as many + | otherwise + = case (lookupIdEnv usage binder) of + Nothing -> deadOccurrence + Just info -> info + +isNeeded env usage binder = not (isDeadOcc (usage_of usage binder)) +\end{code} + + diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 42a2405..e21e0f0 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -37,7 +37,7 @@ import Id ( mkSysLocal, mkUserId, setIdVisibility, replaceIdInfo, replacePragmaInfo, getIdDemandInfo, idType, getIdInfo, getPragmaInfo, mkIdWithNewUniq, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, IdEnv, omitIfaceSigForId, + lookupIdEnv, IdEnv, Id ) import IdInfo ( willBeDemanded, DemandInfo ) @@ -236,11 +236,13 @@ foldl_mn f z (x:xs) = f z x >>= \ zz -> Several tasks are done by @tidyCorePgm@ -1. Eliminate indirections. The point here is to transform - x_local = E - x_exported = x_local - ==> - x_exported = E +---------------- + [March 98] Indirections are now elimianted by the occurrence analyser + -- 1. Eliminate indirections. The point here is to transform + -- x_local = E + -- x_exported = x_local + -- ==> + -- x_exported = E 2. Make certain top-level bindings into Globals. The point is that Global things get externally-visible labels at code generation @@ -287,110 +289,15 @@ Several tasks are done by @tidyCorePgm@ generator makes global labels from the uniques for local thunks etc.] -Eliminate indirections -~~~~~~~~~~~~~~~~~~~~~~ -In @elimIndirections@, we look for things at the top-level of the form... -\begin{verbatim} - x_local = .... - x_exported = x_local -\end{verbatim} -In cases we find like this, we go {\em backwards} and replace -\tr{x_local} with \tr{x_exported}. This save a gratuitous jump -(from \tr{x_exported} to \tr{x_local}), and makes strictness -information propagate better. - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -There's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -General Strategy: first collect the info; then make a \tr{Id -> Id} mapping. -Then blast the whole program (LHSs as well as RHSs) with it. - \begin{code} tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding] tidyCorePgm mod binds_in - = initTM mod indirection_env $ - tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds -> + = initTM mod nullIdEnv $ + tidyTopBindings binds_in `thenTM` \ binds -> returnTM (bagToList binds) - where - (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in - - try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding) - try_bind env_so_far (NonRec exported_binder rhs) - | isExported exported_binder && -- Only if this is exported - maybeToBool maybe_rhs_id && -- and the RHS is a simple Id - - isLocallyDefined rhs_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExported rhs_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is - -- something like a constructor, whose - -- definition is implicitly exported and - -- which must not vanish. - -- To illustrate the preceding check consider - -- data T = MkT Int - -- mkT = MkT - -- f x = MkT (x+1) - -- Here, we'll make a local, non-exported, defn for MkT, and without the - -- above condition we'll transform it to: - -- mkT = \x. MkT [x] - -- f = \y. mkT (y+1) - -- This is bad because mkT will get the IdDetails of MkT, and won't - -- be exported. Also the code generator won't make a definition for - -- the MkT constructor. - -- Slightly gruesome, this. - - not (maybeToBool (lookupIdEnv env_so_far rhs_id)) - -- Only if not already substituted for - - = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing) - where - maybe_rhs_id = case etaCoreExpr rhs of - Var rhs_id -> Just rhs_id - other -> Nothing - Just rhs_id = maybe_rhs_id - new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id - `replacePragmaInfo` getPragmaInfo rhs_id - -- NB: we keep the Pragmas and IdInfo for the old rhs_id! - -- This is important; it might be marked "no-inline" by - -- the occurrence analyser (because it's recursive), and - -- we must not lose that information. - - try_bind env_so_far bind - = (env_so_far, Just bind) \end{code} Top level bindings diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 5e86269..9e59327 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -472,7 +472,8 @@ extendConApps con_apps id other_rhs = con_apps \end{code} \begin{code} -lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args +lookForConstructor env@(SimplEnv _ _ _ _ _ con_apps) (Con con args) + | switchIsSet env SimplReuseCon = case lookupFM con_apps (UCA con val_args) of Nothing -> Nothing @@ -485,6 +486,7 @@ lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args val_args = filter isValArg args -- Literals and Ids ty_args = [ty | TyArg ty <- args] -- Just types +lookForConstructor env other = Nothing \end{code} NB: In @lookForConstructor@ we used (before Apr 94) to have a special case @@ -590,7 +592,7 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps where new_out_id_env | okToInline (whnfOrBottom form) - (couldBeSmallEnoughToInline guidance) + (couldBeSmallEnoughToInline out_id guidance) occ_info = out_id_env_with_unfolding | otherwise diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 3799d5e..c3db663 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -30,6 +30,7 @@ import Id ( idType, getIdInfo, getIdUnfolding, elemIdEnv, isNullIdEnv, addOneToIdEnv ) import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv ) +import OccurAnal ( occurAnalyseGlobalExpr ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) import SimplEnv @@ -64,7 +65,7 @@ completeVar env var args result_ty | maybeToBool maybe_specialisation = tick SpecialisationDone `thenSmpl_` simplExpr (bindTyVars env spec_bindings) - spec_template + (occurAnalyseGlobalExpr spec_template) remaining_args result_ty @@ -87,7 +88,7 @@ completeVar env var args result_ty && ok_to_inline && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env) ) - = pprTrace "Unfolding" (ppr var) $ + = -- pprTrace "Unfolding" (ppr var) $ unfold var unf_env unf_template args result_ty @@ -135,7 +136,7 @@ completeVar env var args result_ty essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee ok_to_inline = okToInline (whnfOrBottom form) small_enough occ_info - small_enough = smallEnoughToInline arg_evals is_case_scrutinee guidance + small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance arg_evals = [is_evald arg | arg <- args, isValArg arg] is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 522a96c..2e7b083 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -24,7 +24,7 @@ import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, addIdArity, getIdArity, getIdDemandInfo, addIdDemandInfo ) -import Name ( isExported ) +import Name ( isExported, isLocallyDefined ) import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), atLeastArity, unknownArity ) import Literal ( isNoRepLit ) @@ -1021,47 +1021,53 @@ Because then we can't remove the x=y binding, in which case we have just made things worse, perhaps a lot worse. \begin{code} - -- Right hand sides that are constructors - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. completeNonRec env binder new_id new_rhs - | not (isExported new_id) -- Don't bother for exported things - -- because we won't be able to drop - -- its binding. - && maybeToBool maybe_atomic_rhs - = tick tick_type `thenSmpl_` + = returnSmpl (env', [NonRec b r | (b,r) <- binds]) + where + (env', binds) = completeBind env binder new_id new_rhs + + +completeBind :: SimplEnv + -> InBinder -> OutId -> OutExpr -- Id and RHS + -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s) + +completeBind env binder@(_,occ_info) new_id new_rhs + | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" + = (env, new_binds) + + | atomic_rhs -- If rhs (after eta reduction) is atomic + && not (isExported new_id) -- and binder isn't exported + = -- Drop the binding completely let - env1 = notInScope env new_id - env2 = bindIdToAtom env1 binder rhs_arg + env1 = notInScope env new_id + env2 = bindIdToAtom env1 binder the_arg in - returnSmpl (env2, []) - where - Just (rhs_arg, tick_type) = maybe_atomic_rhs - maybe_atomic_rhs - = -- Try first for an existing constructor application - case maybe_con new_rhs of { - Just con -> Just (VarArg con, ConReused); - - Nothing -> -- No good; try eta-reduction - case etaCoreExpr new_rhs of { - Var v -> Just (VarArg v, AtomicRhs); - Lit l -> Just (LitArg l, AtomicRhs); - - other -> Nothing -- Neither worked, so return Nothing - }} - + (env2, []) - maybe_con (Con con con_args) | switchIsSet env SimplReuseCon - = lookForConstructor env con con_args - maybe_con other_rhs = Nothing + | atomic_rhs -- Rhs is atomic, and new_id is exported + && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False } + = -- The local variable v will be eliminated next time round + -- in favour of new_id, so it's a waste to replace all new_id's with v's + -- this time round. + -- This case is an optional improvement; saves a simplifier iteration + (env, [(new_id, eta'd_rhs)]) -completeNonRec env binder@(id,occ_info) new_id new_rhs - = returnSmpl (new_env , [NonRec new_id new_rhs]) + | otherwise -- Non-atomic + = let + env1 = extendEnvGivenBinding env occ_info new_id new_rhs + in + (env1, new_binds) + where - new_env = extendEnvGivenBinding env occ_info new_id new_rhs + new_binds = [(new_id, new_rhs)] + atomic_rhs = is_atomic eta'd_rhs + eta'd_rhs = case lookForConstructor env new_rhs of + Just v -> Var v + other -> etaCoreExpr new_rhs + + the_arg = case eta'd_rhs of + Var v -> VarArg v + Lit l -> LitArg l \end{code} ---------------------------------------------------------------------------- @@ -1203,31 +1209,11 @@ simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs | otherwise = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) -> let - new_id' = new_id `withArity` arity - - -- ToDo: this next bit could usefully share code with completeNonRec - - new_env - | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline" - = env - - | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = let - env1 = notInScope env new_id - in - bindIdToAtom env1 binder the_arg - - | otherwise -- Non-atomic - = extendEnvGivenBinding env occ_info new_id new_rhs - -- Don't eta if it doesn't eliminate the binding - - eta'd_rhs = etaCoreExpr new_rhs - the_arg = case eta'd_rhs of - Var v -> VarArg v - Lit l -> LitArg l + new_id' = new_id `withArity` arity + (new_env, new_binds') = completeBind env binder new_id' new_rhs in simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) -> - returnSmpl ((new_id', new_rhs) : new_pairs, final_env) + returnSmpl (new_binds' ++ new_pairs, final_env) where ok_to_dup = switchIsSet env SimplOkToDupCode \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index aade3c4..cb5638c 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -32,7 +32,7 @@ import TyVar ( TyVar, TyVarEnv, mkTyVarEnv, delFromTyVarEnv ) import CoreSyn -import OccurAnal ( occurAnalyseGlobalExpr ) +import PprCore () -- Instances import Name ( NamedThing(..), getSrcLoc ) import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues ) @@ -1191,7 +1191,7 @@ addIdSpecialisations id spec_stuff (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff add (tyvars, tys, template) (spec_env, errs) - = case addToSpecEnv True spec_env tyvars tys (occurAnalyseGlobalExpr template) of + = case addToSpecEnv True spec_env tyvars tys template of Succeeded spec_env' -> (spec_env', errs) Failed err -> (spec_env, err:errs) @@ -1234,7 +1234,7 @@ substSpecEnvRhs te ve rhs where te' = delFromTyVarEnv te tyvar - go te ve (Lam b@(ValBinder (v,_)) e) = Lam b (go te ve' e) + go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e) where ve' = delOneFromIdEnv ve v diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index fbac09b..ebea69b 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -184,7 +184,7 @@ tryWW :: Id -- The fn binder -- if two, then a worker and a -- wrapper. tryWW fn_id rhs - | (certainlySmallEnoughToInline $ + | (certainlySmallEnoughToInline fn_id $ calcUnfoldingGuidance (getInlinePragma fn_id) opt_UnfoldingCreationThreshold rhs diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index cecc64a..1218e41 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -67,8 +67,9 @@ tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest) sig_id | any inline_please id_infos = addInlinePragma imp_id | otherwise = imp_id - inline_please (HsUnfold inline _) = inline - inline_please other = False + inline_please (HsUnfold inline _) = inline + inline_please (HsStrictness (HsStrictnessInfo _ (Just _))) = True -- Inline wrappers + inline_please other = False in returnTc sig_id )) `thenTc` \ sig_id ->