X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=622430d088e214370fce9e9ff0a2790cc957c4a4;hb=e1e1c4133f5627a570feae2e4ba3a9c584462401;hp=8054ae31aac00c61cd7d352974d06c6b7c83d5e3;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 8054ae3..622430d 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %************************************************************************ %* * @@ -7,88 +7,51 @@ %* * %************************************************************************ -The occurrence analyser analyses the way in which variables are used -in their scope, and pins that information on the binder. It does {\em -not} take any strategic decisions about what to do as a result (eg -discard binding, inline binding etc). That's the job of the -simplifier. - -The occurrence analyser {\em simply} records usage information. That is, -it pins on each binder info on how that binder occurs in its scope. - -Any uses within the RHS of a let(rec) binding for a variable which is -itself unused are ignored. For example: -@ - let x = ... - y = ...x... - in - x+1 -@ -Here, y is unused, so x will be marked as appearing just once. - -An exported Id gets tagged as ManyOcc. - -IT MUST OBSERVE SCOPING: CANNOT assume unique binders. - -Lambdas -~~~~~~~ -The occurrence analyser marks each binder in a lambda the same way. -Thus: - \ x y -> f y x -will have both x and y marked as single occurrence, and *not* dangerous-to-dup. -Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup, -but the simplifer very carefully takes care of this special case. -(See the CoLam case in simplExpr.) - -Why? Because typically applications are saturated, in which case x is *not* -dangerous-to-dup. - -Things to muse upon -~~~~~~~~~~~~~~~~~~~ - -There *is* a reason not to substitute for -variables applied to types: it can undo the effect of floating -Consider: -\begin{verbatim} - c = /\a -> e - f = /\b -> let d = c b - in \ x::b -> ... -\end{verbatim} -Here, inlining c would be a Bad Idea. - -At present I've set it up so that the "inside-lambda" flag sets set On for -type-lambdas too, which effectively prevents such substitutions. I don't *think* -it disables any interesting ones either. +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. \begin{code} #include "HsVersions.h" module OccurAnal ( - occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, - - -- and to make the interface self-sufficient... - CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch, - PlainCoreProgram(..), PlainCoreExpr(..), - SimplifiableCoreExpr(..), SimplifiableCoreBinding(..) + occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr ) where -IMPORT_Trace -import Outputable -- ToDo: rm; debugging -import Pretty +IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) -import PlainCore -- the stuff we read... -import TaggedCore -- ... and produce Simplifiable* - -import AbsUniType import BinderInfo -import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) ) -import Digraph ( stronglyConnComp ) -import Id ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe, - isSpecPragmaId_maybe, SpecInfo ) -import IdEnv -import Maybes -import UniqSet -import Util +import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) +import CoreSyn +import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) ) +import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, + idType, idUnique, SYN_IE(Id), + emptyIdSet, unionIdSets, mkIdSet, + unitIdSet, elementOfIdSet, + addOneToIdSet, SYN_IE(IdSet), + nullIdEnv, unitIdEnv, combineIdEnvs, + delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, + mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), + GenId{-instance Eq-} + ) +import Name ( isExported, isLocallyDefined ) +import Type ( getFunTy_maybe, splitForAllTy ) +import Maybes ( maybeToBool ) +import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} ) +import PprCore +import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) +import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text ) +import TyVar ( GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-}, u2i ) +import UniqFM ( keysUFM ) +import Util ( assoc, zipEqual, zipWithEqual, Ord3(..) + , pprTrace, panic +#ifdef DEBUG + , assertPanic +#endif + ) + +isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe" \end{code} @@ -99,51 +62,57 @@ import Util %************************************************************************ \begin{code} -data OccEnv = OccEnv - Bool -- Keep-unused-bindings flag - -- False <=> OK to chuck away binding - -- and ignore occurrences within it - Bool -- Keep-spec-pragma-ids flag - -- False <=> OK to chuck away spec pragma bindings - -- and ignore occurrences within it - Bool -- Keep-conjurable flag - -- False <=> OK to throw away *dead* - -- "conjurable" Ids; at the moment, that - -- *only* means constant methods, which - -- are top-level. A use of a "conjurable" - -- Id may appear out of thin air -- e.g., - -- specialiser conjuring up refs to const - -- methods. - Bool -- IgnoreINLINEPragma flag - -- False <=> OK to use INLINEPragma information - -- True <=> ignore INLINEPragma information - (UniqSet Id) -- Candidates +data OccEnv = + OccEnv + Bool -- Keep-unused-bindings flag + -- False <=> OK to chuck away binding + -- and ignore occurrences within it + Bool -- Keep-spec-pragma-ids flag + -- False <=> OK to chuck away spec pragma bindings + -- and ignore occurrences within it + Bool -- Keep-conjurable flag + -- False <=> OK to throw away *dead* + -- "conjurable" Ids; at the moment, that + -- *only* means constant methods, which + -- are top-level. A use of a "conjurable" + -- Id may appear out of thin air -- e.g., + -- specialiser conjuring up refs to const methods. + 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 keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids - = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids) +addNewCands (OccEnv kd ks kc ip ifun cands) ids + = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids) addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id - = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id) +addNewCand (OccEnv ks kd kc ip ifun cands) id + = OccEnv kd ks kc ip ifun (addOneToIdSet cands id) isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands +isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands -ignoreINLINEPragma :: OccEnv -> Bool -ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma +inlineMe :: OccEnv -> Id -> Bool +inlineMe env id + = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs + not ignore_inline_prag && + -} + idWantsToBeINLINEd id keepUnusedBinding :: OccEnv -> Id -> Bool -keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder - = keep_dead || (keep_spec && is_spec) - where - is_spec = maybeToBool (isSpecPragmaId_maybe binder) +keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder + = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder)) keepBecauseConjurable :: OccEnv -> Id -> Bool -keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder - = keep_conjurable && is_conjurable - where - is_conjurable = maybeToBool (isConstMethodId_maybe binder) +keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder + = False + {- keep_conjurable && isConstMethodId binder -} type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage @@ -151,52 +120,68 @@ combineUsageDetails, combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails combineUsageDetails usage1 usage2 - = --BSCC("combineUsages") - combineIdEnvs combineBinderInfo usage1 usage2 - --ESCC + = combineIdEnvs addBinderInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 - = --BSCC("combineUsages") - combineIdEnvs combineAltsBinderInfo usage1 usage2 - --ESCC + = combineIdEnvs orBinderInfo usage1 usage2 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails -addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info) +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 +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] + [ (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 + case us of { DeadCode -> cont; _ -> cont } + +-- (binder, usage_of usage binder) -tagBinder :: UsageDetails -- Of scope - -> Id -- Binders - -> (UsageDetails, -- Details with binders removed - (Id,BinderInfo)) -- Tagged binders - -tagBinder usage binder - = (usage `delOneFromIdEnv` binder, - (binder, usage_of usage binder) - ) usage_of usage binder - | isExported binder = ManyOcc 0 -- Exported things count as many + | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many | otherwise - = case lookupIdEnv usage binder of + = case (lookupIdEnv usage binder) of Nothing -> DeadCode Just info -> info isNeeded env usage binder - = case usage_of usage binder of + = case (usage_of usage binder) of DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway other -> True \end{code} @@ -212,54 +197,68 @@ Here's the externally-callable interface: \begin{code} occurAnalyseBinds - :: [PlainCoreBinding] -- input - -> (GlobalSwitch -> Bool) + :: [CoreBinding] -- input -> (SimplifierSwitch -> Bool) -> [SimplifiableCoreBinding] -- output -occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr - | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds' - | otherwise = binds' +occurAnalyseBinds binds simplifier_sw_chkr + | opt_D_dump_occur_anal = pprTrace "OccurAnal:" + (vcat (map ppr_bind binds')) + binds' + | otherwise = binds' where - (_, binds') = do initial_env binds + (_, binds') = doo initial_env binds initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings) (simplifier_sw_chkr KeepSpecPragmaIds) (not (simplifier_sw_chkr SimplMayDeleteConjurableIds)) (simplifier_sw_chkr IgnoreINLINEPragma) - emptyUniqSet + (\id in_scope -> isLocallyDefined id) -- Anything local is interesting + emptyIdSet -- Not actually used - do env [] = (emptyDetails, []) - do env (bind:binds) + doo env [] = (emptyDetails, []) + doo env (bind:binds) = (final_usage, new_binds ++ the_rest) where new_env = env `addNewCands` (bindersOf bind) - (binds_usage, the_rest) = do new_env binds - (final_usage, new_binds) = --BSCC("occAnalBind1") - occAnalBind env bind binds_usage - --ESCC + (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 PprDebug bind + +ppr_bind bind@(Rec binds) + = vcat [ptext SLIT("Rec {"), + nest 2 (ppr PprDebug bind), + ptext SLIT("end Rec }")] \end{code} \begin{code} -occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars - -> PlainCoreExpr - -> (IdEnv BinderInfo, -- Occ info for interesting free vars +occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting + -> CoreExpr + -> (IdEnv BinderInfo, -- Occ info for interesting free vars SimplifiableCoreExpr) -occurAnalyseExpr candidates expr +occurAnalyseExpr interesting expr = occAnal initial_env expr where initial_env = OccEnv False {- Drop unused bindings -} False {- Drop SpecPragmaId bindings -} True {- Keep conjurable Ids -} False {- Do not ignore INLINE Pragma -} - candidates + (\id locals -> interesting id || elementOfIdSet id locals) + emptyIdSet -occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr +occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr occurAnalyseGlobalExpr expr - = -- Top level expr, so no interesting free vars, and + = -- Top level expr, so no interesting free vars, and -- discard occurence info returned - expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr + snd (occurAnalyseExpr (\_ -> False) expr) \end{code} %************************************************************************ @@ -272,23 +271,30 @@ Bindings ~~~~~~~~ \begin{code} +type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +type Details1 = (Id, (UsageDetails, SimplifiableCoreExpr)) +type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr) + + occAnalBind :: OccEnv - -> PlainCoreBinding + -> CoreBinding -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [SimplifiableCoreBinding]) -occAnalBind env (CoNonRec binder rhs) body_usage +occAnalBind env (NonRec binder rhs) body_usage | isNeeded env body_usage binder -- It's mentioned in body = (final_body_usage `combineUsageDetails` rhs_usage, - [CoNonRec tagged_binder rhs']) + [NonRec tagged_binder rhs']) - | otherwise + | otherwise -- Not mentioned, so drop dead code = (body_usage, []) where - (rhs_usage, rhs') = occAnalRhs env binder rhs - (final_body_usage, tagged_binder) = tagBinder body_usage binder + binder' = nukeNoInlinePragma binder + (rhs_usage, rhs') = occAnalRhs env binder' rhs + (final_body_usage, tagged_binder) = tagBinder body_usage binder' \end{code} Dropping dead code for recursive bindings is done in a very simple way: @@ -298,9 +304,9 @@ Dropping dead code for recursive bindings is done in a very simple way: This seems to miss an obvious improvement. @ - letrec f = ...g... - g = ...f... - in + letrec f = ...g... + g = ...f... + in ...g... ===> @@ -327,69 +333,191 @@ It isn't easy to do a perfect job in one blow. Consider \begin{code} -occAnalBind env (CoRec pairs) body_usage - = foldr do_final_bind (body_usage, []) sccs +occAnalBind env (Rec pairs) body_usage + = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs where + pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))] + pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item] + pp_item (_, bndr, _) = ppr PprDebug bndr - (binders, rhss) = unzip pairs - new_env = env `addNewCands` binders - - analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))] - analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs] - - lookup :: Id -> (UsageDetails, SimplifiableCoreExpr) - lookup id = assoc "occAnalBind:lookup" analysed_pairs id + binders = map fst pairs + new_env = env `addNewCands` binders + analysed_pairs :: [Details1] + analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs] - ---- stuff for dependency analysis of binds ------------------------------- + sccs :: [SCC (Node Details1)] + sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges - edges :: [(Id,Id)] -- (a,b) means a mentions b - edges = concat [ edges_from binder rhs_usage - | (binder, (rhs_usage, _)) <- analysed_pairs] - edges_from :: Id -> UsageDetails -> [(Id,Id)] - edges_from id its_rhs_usage - = [(id,mentioned) | mentioned <- binders, - maybeToBool (lookupIdEnv its_rhs_usage mentioned) - ] - - sccs :: [[Id]] - sccs = case binders of - [_] -> [binders] -- Singleton; no need to analyse - other -> stronglyConnComp eqId edges binders + ---- stuff for dependency analysis of binds ------------------------------- + edges :: [Node Details1] + edges = _scc_ "occAnalBind.assoc" + [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage) + | pair@(id, (rhs_usage, rhs)) <- analysed_pairs + ] + + -- (a -> b) means a mentions b + -- Given the usage details (a UFM that gives occ info for each free var of + -- the RHS) we can get the list of free vars -- or rather their Int keys -- + -- by just extracting the keys from the finite map. Grimy, but fast. + -- Previously we had this: + -- [ bndr | bndr <- bndrs, + -- maybeToBool (lookupIdEnv rhs_usage bndr)] + -- which has n**2 cost, and this meant that edges_from alone + -- consumed 10% of total runtime! + edges_from :: UsageDetails -> [Int] + edges_from rhs_usage = _scc_ "occAnalBind.edges_from" + keysUFM rhs_usage ---- stuff to "re-constitute" bindings from dependency-analysis info ------ - do_final_bind sCC@[binder] (body_usage, binds_so_far) - | isNeeded env body_usage binder - = (combined_usage, new_bind:binds_so_far) - - | otherwise -- Dead - = (body_usage, binds_so_far) + -- Non-recursive SCC + do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far) + | isNeeded env body_usage bndr + = (combined_usage, new_bind : binds_so_far) + | otherwise + = (body_usage, binds_so_far) -- Dead code where - total_usage = combineUsageDetails body_usage rhs_usage - (rhs_usage, rhs') = lookup binder - (combined_usage, tagged_binder) = tagBinder total_usage binder - - new_bind - | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')] - | otherwise = CoNonRec tagged_binder rhs' - where - mentions_itself binder usage - = maybeToBool (lookupIdEnv usage binder) - - do_final_bind sCC (body_usage, binds_so_far) - | any (isNeeded env body_usage) sCC - = (combined_usage, new_bind:binds_so_far) - - | otherwise -- Dead - = (body_usage, binds_so_far) + total_usage = combineUsageDetails body_usage rhs_usage + (combined_usage, tagged_bndr) = tagBinder total_usage bndr + new_bind = NonRec tagged_bndr rhs' + + -- Recursive SCC + do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far) + | any (isNeeded env body_usage) bndrs + = (combined_usage, final_bind:binds_so_far) + | otherwise + = (body_usage, binds_so_far) -- Dead code where - (rhs_usages, rhss') = unzip (map lookup sCC) + pairs = [pair | (pair, _, _) <- cycle] + bndrs = [bndr | (bndr, _) <- pairs] + rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs] total_usage = foldr combineUsageDetails body_usage rhs_usages - (combined_usage, tagged_binders) = tagBinders total_usage sCC + (combined_usage, tagged_binders) = tagBinders total_usage bndrs + final_bind = Rec (reOrderRec env new_cycle) + + new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle) + mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys) +\end{code} + +@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic +strongly connected component (there's guaranteed to be a cycle). It returns the +same pairs, but + a) in a better order, + b) with some of the Ids having a IMustNotBeINLINEd pragma - new_bind = CoRec (tagged_binders `zip` rhss') +The "no-inline" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. + +Here's a case that bit me: + + letrec + a = b + b = \x. BIG + in + ...a...a...a.... + +Re-ordering doesn't change the order of bindings, but there was no loop-breaker. + +My solution was to make a=b bindings record b as Many, rather like INLINE bindings. +Perhaps something cleverer would suffice. + +You might think that you can prevent non-termination simply by making +sure that we simplify a recursive binding's RHS in an environment that +simply clones the recursive Id. But no. Consider + + letrec f = \x -> let z = f x' in ... + + in + let n = f y + in + case n of { ... } + +We bind n to its *simplified* RHS, we then *re-simplify* it when +we inline n. Then we may well inline f; and then the same thing +happens with z! + +I don't think it's possible to prevent non-termination by environment +manipulation in this way. Apart from anything else, successive +iterations of the simplifier may unroll recursive loops in cases like +that above. The idea of beaking every recursive loop with an +IMustNotBeINLINEd pragma is much much better. + + +\begin{code} +reOrderRec + :: OccEnv + -> SCC (Node Details2) + -> [Details2] + -- Sorted into a plausible order. Enough of the Ids have + -- dontINLINE pragmas that there are no loops left. + + -- Non-recursive case +reOrderRec env (AcyclicSCC (pair, _, _)) = [pair] + + -- Common case of simple self-recursion +reOrderRec env (CyclicSCC [bind]) + = [((addNoInlinePragma bndr, occ_info), rhs)] + where + (((bndr,occ_info), rhs), _, _) = bind + +reOrderRec env (CyclicSCC binds) + = -- Choose a loop breaker, mark it no-inline, + -- do SCC analysis on the rest, and recursively sort them out + concat (map (reOrderRec env) (stronglyConnCompR unchosen)) + ++ + [((addNoInlinePragma bndr, occ_info), rhs)] + + where + (chosen_pair, unchosen) = choose_loop_breaker binds + ((bndr,occ_info), rhs) = chosen_pair + + -- Choosing the loop breaker; heursitic + choose_loop_breaker (bind@(pair, _, _) : rest) + | not (null rest) && + bad_choice pair + = (chosen, bind : unchosen) -- Don't pick it + | otherwise -- Pick it + = (pair,rest) + where + (chosen, unchosen) = choose_loop_breaker rest + + bad_choice ((bndr, occ_info), rhs) + = var_rhs rhs -- Dont pick var RHS + || inlineMe env bndr -- Dont pick INLINE thing + || one_occ occ_info -- Dont pick single-occ thing + || not_fun_ty (idType bndr) -- Dont pick data-ty thing + + not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty)) + where + (_, rho_ty) = splitForAllTy ty + + -- A variable RHS + var_rhs (Var v) = True + var_rhs other_rhs = False + + -- One textual occurrence, whether inside lambda or whatever + -- We stick to just FunOccs because if we're not going to be able + -- to inline the thing on this round it might be better to pick + -- this one as the loop breaker. Real example (the Enum Ordering instance + -- from PrelBase): + -- rec f = \ x -> case d of (p,q,r) -> p x + -- g = \ x -> case d of (p,q,r) -> q x + -- d = (v, f, g) + -- + -- Here, f and g occur just once; but we can't inline them into d. + -- On the other hand we *could* simplify those case expressions if + -- we didn't stupidly choose d as the loop breaker. + + one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg + one_occ other_bind = False \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked @@ -399,14 +527,22 @@ inlined binder also occurs many times in its scope, but if it doesn't we'll catch it next time round. At worst this costs an extra simplifier pass. ToDo: try using the occurrence info for the inline'd binder. +[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec. + \begin{code} occAnalRhs :: OccEnv - -> Id -- Binder - -> PlainCoreExpr -- Rhs + -> Id -> CoreExpr -- Binder and rhs -> (UsageDetails, SimplifiableCoreExpr) +occAnalRhs env id (Var v) + | isCandidate env v + = (unitIdEnv v (markMany (funOccurrence 0)), Var v) + + | otherwise + = (emptyDetails, Var v) + occAnalRhs env id rhs - | idWantsToBeINLINEd id && not (ignoreINLINEPragma env) + | inlineMe env id = (mapIdEnv markMany rhs_usage, rhs') | otherwise @@ -420,74 +556,117 @@ Expressions ~~~~~~~~~~~ \begin{code} occAnal :: OccEnv - -> PlainCoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids SimplifiableCoreExpr) -occAnal env (CoVar v) +occAnal env (Var v) | isCandidate env v - = (unitIdEnv v (funOccurrence 0), CoVar v) + = (unitIdEnv v (funOccurrence 0), Var v) | otherwise - = (emptyDetails, CoVar v) + = (emptyDetails, Var v) + +occAnal env (Lit lit) = (emptyDetails, Lit lit) +occAnal env (Prim op args) = (occAnalArgs env args, Prim op args) +\end{code} + +We regard variables that occur as constructor arguments as "dangerousToDup": + +\begin{verbatim} +module A where +f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +\end{verbatim} + +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. -occAnal env (CoLit lit) = (emptyDetails, CoLit lit) -occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args) -occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args) +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. -occAnal env (CoSCC cc body) - = (mapIdEnv markInsideSCC usage, CoSCC cc body') +\begin{code} +occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args), + Con con args) + +occAnal env (SCC cc body) + = (mapIdEnv markInsideSCC usage, SCC cc body') where (usage, body') = occAnal env body -occAnal env (CoApp fun arg) - = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg) - where - (fun_usage, fun') = occAnal env fun - arg_usage = occAnalAtom env arg - -occAnal env (CoTyApp fun ty) - = (fun_usage, CoTyApp fun' ty) +occAnal env (Coerce c ty body) + = (usage, Coerce c ty body') where - (fun_usage, fun') = occAnal env fun + (usage, body') = occAnal env body -occAnal env (CoLam binders body) - = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body') +occAnal env (App fun arg) + = (fun_usage `combineUsageDetails` arg_usage, App fun' arg) + where + (fun_usage, fun') = occAnal env fun + arg_usage = occAnalArg env arg + +-- For value lambdas we do a special hack. Consider +-- (\x. \y. ...x...) +-- If we did nothing, x is used inside the \y, so would be marked +-- as dangerous to dup. But in the common case where the abstraction +-- is applied to two arguments this is over-pessimistic. +-- So instead we don't take account of the \y when dealing with x's usage; +-- instead, the simplifier is careful when partially applying lambdas + +occAnal env expr@(Lam (ValBinder binder) body) + = (mapIdEnv markDangerousToDup final_usage, + foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders) where - new_env = env `addNewCands` binders - (body_usage, body') = occAnal new_env body + (binders,body) = collectValBinders expr + (body_usage, body') = occAnal (env `addNewCands` binders) body (final_usage, tagged_binders) = tagBinders body_usage binders -- ANDY: WE MUST THINK ABOUT THIS! (ToDo) -occAnal env (CoTyLam tyvar body) - = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body') - where - (body_usage, body') = occAnal env body - -occAnal env (CoCase scrut alts) - = (scrut_usage `combineUsageDetails` alts_usage, - CoCase scrut' alts') +occAnal env (Lam (TyBinder tyvar) body) + = case occAnal env body of { (body_usage, body') -> + (mapIdEnv markDangerousToDup body_usage, + Lam (TyBinder tyvar) body') } +-- where +-- (body_usage, body') = occAnal env body + +occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder" + +occAnal env (Case scrut alts) + = case occAnalAlts env alts of { (alts_usage, alts') -> + case occAnal env scrut of { (scrut_usage, scrut') -> + let + det = scrut_usage `combineUsageDetails` alts_usage + in + if isNullIdEnv det then + (det, Case scrut' alts') + else + (det, Case scrut' alts') }} +{- + (scrut_usage `combineUsageDetails` alts_usage, + Case scrut' alts') where (scrut_usage, scrut') = occAnal env scrut (alts_usage, alts') = occAnalAlts env alts +-} -occAnal env (CoLet bind body) - = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh) +occAnal env (Let bind body) + = case occAnal new_env body of { (body_usage, body') -> + case occAnalBind env bind body_usage of { (final_usage, new_binds) -> + (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh) where new_env = env `addNewCands` (bindersOf bind) - (body_usage, body') = occAnal new_env body - (final_usage, new_binds) = --BSCC("occAnalBind2") - occAnalBind env bind body_usage - --ESCC +-- (body_usage, body') = occAnal new_env body +-- (final_usage, new_binds) = occAnalBind env bind body_usage \end{code} Case alternatives ~~~~~~~~~~~~~~~~~ \begin{code} -occAnalAlts env (CoAlgAlts alts deflt) +occAnalAlts env (AlgAlts alts deflt) = (foldr combineAltsUsageDetails deflt_usage alts_usage, -- Note: combine*Alts*UsageDetails... - CoAlgAlts alts' deflt') + AlgAlts alts' deflt') where (alts_usage, alts') = unzip (map do_alt alts) (deflt_usage, deflt') = occAnalDeflt env deflt @@ -499,10 +678,10 @@ occAnalAlts env (CoAlgAlts alts deflt) (rhs_usage, rhs') = occAnal new_env rhs (final_usage, tagged_args) = tagBinders rhs_usage args -occAnalAlts env (CoPrimAlts alts deflt) +occAnalAlts env (PrimAlts alts deflt) = (foldr combineAltsUsageDetails deflt_usage alts_usage, -- Note: combine*Alts*UsageDetails... - CoPrimAlts alts' deflt') + PrimAlts alts' deflt') where (alts_usage, alts') = unzip (map do_alt alts) (deflt_usage, deflt') = occAnalDeflt env deflt @@ -512,10 +691,10 @@ occAnalAlts env (CoPrimAlts alts deflt) where (rhs_usage, rhs') = occAnal env rhs -occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault) +occAnalDeflt env NoDefault = (emptyDetails, NoDefault) -occAnalDeflt env (CoBindDefault binder rhs) - = (final_usage, CoBindDefault tagged_binder rhs') +occAnalDeflt env (BindDefault binder rhs) + = (final_usage, BindDefault tagged_binder rhs') where new_env = env `addNewCand` binder (rhs_usage, rhs') = occAnal new_env rhs @@ -526,21 +705,21 @@ occAnalDeflt env (CoBindDefault binder rhs) Atoms ~~~~~ \begin{code} -occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails +occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails -occAnalAtoms env atoms +occAnalArgs env atoms = foldr do_one_atom emptyDetails atoms where - do_one_atom (CoLitAtom lit) usage = usage - do_one_atom (CoVarAtom v) usage + do_one_atom (VarArg v) usage | isCandidate env v = addOneOcc usage v (argOccurrence 0) - | otherwise = usage + | otherwise = usage + do_one_atom other_arg usage = usage -occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails +occAnalArg :: OccEnv -> CoreArg -> UsageDetails -occAnalAtom env (CoLitAtom lit) = emptyDetails -occAnalAtom env (CoVarAtom v) +occAnalArg env (VarArg v) | isCandidate env v = unitDetails v (argOccurrence 0) | otherwise = emptyDetails +occAnalArg _ _ = emptyDetails \end{code}