X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=005b44cf93a3425393e2700baf67cba749cb4269;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=2d37a9de35a6016a8ac3e3d8269ce1d4ce58717d;hpb=996573cd62a9dab5b3a7f7ab85567507422601bb;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 2d37a9d..005b44c 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-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -12,34 +12,37 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr + occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, + markBinderInsideLambda ) where #include "HsVersions.h" import BinderInfo -import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) +import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn -import Digraph ( stronglyConnCompR, SCC(..) ) -import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, +import CoreUtils ( exprIsTrivial, idSpecVars ) +import Const ( Con(..), Literal(..) ) +import Id ( idWantsToBeINLINEd, + getInlinePragma, setInlinePragma, omitIfaceSigForId, - idType, idUnique, Id, - emptyIdSet, unionIdSets, mkIdSet, - elementOfIdSet, - addOneToIdSet, IdSet, - - IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs, - delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, - mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv + getIdSpecialisation, + idType, idUnique, Id ) -import Specialise ( idSpecVars ) +import IdInfo ( InlinePragInfo(..), OccInfo(..) ) +import SpecEnv ( isEmptySpecEnv ) + +import VarSet +import VarEnv + +import PrelInfo ( noRepStrIds, noRepIntegerIds ) import Name ( isExported, isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) -import PprCore +import Digraph ( stronglyConnCompR, SCC(..) ) import Unique ( u2i ) import UniqFM ( keysUFM ) -import Util ( zipWithEqual ) +import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -54,21 +57,18 @@ Here's the externally-callable interface: \begin{code} occurAnalyseBinds - :: [CoreBinding] -- input - -> (SimplifierSwitch -> Bool) - -> [SimplifiableCoreBinding] -- output - -occurAnalyseBinds binds simplifier_sw_chkr - | opt_D_dump_occur_anal = pprTrace "OccurAnal:" - (pprGenericBindings binds') - binds' - | otherwise = binds' + :: (SimplifierSwitch -> Bool) + -> [CoreBind] + -> [CoreBind] + +occurAnalyseBinds simplifier_sw_chkr binds + = binds' where (_, _, 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 + (\id -> isLocallyDefined id) -- Anything local is interesting + emptyVarSet \end{code} @@ -76,16 +76,16 @@ occurAnalyseBinds binds simplifier_sw_chkr occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting -> CoreExpr -> (IdEnv BinderInfo, -- Occ info for interesting free vars - SimplifiableCoreExpr) + CoreExpr) occurAnalyseExpr interesting expr = occAnal initial_env expr where initial_env = OccEnv False {- Do not ignore INLINE Pragma -} - (\id locals -> interesting id || elementOfIdSet id locals) - emptyIdSet + interesting + emptyVarSet -occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr +occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned @@ -150,17 +150,52 @@ unfolding for something. \begin{code} occAnalTop :: OccEnv -- What's in scope - -> [CoreBinding] + -> [CoreBind] -> (IdEnv BinderInfo, -- Occurrence info IdEnv Id, -- Indirection elimination info - [SimplifiableCoreBinding] + [CoreBind] ) -occAnalTop env [] = (emptyDetails, nullIdEnv, []) +occAnalTop env [] = (emptyDetails, emptyVarEnv, []) -- Special case for eliminating indirections -occAnalTop env (NonRec exported_id (Var local_id) : binds) - | isExported exported_id && -- Only if this is exported +-- Note: it's a shortcoming that this only works for +-- non-recursive bindings. Elminating indirections +-- makes perfect sense for recursive bindings too, but +-- it's more complicated to implement, so I haven't done so + +occAnalTop env (bind : binds) + = case bind of + NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id + -> -- Aha! An indirection; let's eliminate it! + (scope_usage, ind_env', binds') + where + ind_env' = extendVarEnv ind_env local_id exported_id + + other -> -- Ho ho! The normal case + (final_usage, ind_env, new_binds ++ binds') + where + (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage + where + new_env = env `addNewCands` (bindersOf bind) + (scope_usage, ind_env, binds') = occAnalTop new_env binds + + -- Deal with any indirections + zap_bind (NonRec bndr rhs) + | bndr `elemVarEnv` ind_env = Rec (zap (bndr,rhs)) + -- The Rec isn't strictly necessary, but it's convenient + zap_bind (Rec pairs) + | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs)) + + zap_bind bind = bind + + zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of + Nothing -> [pair] + Just exported_id -> [(bndr, Var exported_id), + (exported_id, rhs)] + +shortMeOut ind_env exported_id local_id + = 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 @@ -187,36 +222,7 @@ occAnalTop env (NonRec exported_id (Var local_id) : binds) -- 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)] + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for \end{code} @@ -230,30 +236,31 @@ Bindings ~~~~~~~~ \begin{code} +type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached + 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) +type Details1 = (Id, UsageDetails, CoreExpr) +type Details2 = (IdWithOccInfo, CoreExpr) occAnalBind :: OccEnv - -> CoreBinding + -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) - [SimplifiableCoreBinding]) + [CoreBind]) occAnalBind env (NonRec binder rhs) body_usage - | isNeeded env body_usage binder -- It's mentioned in body + | isDeadBinder tagged_binder -- It's not mentioned + = (body_usage, []) + + | otherwise -- It's mentioned in the body = (final_body_usage `combineUsageDetails` rhs_usage, [NonRec tagged_binder rhs']) - | otherwise -- Not mentioned, so drop dead code - = (body_usage, []) - where - binder' = nukeNoInlinePragma binder - (rhs_usage, rhs') = occAnalRhs env binder' rhs - (final_body_usage, tagged_binder) = tagBinder body_usage binder' + (final_body_usage, tagged_binder) = tagBinder body_usage binder + (rhs_usage, rhs') = occAnalRhs env binder rhs \end{code} Dropping dead code for recursive bindings is done in a very simple way: @@ -301,7 +308,7 @@ occAnalBind env (Rec pairs) body_usage new_env = env `addNewCands` binders analysed_pairs :: [Details1] - analysed_pairs = [ (nukeNoInlinePragma bndr, rhs_usage, rhs') + analysed_pairs = [ (bndr, rhs_usage, rhs') | (bndr, rhs) <- pairs, let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs ] @@ -323,7 +330,7 @@ occAnalBind env (Rec pairs) body_usage -- by just extracting the keys from the finite map. Grimy, but fast. -- Previously we had this: -- [ bndr | bndr <- bndrs, - -- maybeToBool (lookupIdEnv rhs_usage bndr)] + -- maybeToBool (lookupVarEnv rhs_usage bndr)] -- which has n**2 cost, and this meant that edges_from alone -- consumed 10% of total runtime! edges_from :: UsageDetails -> [Int] @@ -334,10 +341,10 @@ occAnalBind env (Rec pairs) body_usage -- 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 + | isDeadBinder tagged_bndr = (body_usage, binds_so_far) -- Dead code + | otherwise + = (combined_usage, new_bind : binds_so_far) where total_usage = combineUsageDetails body_usage rhs_usage (combined_usage, tagged_bndr) = tagBinder total_usage bndr @@ -345,20 +352,20 @@ occAnalBind env (Rec pairs) body_usage -- 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 + | all isDeadBinder tagged_bndrs = (body_usage, binds_so_far) -- Dead code + | otherwise + = (combined_usage, final_bind:binds_so_far) where - details = [details | (details, _, _) <- cycle] - bndrs = [bndr | (bndr, _, _) <- details] - rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] - total_usage = foldr combineUsageDetails body_usage rhs_usages - (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 (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys) + details = [details | (details, _, _) <- cycle] + bndrs = [bndr | (bndr, _, _) <- details] + rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] + total_usage = foldr combineUsageDetails body_usage rhs_usages + (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs + final_bind = Rec (reOrderRec env new_cycle) + + new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs 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 @@ -376,6 +383,10 @@ 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. +============== +[June 98: I don't understand the following paragraphs, and I've + changed the a=b case again so that it isn't a special case any more.] + Here's a case that bit me: letrec @@ -388,6 +399,7 @@ 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 @@ -424,42 +436,55 @@ reOrderRec env (AcyclicSCC (bind, _, _)) = [bind] -- Common case of simple self-recursion reOrderRec env (CyclicSCC [bind]) - = [((addNoInlinePragma bndr, occ_info), rhs)] + = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)] where - (((bndr, occ_info), rhs), _, _) = bind + ((tagged_bndr, rhs), _, _) = bind -reOrderRec env (CyclicSCC binds) +reOrderRec env (CyclicSCC (bind : 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)] + [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)] where - (chosen_pair, unchosen) = choose_loop_breaker binds - ((bndr,occ_info), rhs) = chosen_pair - - -- Choosing the loop breaker; heursitic - choose_loop_breaker (bind@(details, _, _) : rest) - | not (null rest) && - bad_choice details - = (chosen, bind : unchosen) -- Don't pick it - | otherwise -- Pick it - = (details,rest) + (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds + (tagged_bndr, rhs) = chosen_pair + + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in + choose_loop_breaker (details,_,_) loop_sc acc [] + = (details, acc) -- Done + + choose_loop_breaker loop_bind loop_sc acc (bind : binds) + | sc < loop_sc -- Lower score so pick this new one + = choose_loop_breaker bind sc (loop_bind : acc) binds + + | otherwise -- No lower so don't pick it + = choose_loop_breaker loop_bind loop_sc (bind : acc) binds 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 - || isOneFunOcc occ_info -- Dont pick single-occ thing - || not_fun_ty (idType bndr) -- Dont pick data-ty thing - - -- isOneFunOcc looks for 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): + sc = score bind + + score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker + score ((bndr, rhs), _, _) + | exprIsTrivial rhs && + not (isExported bndr) = 3 -- Practically certain to be inlined + | inlineCandidate bndr = 3 -- Likely to be inlined + | not_fun_ty (idType bndr) = 2 -- Data types help with cases + | not (isEmptySpecEnv (getIdSpecialisation bndr)) = 1 + -- Avoid things with a SpecEnv; we'd like + -- to take advantage of the SpecEnv in the subsequent bindings + | otherwise = 0 + + inlineCandidate :: Id -> Bool + inlineCandidate id + = case getInlinePragma id of + IWantToBeINLINEd -> True + IMustBeINLINEd -> True + ICanSafelyBeINLINEd _ _ -> True + other -> False + + -- 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) @@ -467,14 +492,11 @@ reOrderRec env (CyclicSCC binds) -- 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. + -- But we won't because constructor args are marked "Many". not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty)) where (_, rho_ty) = splitForAllTys ty - - -- A variable RHS - var_rhs (Var v) = True - var_rhs other_rhs = False \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked @@ -485,6 +507,7 @@ 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. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec. [March 98] A new wrinkle is that if the binder has specialisations inside it then we count the specialised Ids as "extra rhs's". That way @@ -495,28 +518,34 @@ die too unless they are already referenced directly. \begin{code} occAnalRhs :: OccEnv -> Id -> CoreExpr -- Binder and rhs - -> (UsageDetails, SimplifiableCoreExpr) + -> (UsageDetails, CoreExpr) +{- DELETED SLPJ June 98: seems quite bogus to me occAnalRhs env id (Var v) | isCandidate env v - = (unitIdEnv v (markMany (funOccurrence 0)), Var v) + = (unitVarEnv v (markMany (funOccurrence 0)), Var v) | otherwise = (emptyDetails, Var v) +-} occAnalRhs env id rhs - | inlineMe env id - = (mapIdEnv markMany total_usage, rhs') + | idWantsToBeINLINEd id + = (mapVarEnv markMany total_usage, rhs') | otherwise = (total_usage, rhs') where (rhs_usage, rhs') = occAnal env rhs - total_usage = foldr add rhs_usage (idSpecVars id) - 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 + lazy_rhs_usage = mapVarEnv markLazy rhs_usage + total_usage = foldVarSet add lazy_rhs_usage spec_ids + 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 + spec_ids = idSpecVars id +\end{code} + \end{code} Expressions @@ -525,17 +554,13 @@ Expressions occAnal :: OccEnv -> CoreExpr -> (UsageDetails, -- Gives info only about the "interesting" Ids - SimplifiableCoreExpr) - -occAnal env (Var v) - | isCandidate env v - = (unitIdEnv v (funOccurrence 0), Var v) + CoreExpr) - | otherwise - = (emptyDetails, Var v) +occAnal env (Type t) = (emptyDetails, Type t) -occAnal env (Lit lit) = (emptyDetails, Lit lit) -occAnal env (Prim op args) = (occAnalArgs env args, Prim op args) +occAnal env (Var v) + | isCandidate env v = (unitVarEnv v funOccZero, Var v) + | otherwise = (emptyDetails, Var v) \end{code} We regard variables that occur as constructor arguments as "dangerousToDup": @@ -554,139 +579,108 @@ If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. \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') + -- For NoRep literals we have to report an occurrence of + -- the things which tidyCore will later add, so that when + -- we are compiling the very module in which those thin-air Ids + -- are defined we have them in scope! +occAnal env expr@(Con (Literal lit) args) + = ASSERT( null args ) + (mk_lit_uds lit, expr) where - (usage, body') = occAnal env body + mk_lit_uds (NoRepStr _ _) = try noRepStrIds + mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds + mk_lit_uds lit = emptyDetails + + try vs = foldr add emptyDetails vs + add v uds | isCandidate env v = extendVarEnv uds v funOccZero + | otherwise = uds + +occAnal env (Con con args) + = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') -> + let + arg_uds = foldr combineUsageDetails emptyDetails arg_uds_s + + -- We mark the free vars of the argument of a constructor as "many" + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + final_arg_uds = case con of + DataCon _ -> mapVarEnv markMany arg_uds + other -> arg_uds + in + (final_arg_uds, Con con args') + } +\end{code} -occAnal env (Coerce c ty body) - = (usage, Coerce c ty body') - where - (usage, body') = occAnal env body +\begin{code} +occAnal env (Note note@(SCC cc) body) + = case occAnal env body of { (usage, body') -> + (mapVarEnv markInsideSCC usage, Note note body') + } + +occAnal env (Note note body) + = case occAnal env body of { (usage, body') -> + (usage, Note note body') + } +\end{code} +\begin{code} 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 + = case occAnal env fun of { (fun_usage, fun') -> + case occAnal env arg of { (arg_usage, arg') -> + (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' 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) +-- So instead, we just mark each binder with its occurrence +-- info in the *body* of the multiple lambda. +-- Then, the simplifier is careful when partially applying lambdas. + +occAnal env expr@(Lam _ _) + = case occAnal (env `addNewCands` binders) body of { (body_usage, body') -> + let + (final_usage, tagged_binders) = tagBinders body_usage binders + in + (mapVarEnv markInsideLam final_usage, + mkLams tagged_binders body') } where - (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 (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 (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') + (binders, body) = collectBinders expr + + +occAnal env (Case scrut bndr alts) + = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> + case occAnal env scrut of { (scrut_usage, scrut') -> + let + alts_usage = foldr1 combineAltsUsageDetails alts_usage_s + (alts_usage1, tagged_bndr) = tagBinder alts_usage bndr + total_usage = scrut_usage `combineUsageDetails` alts_usage1 + in + total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }} where - (scrut_usage, scrut') = occAnal env scrut - (alts_usage, alts') = occAnalAlts env alts --} + alt_env = env `addNewCand` bndr 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) + (final_usage, mkLets new_binds body') }} where - new_env = env `addNewCands` (bindersOf bind) --- (body_usage, body') = occAnal new_env body --- (final_usage, new_binds) = occAnalBind env bind body_usage + new_env = env `addNewCands` (bindersOf bind) \end{code} Case alternatives ~~~~~~~~~~~~~~~~~ \begin{code} -occAnalAlts env (AlgAlts alts deflt) - = (foldr combineAltsUsageDetails deflt_usage alts_usage, - -- Note: combine*Alts*UsageDetails... - AlgAlts alts' deflt') - where - (alts_usage, alts') = unzip (map do_alt alts) - (deflt_usage, deflt') = occAnalDeflt env deflt - - do_alt (con, args, rhs) - = (final_usage, (con, tagged_args, rhs')) - where - new_env = env `addNewCands` args - (rhs_usage, rhs') = occAnal new_env rhs - (final_usage, tagged_args) = tagBinders rhs_usage args - -occAnalAlts env (PrimAlts alts deflt) - = (foldr combineAltsUsageDetails deflt_usage alts_usage, - -- Note: combine*Alts*UsageDetails... - PrimAlts alts' deflt') - where - (alts_usage, alts') = unzip (map do_alt alts) - (deflt_usage, deflt') = occAnalDeflt env deflt - - do_alt (lit, rhs) - = (rhs_usage, (lit, rhs')) - where - (rhs_usage, rhs') = occAnal env rhs - -occAnalDeflt env NoDefault = (emptyDetails, NoDefault) - -occAnalDeflt env (BindDefault binder rhs) - = (final_usage, BindDefault tagged_binder rhs') - where - new_env = env `addNewCand` binder - (rhs_usage, rhs') = occAnal new_env rhs - (final_usage, tagged_binder) = tagBinder rhs_usage binder -\end{code} - - -Atoms -~~~~~ -\begin{code} -occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails - -occAnalArgs env atoms - = foldr do_one_atom emptyDetails atoms - where - do_one_atom (VarArg v) usage - | isCandidate env v = addOneOcc usage v (argOccurrence 0) - | otherwise = usage - do_one_atom other_arg usage = usage - - -occAnalArg :: OccEnv -> CoreArg -> UsageDetails - -occAnalArg env (VarArg v) - | isCandidate env v = unitDetails v (argOccurrence 0) - | otherwise = emptyDetails -occAnalArg _ _ = emptyDetails +occAnalAlt env (con, bndrs, rhs) + = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') -> + let + (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs + in + (final_usage, (con, tagged_bndrs, rhs')) } \end{code} @@ -703,29 +697,22 @@ data OccEnv = -- 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 + (Id -> 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) + = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids) addNewCand :: OccEnv -> Id -> OccEnv addNewCand (OccEnv ip ifun cands) id - = OccEnv ip ifun (addOneToIdSet cands id) + = OccEnv ip ifun (extendVarSet 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 +isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage @@ -734,69 +721,92 @@ combineUsageDetails, combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails combineUsageDetails usage1 usage2 - = combineIdEnvs addBinderInfo usage1 usage2 + = plusVarEnv_C addBinderInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 - = combineIdEnvs orBinderInfo usage1 usage2 + = plusVarEnv_C orBinderInfo usage1 usage2 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails addOneOcc usage id info - = combineIdEnvs addBinderInfo usage (unitIdEnv id info) + = plusVarEnv_C addBinderInfo usage (unitVarEnv id info) -- ToDo: make this more efficient -emptyDetails = (nullIdEnv :: UsageDetails) +emptyDetails = (emptyVarEnv :: UsageDetails) -unitDetails id info = (unitIdEnv id info :: UsageDetails) +unitDetails id info = (unitVarEnv 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 ] - ) --} + [IdWithOccInfo]) -- Tagged binders + +tagBinders usage binders + = let + usage' = usage `delVarEnvList` binders + uss = map (setBinderPrag usage) binders + in + usage' `seq` (usage', uss) + 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 + IdWithOccInfo) -- Tagged binders + +tagBinder usage binder + = let + usage' = usage `delVarEnv` binder + binder' = setBinderPrag usage binder + in + usage' `seq` (usage', binder') + + +setBinderPrag :: UsageDetails -> CoreBndr -> CoreBndr +setBinderPrag usage bndr + | isTyVar bndr + = bndr + | otherwise - = case (lookupIdEnv usage binder) of - Nothing -> deadOccurrence - Just info -> info + = case old_prag of + NoInlinePragInfo -> new_bndr + IAmDead -> new_bndr -- The next three are annotations + ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of + IAmALoopBreaker -> new_bndr -- the occurrence analyser -isNeeded env usage binder = not (isDeadOcc (usage_of usage binder)) -\end{code} + IAmASpecPragmaId -> bndr -- Don't ever overwrite or drop these as dead + + other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead + | otherwise -> bndr + + where + old_prag = getInlinePragma bndr + new_bndr = setInlinePragma bndr new_prag + its_now_dead = case new_prag of + IAmDead -> True + other -> False + new_prag = occInfoToInlinePrag occ_info + + occ_info + | isExported bndr = noBinderInfo + -- Don't use local usage info for visible-elsewhere things + -- But NB that we do set NoInlinePragma for exported things + -- thereby nuking any IAmALoopBreaker from a previous pass. + + | otherwise = case lookupVarEnv usage bndr of + Nothing -> deadOccurrence + Just info -> info + +markBinderInsideLambda :: CoreBndr -> CoreBndr +markBinderInsideLambda bndr + | isTyVar bndr + = bndr + + | otherwise + = case getInlinePragma bndr of + ICanSafelyBeINLINEd not_in_lam nalts + -> bndr `setInlinePragma` ICanSafelyBeINLINEd InsideLam nalts + other -> bndr + +funOccZero = funOccurrence 0 +\end{code}