X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=e6013f3742f261c777d8eed4f3881195e466fd3f;hb=c248518fe81b6d2807d3bcbb8a09ae14facce1ad;hp=90a565f4ddd0782795ac95badfa4a84172cd0daa;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 90a565f..e6013f3 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -22,10 +22,9 @@ import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial, isDefaultAlt ) import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, idOccInfo, setIdOccInfo, isLocalId, - isExportedId, idArity, idSpecialisation, + isExportedId, idArity, idHasRules, idType, idUnique, Id ) -import IdInfo ( isEmptySpecInfo ) import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt ) import VarSet @@ -36,7 +35,7 @@ import Maybes ( orElse ) import Digraph ( stronglyConnCompR, SCC(..) ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) -import UniqFM ( keysUFM ) +import UniqFM ( keysUFM, lookupUFM_Directly ) import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -201,10 +200,23 @@ occAnalBind env (Rec pairs) body_usage 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) + final_bind = Rec (doReorder edges) + + -- Hopefully 'bndrs' is a relatively small group now + -- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references + -- We've done dead-code elimination already, so no worries about un-referenced binders + edges :: [Node Details2] + edges = zipWithEqual "reorder" mk_edge tagged_bndrs details + keys = map idUnique bndrs + mk_edge tagged_bndr (_, rhs_usage, rhs') + = ((tagged_bndr, rhs'), idUnique tagged_bndr, used) + where + used = [key | key <- keys, used_outside_rule rhs_usage key ] + + used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of + Nothing -> False + Just RulesOnly -> False -- Ignore rules + other -> True \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic @@ -263,27 +275,29 @@ 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. +doReorder :: [Node Details2] -> [Details2] +-- Sorted into a plausible order. Enough of the Ids have +-- dontINLINE pragmas that there are no loops left. +doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes) + +reOrderRec :: SCC (Node Details2) -> [Details2] -- Non-recursive case -reOrderRec env (AcyclicSCC (bind, _, _)) = [bind] +reOrderRec (AcyclicSCC (bind, _, _)) = [bind] -- Common case of simple self-recursion -reOrderRec env (CyclicSCC [bind]) +reOrderRec (CyclicSCC []) + = panic "reOrderRec" + +reOrderRec (CyclicSCC [bind]) = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where ((tagged_bndr, rhs), _, _) = bind -reOrderRec env (CyclicSCC (bind : binds)) +reOrderRec (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)) - ++ + doReorder unchosen ++ [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where @@ -320,7 +334,7 @@ reOrderRec env (CyclicSCC (bind : binds)) | inlineCandidate bndr rhs = 2 -- Likely to be inlined - | not (isEmptySpecInfo (idSpecialisation bndr)) = 1 + | idHasRules bndr = 1 -- Avoid things with specialisations; we'd like -- to take advantage of them in the subsequent bindings @@ -399,7 +413,7 @@ addRuleUsage :: UsageDetails -> Id -> UsageDetails addRuleUsage usage id = foldVarSet add usage (idRuleVars id) where - add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info + add v u = addOneOcc u v RulesOnly -- Give a non-committal binder info -- (i.e manyOcc) because many copies -- of the specialised thing can appear \end{code} @@ -456,6 +470,11 @@ occAnal env (Note note body) = case occAnal env body of { (usage, body') -> (usage, Note note body') } + +occAnal env (Cast expr co) + = case occAnal env expr of { (usage, expr') -> + (usage, Cast expr' co) + } \end{code} \begin{code} @@ -503,8 +522,8 @@ occAnal env expr@(Lam _ _) is_one_shot b = isId b && isOneShotBndr b occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') -> + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s alts_usage' = addCaseBndrUsage alts_usage @@ -524,6 +543,10 @@ occAnal env (Case scrut bndr ty alts) Nothing -> usage Just occ -> extendVarEnv usage bndr (markMany occ) + alt_env = setVanillaCtxt env + -- Consider x = case v of { True -> (p,q); ... } + -- Then it's fine to inline p and q + occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) = (mkOneOcc env v True, Var v) @@ -546,7 +569,6 @@ Applications are dealt with specially because we want the "build hack" to work. \begin{code} --- Hack for build, fold, runST occAnalApp env (Var fun, args) is_rhs = case args_stuff of { (args_uds, args') -> let @@ -567,6 +589,8 @@ occAnalApp env (Var fun, args) is_rhs where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) + + -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args @@ -628,15 +652,22 @@ is rather like If e turns out to be (e1,e2) we indeed get something like let a = e1; b = e2; x = (a,b) in rhs +Note [Aug 06]: I don't think this is necessary any more, and it helpe + to know when binders are unused. See esp the call to + isDeadBinder in Simplify.mkDupableAlt + \begin{code} occAnalAlt env case_bndr (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage, rhs') -> let (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs + final_bndrs = tagged_bndrs -- See Note [Aug06] above +{- final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs | otherwise = tagged_bndrs -- Leave the binders untagged if the case -- binder occurs at all; see note above +-} in (final_usage, (con, final_bndrs, rhs')) } \end{code} @@ -686,6 +717,10 @@ rhsCtxt = OccEnv OccRhs [] isRhsEnv (OccEnv OccRhs _) = True isRhsEnv (OccEnv OccVanilla _) = False +setVanillaCtxt :: OccEnv -> OccEnv +setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty +setVanillaCtxt other_env = other_env + setCtxt :: OccEnv -> CtxtTy -> OccEnv setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt @@ -804,20 +839,21 @@ markInsideLam occ = occ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo -addOccInfo IAmDead info2 = info2 -addOccInfo info1 IAmDead = info1 -addOccInfo info1 info2 = NoOccInfo +addOccInfo IAmDead info2 = info2 +addOccInfo info1 IAmDead = info1 +addOccInfo RulesOnly RulesOnly = RulesOnly +addOccInfo info1 info2 = NoOccInfo -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case orOccInfo IAmDead info2 = info2 orOccInfo info1 IAmDead = info1 +orOccInfo RulesOnly RulesOnly = RulesOnly orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1) (OneOcc in_lam2 one_branch2 int_cxt2) = OneOcc (in_lam1 || in_lam2) False -- False, because it occurs in both branches (int_cxt1 && int_cxt2) - orOccInfo info1 info2 = NoOccInfo \end{code}