diff options
| -rw-r--r-- | compiler/GHC/Core.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Core/FVs.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Core/Op/OccurAnal.hs | 897 | ||||
| -rw-r--r-- | compiler/GHC/Core/Op/Simplify.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Core/Op/Simplify/Utils.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Core/Subst.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unfold.hs | 111 | ||||
| -rw-r--r-- | compiler/GHC/Core/Utils.hs | 139 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Stg/CSE.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_compile/dynamic-paper.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T17901.stdout | 10 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T7360.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T7360.stderr | 40 |
19 files changed, 657 insertions, 659 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 8c354b5298..b8d44d98a0 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -69,7 +69,7 @@ module GHC.Core ( maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isFragileUnfolding, hasSomeUnfolding, + isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding, isBootUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, @@ -1739,14 +1739,13 @@ neverUnfoldGuidance :: UnfoldingGuidance -> Bool neverUnfoldGuidance UnfNever = True neverUnfoldGuidance _ = False -isFragileUnfolding :: Unfolding -> Bool --- An unfolding is fragile if it mentions free variables or --- is otherwise subject to change. A robust one can be kept. --- See Note [Fragile unfoldings] -isFragileUnfolding (CoreUnfolding {}) = True -isFragileUnfolding (DFunUnfolding {}) = True -isFragileUnfolding _ = False - -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile +hasCoreUnfolding :: Unfolding -> Bool +-- An unfolding "has Core" if it contains a Core expression, which +-- may mention free variables. See Note [Fragile unfoldings] +hasCoreUnfolding (CoreUnfolding {}) = True +hasCoreUnfolding (DFunUnfolding {}) = True +hasCoreUnfolding _ = False + -- NoUnfolding, BootUnfolding, OtherCon have no Core canUnfold :: Unfolding -> Bool canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 67577bcd9b..6995cc71a1 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -35,7 +35,7 @@ module GHC.Core.FVs ( idFVs, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, - rulesFreeVarsDSet, + rulesFreeVarsDSet, mkRuleInfo, ruleLhsFreeIds, ruleLhsFreeIdsList, expr_fvs, @@ -469,6 +469,11 @@ rulesFVs = mapUnionFV ruleFVs rulesFreeVarsDSet :: [CoreRule] -> DVarSet rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules +-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkRuleInfo :: [CoreRule] -> RuleInfo +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) + idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule idRuleRhsVars is_active id diff --git a/compiler/GHC/Core/Op/OccurAnal.hs b/compiler/GHC/Core/Op/OccurAnal.hs index ac1c665e1e..997ff7dd5a 100644 --- a/compiler/GHC/Core/Op/OccurAnal.hs +++ b/compiler/GHC/Core/Op/OccurAnal.hs @@ -14,10 +14,7 @@ core expression with (hopefully) improved usage information. {-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module GHC.Core.Op.OccurAnal ( - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap - ) where +module GHC.Core.Op.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where #include "HsVersions.h" @@ -30,7 +27,6 @@ import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, import GHC.Core.Arity ( joinRhsArity ) import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Name( localiseName ) import GHC.Types.Basic import GHC.Types.Module( Module ) import GHC.Core.Coercion @@ -47,14 +43,14 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import Util +import Maybes( orElse, isJust ) import Outputable import Data.List -import Control.Arrow ( second ) {- ************************************************************************ * * - occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap + occurAnalysePgm, occurAnalyseExpr * * ************************************************************************ @@ -92,8 +88,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds -- a binding that was actually needed (albeit before its -- definition site). #17724 threw this up. - initial_uds = addManyOccsSet emptyDetails - (rulesFreeVars imp_rules) + initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) -- The RULES declarations keep things alive! -- Note [Preventing loops due to imported functions rules] @@ -117,17 +112,9 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr - -- Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap - -occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr -occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap - -occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr -occurAnalyseExpr' enable_binder_swap expr - = snd (occAnal env expr) - where - env = initOccEnv { occ_binder_swap = enable_binder_swap } +-- Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr expr + = snd (occAnal initOccEnv expr) {- Note [Plugin rules] ~~~~~~~~~~~~~~~~~~~~~~ @@ -672,38 +659,66 @@ tail call with `n` arguments (counting both value and type arguments). Otherwise 'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the rest of 'OccInfo' until it goes on the binder. -Note [Rules and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Join points and unfoldings/rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let j2 y = blah + let j x = j2 (x+x) + {-# INLINE [2] j #-} + in case e of { A -> j 1; B -> ...; C -> j 2 } -Things get fiddly with rules. Suppose we have: +Before j is inlined, we'll have occurrences of j2 in +both j's RHS and in its stable unfolding. We want to discover +j2 as a join point. So we must do the adjustRhsUsage thing +on j's RHS. That's why we pass mb_join_arity to calcUnfolding. + +Aame with rules. Suppose we have: let j :: Int -> Int j y = 2 * y - k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 = j #-} + let k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 y = j y #-} k x y = x + 2 * y - in ... - -Now suppose that both j and k appear only as saturated tail calls in the body. -Thus we would like to make them both join points. The rule complicates matters, -though, as its RHS has an unapplied occurrence of j. *However*, if we were to -eta-expand the rule, all would be well: - - {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} - -So conceivably we could notice that a potential join point would have an -"undersaturated" rule and account for it. This would mean we could make -something that's been specialised a join point, for instance. But local bindings -are rarely specialised, and being overly cautious about rules only -costs us anything when, for some `j`: + in case e of { A -> k 1 2; B -> k 3 5; C -> blah } + +We identify k as a join point, and we want j to be a join point too. +Without the RULE it would be, and we don't want the RULE to mess it +up. So provided the join-point arity of k matches the args of the +rule we can allow the tail-cal info from the RHS of the rule to +propagate. + +* Wrinkle for Rec case. In the recursive case we don't know the + join-point arity in advance, when calling occAnalUnfolding and + occAnalRules. (See makeNode.) We don't want to pass Nothing, + because then a recursive joinrec might lose its join-poin-hood + when SpecConstr adds a RULE. So we just make do with the + *current* join-poin-hood, stored in the Id. + + In the non-recursive case things are simple: see occAnalNonRecBind + +* Wrinkle for RULES. Suppose the example was a bit different: + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + If we eta-expanded the rule all woudl be well, but as it stands the + one arg of the rule don't match the join-point arity of 2. + + Conceivably we could notice that a potential join point would have + an "undersaturated" rule and account for it. This would mean we + could make something that's been specialised a join point, for + instance. But local bindings are rarely specialised, and being + overly cautious about rules only costs us anything when, for some `j`: * Before specialisation, `j` has non-tail calls, so it can't be a join point. * During specialisation, `j` gets specialised and thus acquires rules. * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), and so now `j` *could* become a join point. -This appears to be very rare in practice. TODO Perhaps we should gather -statistics to be sure. + This appears to be very rare in practice. TODO Perhaps we should gather + statistics to be sure. ------------------------------------------------------------ Note [Adjusting right-hand sides] @@ -767,44 +782,62 @@ occAnalBind env lvl top_env (Rec pairs) body_usage ----------------- occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr -> UsageDetails -> (UsageDetails, [CoreBind]) -occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage - | isTyVar binder -- A type let; we don't gather usage info - = (body_usage, [NonRec binder rhs]) +occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage + | isTyVar bndr -- A type let; we don't gather usage info + = (body_usage, [NonRec bndr rhs]) - | not (binder `usedIn` body_usage) -- It's not mentioned + | not (bndr `usedIn` body_usage) -- It's not mentioned = (body_usage, []) | otherwise -- It's mentioned in the body - = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) + = (body_usage' `andUDs` rhs_usage4, [NonRec final_bndr rhs']) where - (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder - mb_join_arity = willBeJoinId_maybe tagged_binder + (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr + occ = idOccInfo tagged_bndr - (bndrs, body) = collectBinders rhs + -- Get the join info from the *new* decision + -- See Note [Join points and unfoldings/rules] + mb_join_arity = willBeJoinId_maybe tagged_bndr + is_join_point = isJust mb_join_arity - (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body - rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' - -- For a /non-recursive/ join point we can mark all - -- its join-lambda as one-shot; and it's a good idea to do so + final_bndr = tagged_bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + env1 | is_join_point = env -- See Note [Join point RHSs] + | certainly_inline = env -- See Note [Cascading inlines] + | otherwise = rhsCtxt env + + -- See Note [Sources of one-shot information] + rhs_env = env1 { occ_one_shots = argOneShots dmd } + + (rhs_usage1, rhs') = occAnalRhs rhs_env mb_join_arity rhs -- Unfoldings -- See Note [Unfoldings and join points] - rhs_usage2 = case occAnalUnfolding env NonRecursive binder of - Just unf_usage -> rhs_usage1 `andUDs` unf_usage - Nothing -> rhs_usage1 + unf = idUnfolding bndr + (unf_usage, unf') = occAnalUnfolding rhs_env mb_join_arity unf + rhs_usage2 = rhs_usage1 `andUDs` unf_usage -- Rules -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder + rules_w_uds = occAnalRules rhs_env mb_join_arity bndr rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + rules' = map fstOf3 rules_w_uds rhs_usage3 = foldr andUDs rhs_usage2 rule_uds - rhs_usage4 = case lookupVarEnv imp_rule_edges binder of + rhs_usage4 = case lookupVarEnv imp_rule_edges bndr of Nothing -> rhs_usage3 - Just vs -> addManyOccsSet rhs_usage3 vs + Just vs -> addManyOccs rhs_usage3 vs -- See Note [Preventing loops due to imported functions rules] - -- Final adjustment - rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 + certainly_inline -- See Note [Cascading inlines] + = case occ of + OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } + -> active && not_stable + _ -> False + + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) ----------------- occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] @@ -866,8 +899,8 @@ occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) | otherwise -- At this point we always build a single Rec = -- pprTrace "occAnalRec" (vcat - -- [ text "weak_fvs" <+> ppr weak_fvs - -- , text "lb nodes" <+> ppr loop_breaker_nodes]) + -- [ text "weak_fvs" <+> ppr weak_fvs + -- , text "lb nodes" <+> ppr loop_breaker_nodes]) (final_uds, Rec pairs : binds) where @@ -931,10 +964,10 @@ recording inlinings for any Ids which aren't marked as "no-inline" as it goes. -- Return the bindings sorted into a plausible order, and marked with loop breakers. loopBreakNodes depth bndr_set weak_fvs nodes binds = -- pprTrace "loopBreakNodes" (ppr nodes) $ - go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds + go (stronglyConnCompFromEdgedVerticesUniqR nodes) where - go [] binds = binds - go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + go [] = binds + go (scc:sccs) = loop_break_scc scc (go sccs) loop_break_scc scc binds = case scc of @@ -949,7 +982,7 @@ reOrderNodes _ _ _ [] _ = panic "reOrderNodes" reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds reOrderNodes depth bndr_set weak_fvs (node : nodes) binds = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen - -- , text "chosen" <+> ppr chosen_nodes ]) $ + -- , text "chosen" <+> ppr chosen_nodes ]) $ loopBreakNodes new_depth bndr_set weak_fvs unchosen $ (map mk_loop_breaker chosen_nodes ++ binds) where @@ -1148,7 +1181,9 @@ type LetrecNode = Node Unique Details -- Node comes from Digraph -- The Unique key is gotten from the Id data Details = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed + , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS -- INVARIANT: (nd_rhs_bndrs nd, _) == -- collectBinders (nd_rhs nd) @@ -1205,7 +1240,7 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs) -- is still deterministic with edges in nondeterministic order as -- explained in Note [Deterministic SCC] in Digraph. where - details = ND { nd_bndr = bndr + details = ND { nd_bndr = bndr' , nd_rhs = rhs' , nd_rhs_bndrs = bndrs' , nd_uds = rhs_usage3 @@ -1214,24 +1249,35 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs) , nd_active_rule_fvs = active_rule_fvs , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } + bndr' = bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + -- Get join point info from the *current* decision + -- We don't know what the new decision will be! + -- Using the old decision at least allows us to + -- preserve existing join point, even RULEs are added + -- See Note [Join points and unfoldings/rules] + mb_join_arity = isJoinId_maybe bndr + -- Constructing the edges for the main Rec computation -- See Note [Forming Rec groups] (bndrs, body) = collectBinders rhs - (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body - rhs' = mkLams bndrs' body' - rhs_usage2 = foldr andUDs rhs_usage1 rule_uds + rhs_env = rhsCtxt env + (rhs_usage1, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body + rhs' = mkLams bndrs' body' + rhs_usage3 = foldr andUDs rhs_usage1 rule_uds + `andUDs` unf_uds -- Note [Rules are extra RHSs] -- Note [Rule dependency info] - rhs_usage3 = case mb_unf_uds of - Just unf_uds -> rhs_usage2 `andUDs` unf_uds - Nothing -> rhs_usage2 - node_fvs = udFreeVars bndr_set rhs_usage3 + node_fvs = udFreeVars bndr_set rhs_usage3 -- Finding the free variables of the rules is_active = occ_rule_act env :: Activation -> Bool rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr + rules_w_uds = occAnalRules rhs_env mb_join_arity bndr + + rules' = map fstOf3 rules_w_uds rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) @@ -1244,16 +1290,20 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs) , is_active a] -- Finding the usage details of the INLINE pragma (if any) - mb_unf_uds = occAnalUnfolding env Recursive bndr + unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness + -- here because that is what we are setting! + (unf_uds, unf') = occAnalUnfolding rhs_env mb_join_arity unf -- Find the "nd_inl" free vars; for the loop-breaker phase - inl_fvs = case mb_unf_uds of - Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS - Just unf_uds -> udFreeVars bndr_set unf_uds - -- We could check for an *active* INLINE (returning - -- emptyVarSet for an inactive one), but is_active - -- isn't the right thing (it tells about - -- RULE activation), so we'd need more plumbing + -- These are the vars that would become free if the function + -- was inlinined; usually that means the RHS, unless the + -- unfolding is a stable one. + -- Note: We could do this only for functions with an *active* unfolding + -- (returning emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about RULE activation), + -- so we'd need more plumbing + inl_fvs | isStableUnfolding unf = udFreeVars bndr_set unf_uds + | otherwise = udFreeVars bndr_set rhs_usage1 mkLoopBreakerNodes :: OccEnv -> TopLevelFlag -> VarSet @@ -1271,22 +1321,24 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag mkLoopBreakerNodes env lvl bndr_set body_uds details_s = (final_uds, zipWith mk_lb_node details_s bndrs') where - (final_uds, bndrs') = tagRecBinders lvl body_uds - [ ((nd_bndr nd) - ,(nd_uds nd) - ,(nd_rhs_bndrs nd)) - | nd <- details_s ] - mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' - = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) + (final_uds, bndrs') + = tagRecBinders lvl body_uds + [ (bndr, uds, rhs_bndrs) + | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs } + <- details_s ] + + mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr + = DigraphNode nd' (varUnique old_bndr) (nonDetKeysUniqSet lb_deps) -- It's OK to use nonDetKeysUniqSet here as -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges -- in nondeterministic order as explained in -- Note [Deterministic SCC] in Digraph. where - nd' = nd { nd_bndr = bndr', nd_score = score } - score = nodeScore env bndr bndr' rhs lb_deps + nd' = nd { nd_bndr = new_bndr, nd_score = score } + score = nodeScore env new_bndr lb_deps nd lb_deps = extendFvs_ rule_fv_env inl_fvs + rule_fv_env :: IdEnv IdSet -- Maps a variable f to the variables from this group -- mentioned in RHS of active rules for f @@ -1301,12 +1353,13 @@ mkLoopBreakerNodes env lvl bndr_set body_uds details_s ------------------------------------------ nodeScore :: OccEnv - -> Id -- Binder has old occ-info (just for loop-breaker-ness) -> Id -- Binder with new occ-info - -> CoreExpr -- RHS -> VarSet -- Loop-breaker dependencies + -> Details -> NodeScore -nodeScore env old_bndr new_bndr bind_rhs lb_deps +nodeScore env new_bndr lb_deps + (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs }) + | not (isId old_bndr) -- A type or coercion variable is never a loop breaker = (100, 0, False) @@ -1324,7 +1377,7 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker - | DFunUnfolding { df_args = args } <- id_unfolding + | DFunUnfolding { df_args = args } <- old_unf -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] = (9, length args, is_lb) @@ -1332,13 +1385,13 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps -- Data structures are more important than INLINE pragmas -- so that dictionary/method recursion unravels - | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding + | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf = mk_score 6 | is_con_app rhs -- Data types help with cases: = mk_score 5 -- Note [Constructor applications] - | isStableUnfolding id_unfolding + | isStableUnfolding old_unf , can_unfold = mk_score 3 @@ -1355,23 +1408,23 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps mk_score :: Int -> NodeScore mk_score rank = (rank, rhs_size, is_lb) - is_lb = isStrongLoopBreaker (idOccInfo old_bndr) - rhs = case id_unfolding of - CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } - | isStableSource src - -> unf_rhs - _ -> bind_rhs + -- is_lb: see Note [Loop breakers, node scoring, and stability] + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + + old_unf = realIdUnfolding old_bndr + can_unfold = canUnfold old_unf + rhs = case old_unf of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding - rhs_size = case id_unfolding of + rhs_size = case old_unf of CoreUnfolding { uf_guidance = guidance } | UnfIfGoodArgs { ug_size = size } <- guidance -> size _ -> cheapExprSize rhs - can_unfold = canUnfold id_unfolding - id_unfolding = realIdUnfolding old_bndr - -- realIdUnfolding: Ignore loop-breaker-ness here because - -- that is what we are setting! -- Checking for a constructor application -- Cheap and cheerful; the simplifier moves casts out of the way @@ -1508,108 +1561,84 @@ Hence the is_lb field of NodeScore ************************************************************************ -} -occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRhs env Recursive _ bndrs body - = occAnalRecRhs env bndrs body -occAnalRhs env NonRecursive id bndrs body - = occAnalNonRecRhs env id bndrs body - -occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body - -occAnalNonRecRhs :: OccEnv - -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body - -- Binder is already tagged with occurrence info - -> (UsageDetails, [CoreBndr], CoreExpr) - -- Returned usage details covers only the RHS, - -- and *not* the RULE or INLINE template for the Id -occAnalNonRecRhs env bndr bndrs body - = occAnalLamOrRhs rhs_env bndrs body +occAnalRhs :: OccEnv -> Maybe JoinArity + -> CoreExpr -- RHS + -> (UsageDetails, CoreExpr) +occAnalRhs env mb_join_arity rhs + = (rhs_usage, rhs') where - env1 | is_join_point = env -- See Note [Join point RHSs] - | certainly_inline = env -- See Note [Cascading inlines] - | otherwise = rhsCtxt env - - -- See Note [Sources of one-shot information] - rhs_env = env1 { occ_one_shots = argOneShots dmd } - - certainly_inline -- See Note [Cascading inlines] - = case occ of - OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } - -> active && not_stable - _ -> False - - is_join_point = isAlwaysTailCalled occ - -- Like (isJoinId bndr) but happens one step earlier - -- c.f. willBeJoinId_maybe + (bndrs, body) = collectBinders rhs + (body_usage, bndrs', body') = occAnalLamOrRhs env bndrs body + rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so - occ = idOccInfo bndr - dmd = idDemandInfo bndr - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) + -- Final adjustment + rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage occAnalUnfolding :: OccEnv - -> RecFlag - -> Id - -> Maybe UsageDetails - -- Just the analysis, not a new unfolding. The unfolding - -- got analysed when it was created and we don't need to - -- update it. -occAnalUnfolding env rec_flag id - = case realIdUnfolding id of -- ignore previous loop-breaker flag - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | not (isStableSource src) - -> Nothing - | otherwise - -> Just $ markAllMany usage + -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] + -> Unfolding + -> (UsageDetails, Unfolding) +-- Occurrence-analyse a stable unfolding; +-- discard a non-stable one altogether. +occAnalUnfolding env mb_join_arity unf + = case unf of + unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src -> (usage, unf') + | otherwise -> (emptyDetails, unf) + where -- For non-Stable unfoldings we leave them undisturbed, but + -- don't count their usage because the simplifier will discard them. + -- We leave them undisturbed because nodeScore uses their size info + -- to guide its decisions. It's ok to leave un-substituted + -- expressions in the tree because all the variables that were in + -- scope remain in scope; there is no cloning etc. + (usage, rhs') = occAnalRhs env mb_join_arity rhs + + unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules] + | otherwise = unf { uf_tmpl = rhs' } + + unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + -> ( final_usage, unf { df_args = args' } ) where - (bndrs, body) = collectBinders rhs - (usage, _, _) = occAnalRhs env rec_flag id bndrs body + env' = env `addInScope` bndrs + (usage, args') = occAnalList env' args + final_usage = zapDetails (delDetailsList usage bndrs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just $ zapDetails (delDetailsList usage bndrs) - where - usage = andUDsList (map (fst . occAnal env) args) - - _ -> Nothing + unf -> (emptyDetails, unf) occAnalRules :: OccEnv - -> Maybe JoinArity -- If the binder is (or MAY become) a join - -- point, what its join arity is (or WOULD - -- become). See Note [Rules and join points]. - -> RecFlag - -> Id + -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] + -> Id -- Get rules from here -> [(CoreRule, -- Each (non-built-in) rule UsageDetails, -- Usage details for LHS UsageDetails)] -- Usage details for RHS -occAnalRules env mb_expected_join_arity rec_flag id - = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id - , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] +occAnalRules env mb_join_arity bndr + = map occ_anal_rule (idCoreRules bndr) where - occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = (lhs_uds, final_rhs_uds) + occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (rule', lhs_uds', rhs_uds') where - lhs_uds = addManyOccsSet emptyDetails $ - (exprsFreeVars args `delVarSetList` bndrs) - (rhs_bndrs, rhs_body) = collectBinders rhs - (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body + env' = env `addInScope` bndrs + rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules] + | otherwise = rule { ru_args = args', ru_rhs = rhs' } + + (lhs_uds, args') = occAnalList env' args + lhs_uds' = markAllMany $ + lhs_uds `delDetailsList` bndrs + + (rhs_uds, rhs') = occAnal env' rhs -- Note [Rules are extra RHSs] -- Note [Rule dependency info] - final_rhs_uds = adjust_tail_info args $ markAllMany $ - (rhs_uds `delDetailsList` bndrs) - occ_anal_rule _ - = (emptyDetails, emptyDetails) - - adjust_tail_info args uds -- see Note [Rules and join points] - = case mb_expected_join_arity of - Just ar | args `lengthIs` ar -> uds - _ -> markAllNonTailCalled uds + rhs_uds' = markAllNonTailCalledIf (not exact_join) $ + markAllMany $ + rhs_uds `delDetailsList` bndrs + + exact_join = exactJoin mb_join_arity args + -- See Note [Join points and unfoldings/rules] + + occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails) + {- Note [Join point RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1622,6 +1651,19 @@ the FloatIn pass knows to float into join point RHSs; and the simplifier does not float things out of join point RHSs. But it's a simple, cheap thing to do. See #14137. +Note [Unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally unfoldings and rules are already occurrence-analysed, so we +don't want to reconstruct their trees; we just want to analyse them to +find how they use their free variables. + +EXCEPT if there is a binder-swap going on, in which case we do want to +produce a new tree. + +So we have a fast-path that keeps the old tree if the occ_bs_env is +empty. This just saves a bit of allocation and reconstruction; not +a big deal. + Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an rhsCtxt for the RHS of a binding. This tells the @@ -1674,6 +1716,12 @@ for the various clauses. ************************************************************************ -} +occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) +occAnalList _ [] = (emptyDetails, []) +occAnalList env (e:es) = case occAnal env e of { (uds1, e') -> + case occAnalList env es of { (uds2, es') -> + (uds1 `andUDs` uds2, e' : es') } } + occAnal :: OccEnv -> CoreExpr -> (UsageDetails, -- Gives info only about the "interesting" Ids @@ -1690,7 +1738,7 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], []) -- weren't used at all. occAnal _ (Coercion co) - = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) + = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co) -- See Note [Gather occurrences of coercion variables] {- @@ -1711,7 +1759,7 @@ occAnal env (Tick tickish body) = (markAllNonTailCalled usage, Tick tickish body') | Breakpoint _ ids <- tickish - = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') + = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body') -- never substitute for any of the Ids in a Breakpoint | otherwise @@ -1734,7 +1782,7 @@ occAnal env (Cast expr co) -- usage1: if we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. - usage2 = addManyOccsSet usage1 (coVarsOfCo co) + usage2 = addManyOccs usage1 (coVarsOfCo co) -- usage2: see Note [Gather occurrences of coercion variables] in (markAllNonTailCalled usage2, Cast expr' co) } @@ -1762,21 +1810,23 @@ occAnal env (Lam x body) -- Then, the simplifier is careful when partially applying lambdas. occAnal env expr@(Lam _ _) - = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> + = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') -> let - expr' = mkLams tagged_binders body' + expr' = mkLams tagged_bndrs body' usage1 = markAllNonTailCalled usage - one_shot_gp = all isOneShotBndr tagged_binders - final_usage | one_shot_gp = usage1 - | otherwise = markAllInsideLam usage1 + one_shot_gp = all isOneShotBndr tagged_bndrs + final_usage = markAllInsideLamIf (not one_shot_gp) usage1 in (final_usage, expr') } where - (binders, body) = collectBinders expr + (bndrs, body) = collectBinders expr occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> + = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') -> + let alt_env = addBndrSwap scrut' bndr $ + env { occ_encl = OccVanilla } `addInScope` [bndr] + in + case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> let alts_usage = foldr orUDs emptyDetails alts_usage_s (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr @@ -1784,27 +1834,10 @@ occAnal env (Case scrut bndr ty alts) -- Alts can have tail calls, but the scrutinee can't in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} - where - alt_env = mkAltEnv env scrut bndr - occ_anal_alt = occAnalAlt alt_env - - occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v IsInteresting 0, Var v) - -- The 'True' says that the variable occurs in an interesting - -- context; the case has at least one non-default alternative - occ_anal_scrut (Tick t e) alts - | t `tickishScopesLike` SoftScope - -- No reason to not look through all ticks here, but only - -- for soft-scoped ticks we can do so without having to - -- update returned occurrence info (see occAnal) - = second (Tick t) $ occ_anal_scrut e alts - - occ_anal_scrut scrut _alts - = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> + = case occAnal (env `addInScope` bindersOf bind) + body of { (body_usage, body') -> case occAnalBind env NotTopLevel noImpRuleEdges bind body_usage of { (final_usage, new_binds) -> @@ -1845,17 +1878,22 @@ Constructors are rather like lambdas in this way. occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) -> (UsageDetails, Expr CoreBndr) +-- Naked variables (not applied) end up here too occAnalApp env (Var fun, args, ticks) - | null ticks = (uds, mkApps (Var fun) args') - | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') + | null ticks = (all_uds, mkApps fun' args') + | otherwise = (all_uds, mkTicks ticks $ mkApps fun' args') where - uds = fun_uds `andUDs` final_args_uds + (fun', fun_id') = lookupVarEnv (occ_bs_env env) fun + `orElse` (Var fun, fun) + -- See Note [The binder-swap substitution] + + fun_uds = mkOneOcc fun_id' int_cxt n_args + all_uds = fun_uds `andUDs` final_args_uds !(args_uds, args') = occAnalArgs env args one_shots - !final_args_uds - | isRhsEnv env && is_exp = markAllNonTailCalled $ - markAllInsideLam args_uds - | otherwise = markAllNonTailCalled args_uds + !final_args_uds = markAllNonTailCalled $ + markAllInsideLamIf (isRhsEnv env && is_exp) $ + args_uds -- We mark the free vars of the argument of a constructor or PAP -- as "inside-lambda", if it is the RHS of a let(rec). -- This means that nothing gets inlined into a constructor or PAP @@ -1868,7 +1906,11 @@ occAnalApp env (Var fun, args, ticks) n_val_args = valArgCount args n_args = length args - fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args + int_cxt = case occ_encl env of + OccScrut -> IsInteresting + _other | n_val_args > 0 -> IsInteresting + | otherwise -> NotInteresting + is_exp = isExpandableApp fun n_val_args -- See Note [CONLIKE pragma] in GHC.Types.Basic -- The definition of is_exp should match that in GHC.Core.Op.Simplify.prepareRhs @@ -1891,11 +1933,6 @@ occAnalApp env (fun, args, ticks) -- onto the context stack. !(args_uds, args') = occAnalArgs env args [] -zapDetailsIf :: Bool -- If this is true - -> UsageDetails -- Then do zapDetails on this - -> UsageDetails -zapDetailsIf True uds = zapDetails uds -zapDetailsIf False uds = uds {- Note [Sources of one-shot information] @@ -1987,9 +2024,12 @@ scrutinised y). occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr -> (UsageDetails, [CoreBndr], CoreExpr) +-- Tags the returned binders with their OccInfo, but does +-- not do any markInsideLam to the returned usage details occAnalLamOrRhs env [] body = case occAnal env body of (body_usage, body') -> (body_usage, [], body') -- RHS of thunk or nullary join point + occAnalLamOrRhs env (bndr:bndrs) body | isTyVar bndr = -- Important: Keep the environment so that we don't inline into an RHS like @@ -1997,6 +2037,7 @@ occAnalLamOrRhs env (bndr:bndrs) body -- (see the beginning of Note [Cascading inlines]). case occAnalLamOrRhs env bndrs body of (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') + occAnalLamOrRhs env binders body = case occAnal env_body body of { (body_usage, body') -> let @@ -2005,47 +2046,17 @@ occAnalLamOrRhs env binders body in (final_usage, tagged_binders, body') } where - (env_body, binders') = oneShotGroup env binders + env1 = env `addInScope` binders + (env_body, binders') = oneShotGroup env1 binders -occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) - -> CoreAlt - -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt (env, scrut_bind) (con, bndrs, rhs) - = case occAnal env rhs of { (rhs_usage1, rhs1) -> +occAnalAlt :: OccEnv -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt env (con, bndrs, rhs) + = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) -> let (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - -- See Note [Binders in case alternatives] - (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 - in - (alt_usg', (con, tagged_bndrs, rhs2)) } - -wrapAltRHS :: OccEnv - -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv - -> UsageDetails -- usage for entire alt (p -> rhs) - -> [Var] -- alt binders - -> CoreExpr -- alt RHS - -> (UsageDetails, CoreExpr) -wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs - | occ_binder_swap env - , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this - -- handles condition (a) in Note [Binder swap] - , not captured -- See condition (b) in Note [Binder swap] - = ( alt_usg' `andUDs` let_rhs_usg - , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) - where - captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) - - -- The rhs of the let may include coercion variables - -- if the scrutinee was a cast, so we must gather their - -- usage. See Note [Gather occurrences of coercion variables] - -- Moreover, the rhs of the let may mention the case-binder, and - -- we want to gather its occ-info as well - (let_rhs_usg, let_rhs') = occAnal env let_rhs - - (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var + in -- See Note [Binders in case alternatives] + (alt_usg, (con, tagged_bndrs, rhs1)) } -wrapAltRHS _ _ alt_usg _ alt_rhs - = (alt_usg, alt_rhs) {- ************************************************************************ @@ -2058,18 +2069,17 @@ wrapAltRHS _ _ alt_usg _ alt_rhs data OccEnv = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_gbl_scrut :: GlobalScruts - - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - - , occ_rule_act :: Activation -> Bool -- Which rules are active + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] - , occ_binder_swap :: !Bool -- enable the binder_swap - -- See CorePrep Note [Dead code in CorePrep] + -- See Note [The binder-swap substitution] + , occ_bs_env :: VarEnv (OutExpr, OutId) + , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env + -- Domain is Global and Local Ids + -- Range is just Local Ids } -type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] ----------------------------- -- OccEncl is used to control whether to inline into constructor arguments @@ -2079,15 +2089,22 @@ type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] -- z = f (p,q) -- Do inline p,q; it may make a rule fire -- So OccEncl tells enough about the context to know what to do when -- we encounter a constructor application or PAP. +-- +-- OccScrut is used to set the "interesting context" field of OncOcc data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + + | OccScrut -- Scrutintee of a case + -- Can inline into constructor args + + | OccVanilla -- Argument of function, body of lambda, etc + -- Do inline into constructor args here instance Outputable OccEncl where ppr OccRhs = text "occRhs" + ppr OccScrut = text "occScrut" ppr OccVanilla = text "occVanilla" -- See note [OneShots] @@ -2097,15 +2114,30 @@ initOccEnv :: OccEnv initOccEnv = OccEnv { occ_encl = OccVanilla , occ_one_shots = [] - , occ_gbl_scrut = emptyVarSet + -- To be conservative, we say that all -- inlines and rules are active , occ_unf_act = \_ -> True , occ_rule_act = \_ -> True - , occ_binder_swap = True } -vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } + , occ_bs_env = emptyVarEnv + , occ_bs_rng = emptyVarSet } + +noBinderSwaps :: OccEnv -> Bool +noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env + +scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv +scrutCtxt env alts + | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] } + | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] } + where + interesting_alts = case alts of + [] -> False + [alt] -> not (isDefaultAlt alt) + _ -> True + -- 'interesting_alts' is True if the case has at least one + -- non-default alternative. That in turn influences + -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! rhsCtxt :: OccEnv -> OccEnv rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } @@ -2117,8 +2149,15 @@ argCtxt env (one_shots:one_shots_s) = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = OccRhs }) = True -isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False +isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of + OccRhs -> True + _ -> False + +addInScope :: OccEnv -> [Var] -> OccEnv +-- See Note [The binder-swap substitution] +addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs + | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } + | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs } oneShotGroup :: OccEnv -> [CoreBndr] -> ( OccEnv @@ -2222,14 +2261,14 @@ scrutinee of a case for occurrences of the case-binder: (1) case x of b { pi -> ri } ==> - case x of b { pi -> let x=b in ri } + case x of b { pi -> ri[b/x] } (2) case (x |> co) of b { pi -> ri } ==> - case (x |> co) of b { pi -> let x = b |> sym co in ri } + case (x |> co) of b { pi -> ri[b |> sym co/x] } -In both cases, the trivial 'let' can be eliminated by the -immediately following simplifier pass. +The substitution ri[b/x] etc is done by the occurrence analyser. +See Note [The binder-swap substitution]. There are two reasons for making this swap: @@ -2257,20 +2296,6 @@ There are two reasons for making this swap: The same can happen even if the scrutinee is a variable with a cast: see Note [Case of cast] -In both cases, in a particular alternative (pi -> ri), we only -add the binding if - (a) x occurs free in (pi -> ri) - (ie it occurs in ri, but is not bound in pi) - (b) the pi does not bind b (or the free vars of co) -We need (a) and (b) for the inserted binding to be correct. - -For the alternatives where we inject the binding, we can transfer -all x's OccInfo to b. And that is the point. - -Notice that - * The deliberate shadowing of 'x'. - * That (a) rapidly becomes false, so no bindings are injected. - The reason for doing these transformations /here in the occurrence analyser/ is because it allows us to adjust the OccInfo for 'x' and 'b' as we go. @@ -2279,15 +2304,9 @@ analyser/ is because it allows us to adjust the OccInfo for 'x' and ri; then this transformation makes it occur just once, and hence get inlined right away. - * If instead we do this in the Simplifier, we don't know whether 'x' - is used in ri, so we are forced to pessimistically zap b's OccInfo - even though it is typically dead (ie neither it nor x appear in - the ri). There's nothing actually wrong with zapping it, except - that it's kind of nice to know which variables are dead. My nose - tells me to keep this information as robustly as possible. - -The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding -{x=b}; it's Nothing if the binder-swap doesn't happen. + * If instead the Simplifier replaces occurrences of x with + occurrences of b, that will mess up b's occurrence info. That in + turn might have consequences. There is a danger though. Consider let v = x +# y @@ -2299,6 +2318,75 @@ same simplifier pass that reduced (f v) to v. I think this is just too bad. CSE will recover some of it. +Note [The binder-swap substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder-swap is implemented by the occ_bs_env field of OccEnv. +Given case x |> co of b { alts } +we add [x :-> (b |> sym co)] to the occ_bs_env environment; this is +done by addBndrSwap. Then, at an occurrence of a variable, we look +up in the occ_bs_env to perform the swap. See occAnalApp. + +Some tricky corners: + +* We do the substitution before gathering occurrence info. So in + the above example, an occurrence of x turns into an occurrence + of b, and that's what we gather in the UsageDetails. It's as + if the binder-swap occurred before occurrence analysis. + +* We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, + and we encounter: + - \x. blah + Here we want to delete the x-binding from occ_bs_env + + - \b. blah + This is harder: we really want to delete all bindings that + have 'b' free in the range. That is a bit tiresome to implement, + so we compromise. We keep occ_bs_rng, which is the set of + free vars of rng(occc_bs_env). If a binder shadows any of these + variables, we discard all of occ_bs_env. Safe, if a bit + brutal. NB, however: the simplifer de-shadows the code, so the + next time around this won't happen. + + These checks are implemented in addInScope. + +* The occurrence analyser itself does /not/ do cloning. It could, in + principle, but it'd make it a bit more complicated and there is no + great benefit. The simplifer uses cloning to get a no-shadowing + situation, the care-when-shadowing behaviour above isn't needed for + long. + +* The domain of occ_bs_env can include GlobaIds. Eg + case M.foo of b { alts } + We extend occ_bs_env with [M.foo :-> b]. That's fine. + +* We have to apply the substitution uniformly, including to rules and + unfoldings. + +Historical note +--------------- +We used to do the binder-swap transformation by introducing +a proxy let-binding, thus; + + case x of b { pi -> ri } + ==> + case x of b { pi -> let x = b in ri } + +But that had two problems: + +1. If 'x' is an imported GlobalId, we'd end up with a GlobalId + on the LHS of a let-binding which isn't allowed. We worked + around this for a while by "localising" x, but it turned + out to be very painful #16296, + +2. In CorePrep we use the occurrence analyser to do dead-code + elimination (see Note [Dead code in CorePrep]). But that + occasionally led to an unlifted let-binding + case x of b { DEFAULT -> let x::Int# = b in ... } + which disobeys one of CorePrep's output invariants (no unlifted + let-bindings) -- see #5433. + +Doing a substitution (via occ_bs_env) is much better. + Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ Consider case (x `cast` co) of b { I# -> @@ -2307,25 +2395,12 @@ We'd like to eliminate the inner case. That is the motivation for equation (2) in Note [Binder swap]. When we get to the inner case, we inline x, cancel the casts, and away we go. -Note [Binder swap on GlobalId scrutinees] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the scrutinee is a GlobalId we must take care in two ways - - i) In order to *know* whether 'x' occurs free in the RHS, we need its - occurrence info. BUT, we don't gather occurrence info for - GlobalIds. That's the reason for the (small) occ_gbl_scrut env in - OccEnv is for: it says "gather occurrence info for these". - - ii) We must call localiseId on 'x' first, in case it's a GlobalId, or - has an External Name. See, for example, SimplEnv Note [Global Ids in - the substitution]. - Note [Zap case binders in proxy bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ From the original case x of cb(dead) { p -> ...x... } we will get - case x of cb(live) { p -> let x = cb in ...x... } + case x of cb(live) { p -> ...cb... } Core Lint never expects to find an *occurrence* of an Id marked as Dead, so we must zap the OccInfo on cb before making the @@ -2396,37 +2471,25 @@ binder-swap unconditionally and still get occurrence analysis information right. -} -mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does three things: a) makes the occ_one_shots = OccVanilla --- b) extends the GlobalScruts if possible --- c) returns a proxy mapping, binding the scrutinee --- to the case binder, if possible -mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr - = case stripTicksTopE (const True) scrut of - Var v -> add_scrut v case_bndr' - Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) - -- See Note [Case of cast] - _ -> (env { occ_encl = OccVanilla }, Nothing) +addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [The binder-swap substitution] +addBndrSwap scrut case_bndr + env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) + | Just (v, rhs) <- try_swap (stripTicksTopE (const True) scrut) + = env { occ_bs_env = extendVarEnv swap_env v (rhs, case_bndr') + , occ_bs_rng = rng_vars `unionVarSet` exprFreeVars rhs } + | otherwise + = env where - add_scrut v rhs - | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) - | otherwise = ( env { occ_encl = OccVanilla - , occ_gbl_scrut = pe `extendVarSet` v } - , Just (localise v, rhs) ) - -- ToDO: this isGlobalId stuff is a TEMPORARY FIX - -- to avoid the binder-swap for GlobalIds - -- See #16346 - - case_bndr' = Var (zapIdOccInfo case_bndr) - -- See Note [Zap case binders in proxy bindings] - - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLINE or NOINLINE pragmas! - localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) - (idType scrut_var) + try_swap :: OutExpr -> Maybe (OutVar, OutExpr) + try_swap (Var v) = Just (v, Var case_bndr') + try_swap (Cast (Var v) co) = Just (v, Cast (Var case_bndr') (mkSymCo co)) + -- See Note [Case of cast] + try_swap _ = Nothing + + case_bndr' = zapIdOccInfo case_bndr + -- See Note [Zap case binders in proxy bindings] {- ************************************************************************ @@ -2437,7 +2500,6 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr Note [UsageDetails and zapping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - On many occasions, we must modify all gathered occurrence data at once. For instance, all occurrences underneath a (non-one-shot) lambda set the 'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but @@ -2476,45 +2538,36 @@ andUDs, orUDs andUDs = combineUsageDetailsWith addOccInfo orUDs = combineUsageDetailsWith orOccInfo -andUDsList :: [UsageDetails] -> UsageDetails -andUDsList = foldl' andUDs emptyDetails - -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails -mkOneOcc env id int_cxt arity +mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc id int_cxt arity | isLocalId id - = singleton $ OneOcc { occ_in_lam = NotInsideLam - , occ_one_br = InOneBranch - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled arity } - | id `elemVarSet` occ_gbl_scrut env - = singleton noOccInfo - + = emptyDetails { ud_env = unitVarEnv id occ_info } | otherwise = emptyDetails where - singleton info = emptyDetails { ud_env = unitVarEnv id info } - -addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails -addOneOcc ud id info - = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } - `alterZappedSets` (`delVarEnv` id) - where - plus_zapped old new = doZapping ud id old `addOccInfo` new + occ_info = OneOcc { occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch + , occ_int_cxt = int_cxt + , occ_tail = AlwaysTailCalled arity } -addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails -addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set - -- It's OK to use nonDetFoldUFM here because addManyOccs commutes +addManyOccId :: UsageDetails -> Id -> UsageDetails +-- Add the non-committal (id :-> noOccInfo) to the usage details +addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo } -- Add several occurrences, assumed not to be tail calls -addManyOccs :: Var -> UsageDetails -> UsageDetails -addManyOccs v u | isId v = addOneOcc u v noOccInfo - | otherwise = u +addManyOcc :: Var -> UsageDetails -> UsageDetails +addManyOcc v u | isId v = addManyOccId u v + | otherwise = u -- Give a non-committal binder info (i.e noOccInfo) because -- a) Many copies of the specialised thing can appear -- b) We don't want to substitute a BIG expression inside a RULE -- even if that's the only occurrence of the thing -- (Same goes for INLINE.) +addManyOccs :: UsageDetails -> VarSet -> UsageDetails +addManyOccs usage id_set = nonDetFoldUniqSet addManyOcc usage id_set + -- It's OK to use nonDetFoldUFM here because addManyOcc commutes + delDetails :: UsageDetails -> Id -> UsageDetails delDetails ud bndr = ud `alterUsageDetails` (`delVarEnv` bndr) @@ -2538,8 +2591,23 @@ markAllMany ud = ud { ud_z_many = ud_env ud } markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } +markAllInsideLamIf, markAllNonTailCalledIf :: Bool -> UsageDetails -> UsageDetails + +markAllInsideLamIf True ud = markAllInsideLam ud +markAllInsideLamIf False ud = ud + +markAllNonTailCalledIf True ud = markAllNonTailCalled ud +markAllNonTailCalledIf False ud = ud + + zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo +zapDetailsIf :: Bool -- If this is true + -> UsageDetails -- Then do zapDetails on this + -> UsageDetails +zapDetailsIf True uds = zapDetails uds +zapDetailsIf False uds = uds + lookupDetails :: UsageDetails -> Id -> OccInfo lookupDetails ud id | isCoVar id -- We do not currently gather occurrence info (from types) @@ -2595,14 +2663,17 @@ doZapping ud var occ = doZappingByUnique ud (varUnique var) occ doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo -doZappingByUnique ud uniq - = (if | in_subset ud_z_many -> markMany - | in_subset ud_z_in_lam -> markInsideLam - | otherwise -> id) . - (if | in_subset ud_z_no_tail -> markNonTailCalled - | otherwise -> id) +doZappingByUnique (UD { ud_z_many = many + , ud_z_in_lam = in_lam + , ud_z_no_tail = no_tail }) + uniq occ + = occ2 where - in_subset field = uniq `elemVarEnvByKey` field ud + occ1 | uniq `elemVarEnvByKey` many = markMany occ + | uniq `elemVarEnvByKey` in_lam = markInsideLam occ + | otherwise = occ + occ2 | uniq `elemVarEnvByKey` no_tail = markNonTailCalled occ1 + | otherwise = occ1 alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails alterZappedSets ud f @@ -2612,8 +2683,7 @@ alterZappedSets ud f alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails alterUsageDetails ud f - = ud { ud_env = f (ud_env ud) } - `alterZappedSets` f + = ud { ud_env = f (ud_env ud) } `alterZappedSets` f flattenUsageDetails :: UsageDetails -> UsageDetails flattenUsageDetails ud @@ -2623,25 +2693,26 @@ flattenUsageDetails ud ------------------- -- See Note [Adjusting right-hand sides] adjustRhsUsage :: Maybe JoinArity -> RecFlag - -> [CoreBndr] -- Outer lambdas, AFTER occ anal - -> UsageDetails -> UsageDetails + -> [CoreBndr] -- Outer lambdas, AFTER occ anal + -> UsageDetails -- From body of lambda + -> UsageDetails adjustRhsUsage mb_join_arity rec_flag bndrs usage - = maybe_mark_lam (maybe_drop_tails usage) + = markAllInsideLamIf (not one_shot) $ + markAllNonTailCalledIf (not exact_join) $ + usage where - maybe_mark_lam ud | one_shot = ud - | otherwise = markAllInsideLam ud - maybe_drop_tails ud | exact_join = ud - | otherwise = markAllNonTailCalled ud - one_shot = case mb_join_arity of Just join_arity | isRec rec_flag -> False | otherwise -> all isOneShotBndr (drop join_arity bndrs) Nothing -> all isOneShotBndr bndrs - exact_join = case mb_join_arity of - Just join_arity -> bndrs `lengthIs` join_arity - _ -> False + exact_join = exactJoin mb_join_arity bndrs + +exactJoin :: Maybe JoinArity -> [a] -> Bool +exactJoin Nothing _ = False +exactJoin (Just join_arity) args = args `lengthIs` join_arity + -- Remember join_arity includes type binders type IdWithOccInfo = Id @@ -2668,7 +2739,7 @@ tagLamBinder usage bndr bndr' = setBinderOcc (markNonTailCalled occ) bndr -- Don't try to make an argument into a join point usage1 = usage `delDetails` bndr - usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) + usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr) -- This is effectively the RHS of a -- non-join-point binding, so it's okay to use -- addManyOccsSet, which assumes no tail calls diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs index 5d7d91a37f..fcf2eaf168 100644 --- a/compiler/GHC/Core/Op/Simplify.hs +++ b/compiler/GHC/Core/Op/Simplify.hs @@ -45,7 +45,8 @@ import GHC.Core.Unfold import GHC.Core.Utils import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg , joinPointBinding_maybe, joinPointBindings_maybe ) -import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel, RecFlag(..), Arity ) import MonadUtils ( mapAccumLM, liftIO ) @@ -1422,7 +1423,7 @@ simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- fw a b x{=(a,b)} = ... -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. simplLamBndr env bndr - | isId bndr && isFragileUnfolding old_unf -- Special case + | isId bndr && hasCoreUnfolding old_unf -- Special case = do { (env1, bndr1) <- simplBinder env bndr ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr old_unf (idType bndr1) @@ -2883,7 +2884,7 @@ the unfolding (a,b), and *that* mentions b. If f has a RULE RULE f (p, I# q) = ... we want that rule to match, so we must extend the in-scope env with a suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimintation -- suppose that 'f' was inlined +it's also good for case-elimination -- suppose that 'f' was inlined and did multi-level case analysis, then we'd solve it in one simplifier sweep instead of two. diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs index 4b85bff280..1b8c21f81b 100644 --- a/compiler/GHC/Core/Op/Simplify/Utils.hs +++ b/compiler/GHC/Core/Op/Simplify/Utils.hs @@ -1872,22 +1872,26 @@ Historical note: if you use let-bindings instead of a substitution, beware of th prepareAlts tries these things: -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. e.g. case e of x { DEFAULT -> rhs } ===> case e of x { (a,b) -> rhs } where the type is a single constructor type. This gives better code when rhs also scrutinises x or e. + See CoreUtils Note [Refine DEFAULT case alternatives] -3. Returns a list of the constructors that cannot holds in the - DEFAULT alternative (if there is one) +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts -Here "cannot match" includes knowledge from GADTs +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) It's a good idea to do this stuff before simplifying the alternatives, to avoid simplifying alternatives we know can't happen, and to come up with diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 0b1c0cccb9..dc2b203645 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -17,7 +17,7 @@ module GHC.Core.Rules ( ruleCheckProgram, -- ** Manipulating 'RuleInfo' rules - mkRuleInfo, extendRuleInfo, addRuleInfo, + extendRuleInfo, addRuleInfo, addIdSpecialisations, -- * Misc. CoreRule helpers @@ -279,11 +279,6 @@ pprRulesForUser dflags rules ************************************************************************ -} --- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable --- for putting into an 'IdInfo' -mkRuleInfo :: [CoreRule] -> RuleInfo -mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) - extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo extendRuleInfo (RuleInfo rs1 fvs1) rs2 = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index e36e4fb289..2770882d67 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -618,7 +618,7 @@ substIdInfo subst new_id info where old_rules = ruleInfo info old_unf = unfoldingInfo info - nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) + nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf) ------------------ -- | Substitutes for the 'Id's within an unfolding diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 411a954428..58d460c826 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -22,9 +22,9 @@ find, unsurprisingly, a Core expression. module GHC.Core.Unfold ( Unfolding, UnfoldingGuidance, -- Abstract types - noUnfolding, mkImplicitUnfolding, + noUnfolding, mkUnfolding, mkCoreUnfolding, - mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, mkInlineUnfolding, mkInlineUnfoldingWithArity, mkInlinableUnfolding, mkWwInlineRule, mkCompulsoryUnfolding, mkDFunUnfolding, @@ -48,12 +48,12 @@ import GhcPrelude import GHC.Driver.Session import GHC.Core -import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap ) +import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) import GHC.Core.SimpleOpt import GHC.Core.Arity ( manifestArity ) import GHC.Core.Utils import GHC.Types.Id -import GHC.Types.Demand ( isBottomingSig ) +import GHC.Types.Demand ( StrictSig, isBottomingSig ) import GHC.Core.DataCon import GHC.Types.Literal import PrimOp @@ -80,14 +80,22 @@ import Data.List ************************************************************************ -} -mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding -mkTopUnfolding dflags is_bottoming rhs - = mkUnfolding dflags InlineRhs True is_bottoming rhs +mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding +-- "Final" in the sense that this is a GlobalId that will not be further +-- simplified; so the unfolding should be occurrence-analysed +mkFinalUnfolding dflags src strict_sig expr + = mkUnfolding dflags src + True {- Top level -} + (isBottomingSig strict_sig) + expr + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr unsafeGlobalDynFlags expr) + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) -mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding --- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding dflags expr - = mkTopUnfolding dflags False (simpleOptExpr dflags expr) -- Note [Top-level flag on inline rules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -103,7 +111,7 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops = DFunUnfolding { df_bndrs = bndrs , df_con = con - , df_args = map occurAnalyseExpr_NoBinderSwap ops } + , df_args = map occurAnalyseExpr ops } -- See Note [Occurrence analysis of unfoldings] mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding @@ -113,13 +121,6 @@ mkWwInlineRule dflags expr arity (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk , ug_boring_ok = boringCxtNotOk }) -mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding InlineCompulsory True - (simpleOptExpr unsafeGlobalDynFlags expr) - (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter - , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) - mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding -- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Op.WorkWrap mkWorkerUnfolding dflags work_fn @@ -309,20 +310,6 @@ I'm a bit worried that it's possible for the same kind of problem to arise for non-0-ary functions too, but let's wait and see. -} -mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr - -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding src top_lvl expr guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, - -- See Note [Occurrence analysis of unfoldings] - uf_src = src, - uf_is_top = top_lvl, - uf_is_value = exprIsHNF expr, - uf_is_conlike = exprIsConLike expr, - uf_is_work_free = exprIsWorkFree expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } - mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -- Is top-level -> Bool -- Definitely a bottoming binding @@ -331,21 +318,28 @@ mkUnfolding :: DynFlags -> UnfoldingSource -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it -mkUnfolding dflags src is_top_lvl is_bottoming expr - = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, +mkUnfolding dflags src top_lvl is_bottoming expr + = mkCoreUnfolding src top_lvl expr guidance + where + is_top_bottoming = top_lvl && is_bottoming + guidance = calcUnfoldingGuidance dflags is_top_bottoming expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, -- See Note [Occurrence analysis of unfoldings] uf_src = src, - uf_is_top = is_top_lvl, + uf_is_top = top_lvl, uf_is_value = exprIsHNF expr, uf_is_conlike = exprIsConLike expr, - uf_expandable = exprIsExpandable expr, uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, uf_guidance = guidance } - where - is_top_bottoming = is_top_lvl && is_bottoming - guidance = calcUnfoldingGuidance dflags is_top_bottoming expr - -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! - -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + {- Note [Occurrence analysis of unfoldings] @@ -366,39 +360,6 @@ But more generally, the simplifier is designed on the basis that it is looking at occurrence-analysed expressions, so better ensure that they actually are. -We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr; -see Note [No binder swap in unfoldings]. - -Note [No binder swap in unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The binder swap can temporarily violate Core Lint, by assigning -a LocalId binding to a GlobalId. For example, if A.foo{r872} -is a GlobalId with unique r872, then - - case A.foo{r872} of bar { - K x -> ...(A.foo{r872})... - } - -gets transformed to - - case A.foo{r872} of bar { - K x -> let foo{r872} = bar - in ...(A.foo{r872})... - -This is usually not a problem, because the simplifier will transform -this to: - - case A.foo{r872} of bar { - K x -> ...(bar)... - -However, after occurrence analysis but before simplification, this extra 'let' -violates the Core Lint invariant that we do not have local 'let' bindings for -GlobalIds. That seems (just) tolerable for the occurrence analysis that happens -just before the Simplifier, but not for unfoldings, which are Linted -independently. -As a quick workaround, we disable binder swap in this module. -See #16288 and #16296 for further plans. - Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 4663f54b26..526ba34fd0 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -696,7 +696,7 @@ filterAlts _tycon inst_tys imposs_cons alts impossible_alt _ _ = False -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. --- See Note [Refine Default Alts] +-- See Note [Refine DEFAULT case alternatives] refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders -> TyCon -- ^ Type constructor of scrutinee's type -> [Type] -- ^ Type arguments of scrutinee's type @@ -739,95 +739,62 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts | otherwise -- The common case = (False, all_alts) -{- Note [Refine Default Alts] - -refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one -possible value it could be. +{- Note [Refine DEFAULT case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +refineDefaultAlt replaces the DEFAULT alt with a constructor if there +is one possible value it could be. The simplest example being + foo :: () -> () + foo x = case x of !_ -> () +which rewrites to + foo :: () -> () + foo x = case x of () -> () + +There are two reasons in general why replacing a DEFAULT alternative +with a specific constructor is desirable. + +1. We can simplify inner expressions. For example + + data Foo = Foo1 () + + test :: Foo -> () + test x = case x of + DEFAULT -> mid (case x of + Foo1 x1 -> x1) + + refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then + x becomes bound to `Foo ip1` so is inlined into the other case + which causes the KnownBranch optimisation to kick in. If we don't + refine DEFAULT to `Foo ip1`, we are left with both case expressions. + +2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi) + data D = C0 | C1 | C2 + + case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 + + When we apply combineIdenticalAlts to this expression, it can't + combine the alts for C0 and C1, as we already have a default case. + But if we apply refineDefaultAlt first, we get + case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 + and combineIdenticalAlts can turn that into + case e of + DEFAULT -> e1 + C2 -> e0 -foo :: () -> () -foo x = case x of !_ -> () - -rewrites to - -foo :: () -> () -foo x = case x of () -> () - -There are two reasons in general why this is desirable. - -1. We can simplify inner expressions - -In this example we can eliminate the inner case by refining the outer case. -If we don't refine it, we are left with both case expressions. - -``` -{-# LANGUAGE BangPatterns #-} -module Test where - -mid x = x -{-# NOINLINE mid #-} - -data Foo = Foo1 () - -test :: Foo -> () -test x = - case x of - !_ -> mid (case x of - Foo1 x1 -> x1) - -``` - -refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x -becomes bound to `Foo ip1` so is inlined into the other case which -causes the KnownBranch optimisation to kick in. - - -2. combineIdenticalAlts does a better job - -Simon Jakobi also points out that that combineIdenticalAlts will do a better job -if we refine the DEFAULT first. - -``` -data D = C0 | C1 | C2 - -case e of - DEFAULT -> e0 - C0 -> e1 - C1 -> e1 -``` - -When we apply combineIdenticalAlts to this expression, it can't -combine the alts for C0 and C1, as we already have a default case. - -If we apply refineDefaultAlt first, we get - -``` -case e of - C0 -> e1 - C1 -> e1 - C2 -> e0 -``` - -and combineIdenticalAlts can turn that into - -``` -case e of - DEFAULT -> e1 - C2 -> e0 -``` - -It isn't obvious that refineDefaultAlt does this but if you look at its one call -site in GHC.Core.Op.Simplify.Utils then the `imposs_deflt_cons` argument is -populated with constructors which are matched elsewhere. - --} - - - + It isn't obvious that refineDefaultAlt does this but if you look + at its one call site in GHC.Core.Op.Simplify.Utils then the + `imposs_deflt_cons` argument is populated with constructors which + are matched elsewhere. -{- Note [Combine identical alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If several alternatives are identical, merge them into a single DEFAULT alternative. I've occasionally seen this making a big difference: diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index b6a14b4af5..5cdf084a33 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -347,10 +347,7 @@ The way we fix this is to: * In cloneBndr, drop all unfoldings/rules * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. For that call to OccAnal, we - disable the binder swap, else the occurrence analyser sometimes - introduces new let bindings for cased binders, which lead to the bug - in #5433. + RHS to drop the dead local bindings. The reason we don't just OccAnal the whole output of CorePrep is that the tidier ensures that all top-level binders are GlobalIds, so they @@ -1316,14 +1313,13 @@ deFloatTop :: Floats -> [CoreBind] deFloatTop (Floats _ floats) = foldrOL get [] floats where - get (FloatLet b) bs = occurAnalyseRHSs b : bs - get (FloatCase body var _ _ _) bs - = occurAnalyseRHSs (NonRec var body) : bs + get (FloatLet b) bs = get_bind b : bs + get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs get b _ = pprPanic "corePrepPgm" (ppr b) -- See Note [Dead code in CorePrep] - occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) - occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] --------------------------------------------------------------------------- diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 6459902a52..4bd11d227d 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -1239,8 +1239,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | otherwise = minimal_unfold_info minimal_unfold_info = zapUnfolding unf_info - unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs - is_bot = isBottomingSig final_sig + unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 0024d92037..559587664e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -63,7 +63,6 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) -import GHC.Types.Demand import GHC.Types.Module import GHC.Types.Unique.FM import GHC.Types.Unique.Supply @@ -1506,14 +1505,12 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) | otherwise = InlineRhs ; return $ case mb_expr of Nothing -> NoUnfolding - Just expr -> mkUnfolding dflags unf_src - True {- Top level -} - (isBottomingSig strict_sig) - expr + Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr } where -- Strictness should occur before unfolding! strict_sig = strictnessInfo info + tcUnfolding toplvl name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr True toplvl name if_expr ; return (case mb_expr of diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index 538556c6af..4fbcf47a02 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -92,6 +92,7 @@ import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax import Outputable +import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) import Data.List (mapAccumL) @@ -391,6 +392,7 @@ stgCsePairs env0 ((b,e):pairs) stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) stgCseRhs env bndr (StgRhsCon ccs dataCon args) | Just other_bndr <- envLookup dataCon args' env + , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env in (Nothing, env') | otherwise @@ -399,6 +401,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args) pair = (bndr, StgRhsCon ccs dataCon args') in (Just pair, env') where args' = substArgs env args + stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) = let (env1, args') = substBndrs env args env2 = forgetCse env1 -- See note [Free variables of an StgClosure] @@ -416,6 +419,21 @@ mkStgCase scrut bndr ty alts | all isBndr alts = scrut isBndr _ = False +{- Note [Care with loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing CSE on a letrec we must be careful about loop +breakers. Consider + rec { y = K z + ; z = K z } +Now if, somehow (and wrongly)), y and z are both marked as +loop-breakers, we do *not* want to drop the (z = K z) binding +in favour of a substitution (z :-> y). + +I think this bug will only show up if the loop-breaker-ness is done +wrongly (itself a bug), but it still seems better to do the right +thing regardless. +-} + -- Utilities -- | This function short-cuts let-bindings that are now obsolete diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index e731fc1449..9f3b192848 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -86,7 +86,8 @@ module GHC.Types.Id.Info ( import GhcPrelude -import GHC.Core +import GHC.Core hiding( hasCoreUnfolding ) +import GHC.Core( hasCoreUnfolding ) import GHC.Core.Class import {-# SOURCE #-} PrimOp (PrimOp) @@ -567,8 +568,8 @@ zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) zapFragileUnfolding :: Unfolding -> Unfolding zapFragileUnfolding unf - | isFragileUnfolding unf = noUnfolding - | otherwise = unf + | hasCoreUnfolding unf = noUnfolding + | otherwise = unf zapUnfolding :: Unfolding -> Unfolding -- Squash all unfolding info, preserving only evaluated-ness diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 43b7aae72d..58a02f2f3d 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -42,7 +42,6 @@ module GHC.Types.Id.Make ( import GhcPrelude -import GHC.Core.Rules import TysPrim import TysWiredIn import GHC.Core.Op.ConstantFold @@ -52,7 +51,8 @@ import GHC.Core.FamInstEnv import GHC.Core.Coercion import TcType import GHC.Core.Make -import GHC.Core.Utils ( mkCast, mkDefaultCase ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Utils ( mkCast, mkDefaultCase ) import GHC.Core.Unfold import GHC.Types.Literal import GHC.Core.TyCon diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr index 56da989d37..e9496e19e6 100644 --- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr +++ b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr @@ -1,5 +1,5 @@ Simplifier ticks exhausted - When trying UnfoldingDone delta + When trying UnfoldingDone delta1 To increase the limit, use -fsimpl-tick-factor=N (default 100). If you need to increase the limit substantially, please file a @@ -12,4 +12,4 @@ Simplifier ticks exhausted simplifier non-termination has been judged acceptable. To see detailed counts use -ddump-simpl-stats - Total ticks: 140086 + Total ticks: 140082 diff --git a/testsuite/tests/simplCore/should_compile/T17901.stdout b/testsuite/tests/simplCore/should_compile/T17901.stdout index 406e81ef5f..99969cc0c1 100644 --- a/testsuite/tests/simplCore/should_compile/T17901.stdout +++ b/testsuite/tests/simplCore/should_compile/T17901.stdout @@ -4,13 +4,11 @@ C -> wombat1 T17901.C = \ (@p) (wombat1 :: T -> p) (x :: T) -> case x of wild { __DEFAULT -> wombat1 wild } - (wombat2 [Occ=Once*!] :: S -> p) - SA _ [Occ=Dead] -> wombat2 wild; - SB -> wombat2 T17901.SB + Tmpl= \ (@p) (wombat2 [Occ=Once!] :: S -> p) (x [Occ=Once] :: S) -> + case x of wild [Occ=Once] { __DEFAULT -> wombat2 wild }}] = \ (@p) (wombat2 :: S -> p) (x :: S) -> case x of wild { __DEFAULT -> wombat2 wild } - (wombat3 [Occ=Once*!] :: W -> p) - WB -> wombat3 T17901.WB; - WA _ [Occ=Dead] -> wombat3 wild + Tmpl= \ (@p) (wombat3 [Occ=Once!] :: W -> p) (x [Occ=Once] :: W) -> + case x of wild [Occ=Once] { __DEFAULT -> wombat3 wild }}] = \ (@p) (wombat3 :: W -> p) (x :: W) -> case x of wild { __DEFAULT -> wombat3 wild } diff --git a/testsuite/tests/simplCore/should_compile/T7360.hs b/testsuite/tests/simplCore/should_compile/T7360.hs index 2bf31f200a..4da49041f8 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.hs +++ b/testsuite/tests/simplCore/should_compile/T7360.hs @@ -6,7 +6,7 @@ module T7360 where import GHC.List as L data Foo = Foo1 | Foo2 | Foo3 !Int - + fun1 :: Foo -> () {-# NOINLINE fun1 #-} fun1 x = case x of @@ -14,7 +14,7 @@ fun1 x = case x of Foo2 -> () Foo3 {} -> () -fun2 x = (fun1 Foo1, -- Keep -ddump-simpl output +fun2 x = (fun1 Foo1, -- Keep -ddump-simpl output -- in a predictable order case x of [] -> L.length x diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index b74aee564e..45c88f376e 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 114, types: 53, coercions: 0, joins: 0/0} + = {terms: 106, types: 47, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo @@ -25,21 +25,13 @@ fun1 [InlPrag=NOINLINE] :: Foo -> () fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.fun5 :: () +T7360.fun4 :: () [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] -T7360.fun5 = fun1 T7360.Foo1 +T7360.fun4 = fun1 T7360.Foo1 --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.fun4 :: Int -[GblId, - Cpr=m1, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -T7360.fun4 = GHC.Types.I# 0# - --- RHS size: {terms: 16, types: 13, coercions: 0, joins: 0/0} +-- RHS size: {terms: 11, types: 8, coercions: 0, joins: 0/0} fun2 :: forall {a}. [a] -> ((), Int) [GblId, Arity=1, @@ -48,24 +40,18 @@ fun2 :: forall {a}. [a] -> ((), Int) Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) (x [Occ=Once!] :: [a]) -> - (T7360.fun5, - case x of wild [Occ=Once] { - [] -> T7360.fun4; - : _ [Occ=Dead] _ [Occ=Dead] -> - case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once] { __DEFAULT -> - GHC.Types.I# ww2 - } + Tmpl= \ (@a) (x [Occ=Once] :: [a]) -> + (T7360.fun4, + case x of wild [Occ=Once] { __DEFAULT -> + case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once] { __DEFAULT -> + GHC.Types.I# ww2 + } })}] fun2 = \ (@a) (x :: [a]) -> - (T7360.fun5, - case x of wild { - [] -> T7360.fun4; - : ds ds1 -> - case GHC.List.$wlenAcc @a wild 0# of ww2 { __DEFAULT -> - GHC.Types.I# ww2 - } + (T7360.fun4, + case GHC.List.$wlenAcc @a x 0# of ww2 { __DEFAULT -> + GHC.Types.I# ww2 }) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} |