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
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}
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
\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
| 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
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}
= 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}
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
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)
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
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
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}
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
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}
projects / ghc-hetmet.git / blobdiff