import CoreSyn
import CoreFVs
import Type ( tyVarsOfType )
-import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI )
+import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
import Coercion ( CoercionI(..), mkSymCoI )
import Id
import Name ( localiseName )
import VarSet
import VarEnv
+import Var ( Var, varUnique )
import Maybes ( orElse )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import Util ( mapAndUnzip, filterOut )
import Bag
import Outputable
-
+import FastString
import Data.List
\end{code}
[CoreBind])
occAnalBind env _ (NonRec binder rhs) body_usage
- | isTyVar binder -- A type let; we don't gather usage info
+ | isTyCoVar binder -- A type let; we don't gather usage info
= (body_usage, [NonRec binder rhs])
| not (binder `usedIn` body_usage) -- It's not mentioned
rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
make_node (bndr, rhs)
- = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges)
+ = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges)
where
(rhs_usage, rhs') = occAnalRhs env bndr rhs
- all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs]
- rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
- out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
+ all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs]
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+ out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars)
+ rule_vars = idRuleVars bndr -- See Note [Rule dependency info]
-- (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 --
no_rules = null init_rule_fvs
init_rule_fvs = [(b, rule_fvs)
| b <- bndrs
+ , isId b
, let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
, not (isEmptyVarSet rule_fvs)]
score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
score (ND bndr rhs _ _, _, _)
+ | not (isId bndr) = 100 -- A type or cercion varialbe is never a loop breaker
+
| isDFunId bndr = 9 -- Never choose a DFun as a loop breaker
-- Note [DFuns should not be loop breakers]
- | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr)
- = case inl_rule_info of
- InlWrapper {} -> 10 -- Note [INLINE pragmas]
- _other -> 3 -- Data structures are more important than this
- -- so that dictionary/method recursion unravels
+ | Just (inl_source, _) <- isStableUnfolding_maybe (idUnfolding bndr)
+ = case inl_source of
+ InlineWrapper {} -> 10 -- Note [INLINE pragmas]
+ _other -> 3 -- Data structures are more important than this
+ -- so that dictionary/method recursion unravels
-- Note that this case hits all InlineRule things, so we
-- never look at 'rhs for InlineRule stuff. That's right, because
-- 'rhs' is irrelevant for inlining things with an InlineRule
makeLoopBreaker :: Bool -> Id -> Id
-- Set the loop-breaker flag: see Note [Weak loop breakers]
-makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
+makeLoopBreaker weak bndr
+ = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
\end{code}
Note [Complexity of loop breaking]
-- Returned usage details includes any INLINE rhs
occAnalRhs env id rhs
- = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+ | isId id = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+ | otherwise = (rhs_usage, rhs')
-- Include occurrences for the "extra RHS" from a CoreUnfolding
where
(rhs_usage, rhs') = occAnal ctxt rhs
\begin{code}
-addRuleUsage :: UsageDetails -> Id -> UsageDetails
+addRuleUsage :: UsageDetails -> Var -> UsageDetails
-- Add the usage from RULES in Id to the usage
-addRuleUsage usage id = addIdOccs usage (idRuleVars id)
+addRuleUsage usage var
+ | isId var = addIdOccs usage (idRuleVars var)
+ | otherwise = usage
-- idRuleVars here: see Note [Rule dependency info]
addIdOccs :: UsageDetails -> VarSet -> UsageDetails
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- (markRhsUds env True usage, Cast expr' co)
+ (markManyIf (isRhsEnv env) usage, Cast expr' co)
-- If we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-occAnal env (Lam x body) | isTyVar x
+occAnal env (Lam x body) | isTyCoVar x
= case occAnal env body of { (body_usage, body') ->
(body_usage, Lam x body')
}
occAnalApp env (Var fun, args)
= case args_stuff of { (args_uds, args') ->
let
- final_args_uds = markRhsUds env is_pap args_uds
+ final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
+ -- We mark the free vars of the argument of a constructor or PAP
+ -- as "many", if it is the RHS of a let(rec).
+ -- 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.
+ --
+ -- This is the *whole point* of the isRhsEnv predicate
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
- is_pap = isConLikeId fun || valArgCount args < idArity fun
+ is_exp = isExpandableApp fun (valArgCount args)
-- See Note [CONLIKE pragma] in BasicTypes
+ -- The definition of is_exp should match that in
+ -- Simplify.prepareRhs
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
(final_uds, mkApps fun' args') }}
-markRhsUds :: OccEnv -- Check if this is a RhsEnv
- -> Bool -- and this is true
- -> UsageDetails -- The do markMany on this
+markManyIf :: Bool -- If this is true
+ -> UsageDetails -- Then do markMany on this
-> UsageDetails
--- We mark the free vars of the argument of a constructor or PAP
--- as "many", if it is the RHS of a let(rec).
--- 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.
---
--- This is the *whole point* of the isRhsEnv predicate
-markRhsUds env is_pap arg_uds
- | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
- | otherwise = arg_uds
-
+markManyIf True uds = mapVarEnv markMany uds
+markManyIf False uds = uds
appSpecial :: OccEnv
-> Int -> CtxtTy -- Argument number, and context to use for it
| OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
-- Do inline into constructor args here
+instance Outputable OccEncl where
+ ppr OccRhs = ptext (sLit "occRhs")
+ ppr OccVanilla = ptext (sLit "occVanilla")
+
type CtxtTy = [Bool]
-- [] No info
--
| otherwise = PE env2 fvs2 -- don't extend
where
PE env1 fvs1 = trimProxyEnv pe [case_bndr]
- env2 = extendVarEnv_C add env1 scrut1 (scrut1, [(case_bndr,co)])
- add (x, cb_cos) _ = (x, (case_bndr,co):cb_cos)
+ env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
+ single cb_co = (scrut1, [cb_co])
+ add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
fvs2 = fvs1 `unionVarSet` freeVarsCoI co
`extendVarSet` case_bndr
`extendVarSet` scrut1
where
pe = occ_proxy env
pe' = case scrut of
- Var v -> extendProxyEnv pe v IdCo cb
- Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
+ Var v -> extendProxyEnv pe v (IdCo (idType v)) cb
+ Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
_other -> trimProxyEnv pe [cb]
-----------
-----------
freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI IdCo = emptyVarSet
+freeVarsCoI (IdCo t) = tyVarsOfType t
freeVarsCoI (ACo co) = tyVarsOfType co
\end{code}
emptyDetails :: UsageDetails
emptyDetails = (emptyVarEnv :: UsageDetails)
-localUsedIn, usedIn :: Id -> UsageDetails -> Bool
-v `localUsedIn` details = v `elemVarEnv` details
-v `usedIn` details = isExportedId v || v `localUsedIn` details
+usedIn :: Id -> UsageDetails -> Bool
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
type IdWithOccInfo = Id
setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
- | isTyVar bndr = bndr
+ | isTyCoVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
_ -> setIdOccInfo bndr NoOccInfo
projects / ghc-hetmet.git / blobdiff