diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/CSE.lhs | 285 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 17 | ||||
| -rw-r--r-- | compiler/simplCore/FloatIn.lhs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.lhs | 210 | ||||
| -rw-r--r-- | compiler/simplCore/SimplMonad.lhs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.lhs | 81 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 72 |
7 files changed, 329 insertions, 342 deletions
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 8bd15864c7..1d9ef45f7f 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -4,67 +4,42 @@ \section{Common subexpression} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CSE ( - cseProgram - ) where +module CSE (cseProgram) where #include "HsVersions.h" --- Note [Keep old CSEnv rep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- Temporarily retain code for the old representation for CSEnv --- Keeping it only so that we can switch back if a bug shows up --- or we want to do some performance comparisions --- --- NB: when you remove this, also delete hashExpr from CoreUtils -#ifdef OLD_CSENV_REP -import CoreUtils ( exprIsBig, hashExpr, eqExpr ) -import StaticFlags ( opt_PprStyle_Debug ) -import Util ( lengthExceeds ) -import UniqFM -import FastString -#else -import TrieMap -#endif - import CoreSubst -import Var ( Var ) -import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( mkAltExpr +import Var ( Var ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) +import CoreUtils ( mkAltExpr , exprIsTrivial) -import Type ( tyConAppArgs ) +import Type ( tyConAppArgs ) import CoreSyn import Outputable -import BasicTypes ( isAlwaysActive ) +import BasicTypes ( isAlwaysActive ) +import TrieMap import Data.List \end{code} - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see - x1 = C a b - x2 = C x1 b + x1 = C a b + x2 = C x1 b we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 + C x1 b -> x2 and apply that to the rest of the program. When we then see - y1 = C a b - y2 = C y1 b + y1 = C a b + y2 = C y1 b we replace the C a b with x1. But then we *dont* want to add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. + y2 = C y1 b +will get transformed to C x1 b, and then to x2. So we carry an extra var->var substitution which we apply *before* looking up in the reverse mapping. @@ -74,9 +49,9 @@ Note [Shadowing] ~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... + f = \x -> let y = x+x in + h = \x -> x+x + in ... Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no shadowing, but it doesn't any more (it proved too hard), so we clone as we go. @@ -86,9 +61,9 @@ Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. But that's not quite obvious. In general we want to keep it as (wild1:as), @@ -101,44 +76,44 @@ to try to replaces uses of 'a' with uses of 'wild1' Note [Case binders 2] ~~~~~~~~~~~~~~~~~~~~~~ Consider - case (h x) of y -> ...(h x)... + case (h x) of y -> ...(h x)... We'd like to replace (h x) in the alternative, by y. But because of the preceding [Note: case binders 1], we only want to add the mapping - scrutinee -> case binder + scrutinee -> case binder to the reverse CSE mapping if the scrutinee is a non-trivial expression. (If the scrutinee is a simple variable we want to add the mapping - case binder -> scrutinee + case binder -> scrutinee to the substitution Note [CSE for INLINE and NOINLINE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are careful to do no CSE inside functions that the user has marked as -INLINE or NOINLINE. In terms of Core, that means +INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside an InlineRule + a) we do not do CSE inside an InlineRule - b) we do not do CSE on the RHS of a binding b=e - unless b's InlinePragma is AlwaysActive + b) we do not do CSE on the RHS of a binding b=e + unless b's InlinePragma is AlwaysActive Here's why (examples from Roman Leshchinskiy). Consider - yes :: Int - {-# NOINLINE yes #-} - yes = undefined + yes :: Int + {-# NOINLINE yes #-} + yes = undefined - no :: Int - {-# NOINLINE no #-} - no = undefined + no :: Int + {-# NOINLINE no #-} + no = undefined - foo :: Int -> Int -> Int - {-# NOINLINE foo #-} - foo m n = n + foo :: Int -> Int -> Int + {-# NOINLINE foo #-} + foo m n = n - {-# RULES "foo/no" foo no = id #-} + {-# RULES "foo/no" foo no = id #-} - bar :: Int -> Int - bar = foo yes + bar :: Int -> Int + bar = foo yes We do not expect the rule to fire. But if we do CSE, then we get yes=no, and the rule does fire. Worse, whether we get yes=no or @@ -147,26 +122,26 @@ no=yes depends on the order of the definitions. In general, CSE should probably never touch things with INLINE pragmas as this could lead to surprising results. Consider - {-# INLINE foo #-} - foo = <rhs> + {-# INLINE foo #-} + foo = <rhs> - {-# NOINLINE bar #-} - bar = <rhs> -- Same rhs as foo + {-# NOINLINE bar #-} + bar = <rhs> -- Same rhs as foo If CSE produces - foo = bar + foo = bar then foo will never be inlined (when it should be); but if it produces - bar = foo + bar = foo bar will be inlined (when it should not be). Even if we remove INLINE foo, we'd still like foo to be inlined if rhs is small. This won't happen with foo = bar. Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider a worker/wrapper, in which the worker has turned into a single variable: - $wf = h - f = \x -> ...$wf... + $wf = h + f = \x -> ...$wf... Now CSE may transform to - f = \x -> ...h... + f = \x -> ...h... But the WorkerInfo for f still says $wf, which is now dead! This won't happen now that we don't look inside INLINEs (which wrappers are). @@ -178,9 +153,9 @@ Then we can CSE the inner (f x) to y. In fact 'case' is like a strict let-binding, and we can use cseRhs for dealing with the scrutinee. %************************************************************************ -%* * +%* * \section{Common subexpression} -%* * +%* * %************************************************************************ \begin{code} @@ -190,12 +165,12 @@ cseProgram binds = cseBinds emptyCSEnv binds cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] cseBinds _ [] = [] cseBinds env (b:bs) = (b':bs') - where - (env1, b') = cseBind env b - bs' = cseBinds env1 bs + where + (env1, b') = cseBind env b + bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) +cseBind env (NonRec b e) = (env2, NonRec b' e') where (env1, b') = addBinder env b @@ -211,16 +186,16 @@ cseBind env (Rec pairs) cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr) cseRhs env (id',rhs) = case lookupCSEnv env rhs' of - Just other_expr -> (env, other_expr) - Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') + Just other_expr -> (env, other_expr) + Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') where rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs - | otherwise = rhs - -- See Note [CSE for INLINE and NOINLINE] + | otherwise = rhs + -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> InExpr -> OutExpr tryForCSE env expr - | exprIsTrivial expr' = expr' -- No point + | exprIsTrivial expr' = expr' -- No point | Just smaller <- lookupCSEnv env expr' = smaller | otherwise = expr' where @@ -230,24 +205,24 @@ cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) cseExpr env (Tick t e) = Tick t (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) -cseExpr env (Lam b e) = let (env', b') = addBinder env b - in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind env bind - in Let bind' (cseExpr env' e) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind env bind + in Let bind' (cseExpr env' e) cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' - where - alts' = cseAlts env2 scrut' bndr bndr'' alts - (env1, bndr') = addBinder env bndr - bndr'' = zapIdOccInfo bndr' - -- The swizzling from Note [Case binders 2] may - -- cause a dead case binder to be alive, so we - -- play safe here and bring them all to life - (env2, scrut') = cseRhs env1 (bndr'', scrut) - -- Note [CSE for case expressions] + where + alts' = cseAlts env2 scrut' bndr bndr'' alts + (env1, bndr') = addBinder env bndr + bndr'' = zapIdOccInfo bndr' + -- The swizzling from Note [Case binders 2] may + -- cause a dead case binder to be alive, so we + -- play safe here and bring them all to life + (env2, scrut') = cseRhs env1 (bndr'', scrut) + -- Note [CSE for case expressions] cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] @@ -255,103 +230,50 @@ cseAlts env scrut' bndr bndr' alts = map cse_alt alts where (con_target, alt_env) - = case scrut' of - Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] - -- map: bndr -> v' + = case scrut' of + Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] + -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] - -- map: scrut' -> bndr' + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] + -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) cse_alt (DataAlt con, args, rhs) - | not (null args) - -- Don't try CSE if there are no args; it just increases the number - -- of live vars. E.g. - -- case x of { True -> ....True.... } - -- Don't replace True by x! - -- Hence the 'null args', which also deal with literals and DEFAULT - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) - (Var con_target) + | not (null args) + -- Don't try CSE if there are no args; it just increases the number + -- of live vars. E.g. + -- case x of { True -> ....True.... } + -- Don't replace True by x! + -- Hence the 'null args', which also deal with literals and DEFAULT + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) + (Var con_target) cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args \end{code} %************************************************************************ -%* * +%* * \section{The CSE envt} -%* * +%* * %************************************************************************ \begin{code} -type InExpr = CoreExpr -- Pre-cloning +type InExpr = CoreExpr -- Pre-cloning type InBndr = CoreBndr type InAlt = CoreAlt -type OutExpr = CoreExpr -- Post-cloning +type OutExpr = CoreExpr -- Post-cloning type OutBndr = CoreBndr type OutAlt = CoreAlt --- See Note [Keep old CsEnv rep] -#ifdef OLD_CSENV_REP -data CSEnv = CS { cs_map :: CSEMap - , cs_subst :: Subst } - -type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping - -- It maps the hash-code of an expression e to list of (e,e') pairs - -- This means that it's good to replace e by e' - -- INVARIANT: The expr in the range has already been CSE'd - -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr - = case lookupUFM oldmap (hashExpr expr) of - Nothing -> Nothing - Just pairs -> lookup_list pairs - where - in_scope = substInScope sub - - -- In this lookup we use full expression equality - -- Reason: when expressions differ we generally find out quickly - -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), - -- and this kind of thing happened in real programs - lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr - lookup_list ((e,e'):es) - | eqExpr in_scope e expr = Just e' - | otherwise = lookup_list es - lookup_list [] = Nothing - -addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv -addCSEnvItem env expr expr' | exprIsBig expr = env - | otherwise = extendCSEnv env expr expr' - -- We don't try to CSE big expressions, because they are expensive to compare - -- (and are unlikely to be the same anyway) - -extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' - = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] } - where - hash = hashExpr expr - combine old new - = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result - where - result = new ++ old - short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result) - long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result - | otherwise = empty - -#else ------------- NEW ---------------- - data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value , cs_subst :: Subst } @@ -359,7 +281,7 @@ emptyCSEnv :: CSEnv emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr +lookupCSEnv (CS { cs_map = csmap }) expr = case lookupCoreMap csmap expr of Just (_,e) -> Just e Nothing -> Nothing @@ -375,7 +297,6 @@ addCSEnvItem = extendCSEnv extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv extendCSEnv cse expr expr' = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') } -#endif csEnvSubst :: CSEnv -> Subst csEnvSubst = cs_subst @@ -387,17 +308,17 @@ extendCSSubst :: CSEnv -> Id -> Id -> CSEnv extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') +addBinder cse v = (cse { cs_subst = sub' }, v') where (sub', v') = substBndr (cs_subst cse) v addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') +addBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substBndrs (cs_subst cse) vs addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substRecBndrs (cs_subst cse) vs \end{code} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 3afb8cdf5d..31547e14a2 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -762,7 +762,8 @@ instance Monad CoreM where mx >>= f = CoreM $ \s -> do (x, s', w1) <- unCoreM mx s (y, s'', w2) <- unCoreM (f x) s' - return (y, s'', w1 `plusWriter` w2) + let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702) + return $ seq w (y, s'', w) instance Applicative CoreM where pure = return @@ -781,6 +782,12 @@ instance MonadUnique CoreM where modifyS (\s -> s { cs_uniq_supply = us2 }) return us1 + getUniqueM = do + us <- getS cs_uniq_supply + let (u,us') = takeUniqFromSupply us + modifyS (\s -> s { cs_uniq_supply = us' }) + return u + runCoreM :: HscEnv -> RuleBase -> UniqSupply @@ -896,6 +903,14 @@ not be a problem, except that the new copy has its own mutable state that is not shared with that state that has already been initialized by the original GHC package. +(NB This mechanism is sufficient for granting plugins read-only access to +globals that are guaranteed to be initialized before the plugin is loaded. If +any further synchronization is necessary, I would suggest using the more +sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to +share a single instance of the global variable among the compiler and the +plugins. Perhaps we should migrate all global variables to use that mechanism, +for robustness... -- NSF July 2013) + This leads to loaded plugins calling GHC code which pokes the static flags, and then dying with a panic because the static flags *it* sees are uninitialized. diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 681c183132..0d1c9764c5 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -256,7 +256,7 @@ course. Note [extra_fvs (1): avoid floating into RHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consdider let x=\y....t... in body. We do not necessarily want to float +Consider let x=\y....t... in body. We do not necessarily want to float a binding for t into the RHS, because it'll immediately be floated out again. (It won't go inside the lambda else we risk losing work.) In letrec, we need to be more careful still. We don't want to transform diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index f32130ed76..52c564507a 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -31,10 +31,9 @@ import Coercion import VarSet import VarEnv import Var - +import Demand ( argOneShots, argsOneShots ) import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) -import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique import UniqFM import Util @@ -138,7 +137,7 @@ occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder - (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs + (rhs_usage1, rhs') = occAnalNonRecRhs env tagged_binder rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] @@ -665,7 +664,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs) -- Constructing the edges for the main Rec computation -- See Note [Forming Rec groups] - (rhs_usage1, rhs') = occAnalRhs env Nothing rhs + (rhs_usage1, rhs') = occAnalRecRhs env rhs rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs] -- Note [Rule dependency info] rhs_usage3 = case mb_unf_fvs of @@ -692,7 +691,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs) -- Finding the free variables of the INLINE pragma (if any) unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag - mb_unf_fvs = stableUnfoldingVars isLocalId unf + mb_unf_fvs = stableUnfoldingVars unf -- Find the "nd_inl" free vars; for the loop-breaker phase inl_fvs = case mb_unf_fvs of @@ -1065,28 +1064,36 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} -occAnalRhs :: OccEnv - -> Maybe Id -> CoreExpr -- Binder and rhs - -- Just b => non-rec, and alrady tagged with occurrence info - -- Nothing => Rec, no occ info +occAnalRecRhs :: OccEnv -> CoreExpr -- Rhs -> (UsageDetails, CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id -occAnalRhs env mb_bndr rhs - = occAnal ctxt rhs +occAnalRecRhs env rhs = occAnal (rhsCtxt env) rhs + +occAnalNonRecRhs :: OccEnv + -> Id -> CoreExpr -- Binder and rhs + -- Binder is already tagged with occurrence info + -> (UsageDetails, CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalNonRecRhs env bndr rhs + = occAnal rhs_env rhs where + -- See Note [Use one-shot info] + env1 = env { occ_one_shots = argOneShots dmd } + -- See Note [Cascading inlines] - ctxt = case mb_bndr of - Just b | certainly_inline b -> env - _other -> rhsCtxt env + rhs_env | certainly_inline = env1 + | otherwise = rhsCtxt env1 - certainly_inline bndr -- See Note [Cascading inlines] + certainly_inline -- See Note [Cascading inlines] = case idOccInfo bndr of OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable _ -> False - where - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) + + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) addIdOccs :: UsageDetails -> VarSet -> UsageDetails addIdOccs usage id_set = foldVarSet add usage id_set @@ -1223,24 +1230,13 @@ occAnal env expr@(Lam _ _) (final_usage, tagged_binders) = tagLamBinders body_usage binders' -- Use binders' to put one-shot info on the lambdas - -- URGH! Sept 99: we don't seem to be able to use binders' here, because - -- we get linear-typed things in the resulting program that we can't handle yet. - -- (e.g. PrelShow) TODO - - really_final_usage = if linear then - final_usage - else - mapVarEnv markInsideLam final_usage + really_final_usage | linear = final_usage + | otherwise = mapVarEnv markInsideLam final_usage in - (really_final_usage, - mkLams tagged_binders body') } + (really_final_usage, mkLams tagged_binders body') } where - env_body = vanillaCtxt env - -- Body is (no longer) an RhsContext - (binders, body) = collectBinders expr - binders' = oneShotGroup env binders - linear = all is_one_shot binders' - is_one_shot b = isId b && isOneShotBndr b + (binders, body) = collectBinders expr + (env_body, binders', linear) = oneShotGroup env binders occAnal env (Case scrut bndr ty alts) = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> @@ -1282,12 +1278,20 @@ occAnal env (Let bind body) case occAnalBind env env emptyVarEnv bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} -occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) -occAnalArgs env args - = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> - (foldr (+++) emptyDetails arg_uds_s, args')} - where - arg_env = vanillaCtxt env +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 +++ uds2, arg':args') }}} \end{code} Applications are dealt with specially because we want @@ -1324,27 +1328,23 @@ occAnalApp env (Var fun, args) in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where - fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) 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 - | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args - | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args - | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + one_shots = argsOneShots (idStrictness fun) (valArgCount args) + -- See Note [Use one-shot info] + + args_stuff = occAnalArgs env args one_shots + -- (foldr k z xs) may call k many times, but it never -- shares a partial application of k; hence [False,True] -- This means we can optimise -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs -- by floating in the v - | otherwise = occAnalArgs env args - - occAnalApp env (fun, args) = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> -- The addAppCtxt is a bit cunning. One iteration of the simplifier @@ -1354,11 +1354,8 @@ occAnalApp env (fun, args) -- thing much like a let. We do this by pushing some True items -- onto the context stack. - case occAnalArgs env args of { (args_uds, args') -> - let - final_uds = fun_uds +++ args_uds - in - (final_uds, mkApps fun' args') }} + case occAnalArgs env args [] of { (args_uds, args') -> + (fun_uds +++ args_uds, mkApps fun' args') }} markManyIf :: Bool -- If this is true @@ -1366,29 +1363,23 @@ markManyIf :: Bool -- If this is true -> UsageDetails markManyIf True uds = mapVarEnv markMany uds markManyIf False uds = uds +\end{code} -appSpecial :: OccEnv - -> Int -> CtxtTy -- Argument number, and context to use for it - -> [CoreExpr] - -> (UsageDetails, [CoreExpr]) -appSpecial env n ctxt args - = go n args - where - arg_env = vanillaCtxt env - - go _ [] = (emptyDetails, []) -- Too few args - - go 1 (arg:args) -- The magic arg - = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') -> - case occAnalArgs env args of { (args_uds, args') -> - (arg_uds +++ args_uds, arg':args') }} +Note [Use one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrrence analyser propagates one-shot-lambda information in two situation + * Applications: eg build (\cn -> blah) + Propagate one-shot info from the strictness signature of 'build' to + the \cn - go n (arg:args) - = case occAnal arg_env arg of { (arg_uds, arg') -> - case go (n-1) args of { (args_uds, args') -> - (arg_uds +++ args_uds, arg':args') }} -\end{code} + * Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) +Some of this is done by the demand analyser, but this way it happens +much earlier, taking advantage of the strictness signature of +imported functions. Note [Binders in case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1441,10 +1432,10 @@ wrapProxy _ _ _ body_usg body \begin{code} data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_ctxt :: !CtxtTy -- Tells about linearity - , occ_gbl_scrut :: GlobalScruts - , occ_rule_act :: Activation -> Bool -- Which rules are active + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- Tells about linearity + , occ_gbl_scrut :: GlobalScruts + , 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] @@ -1471,7 +1462,7 @@ instance Outputable OccEncl where ppr OccRhs = ptext (sLit "occRhs") ppr OccVanilla = ptext (sLit "occVanilla") -type CtxtTy = [Bool] +type OneShots = [Bool] -- [] No info -- -- True:ctxt Analysing a function-valued expression that will be @@ -1479,51 +1470,66 @@ type CtxtTy = [Bool] -- -- False:ctxt Analysing a function-valued expression that may -- be applied many times; but when it is, - -- the CtxtTy inside applies + -- the OneShots inside applies initOccEnv :: (Activation -> Bool) -> OccEnv initOccEnv active_rule - = OccEnv { occ_encl = OccVanilla - , occ_ctxt = [] + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] , occ_gbl_scrut = emptyVarSet -- PE emptyVarEnv emptyVarSet - , occ_rule_act = active_rule + , occ_rule_act = active_rule , occ_binder_swap = True } vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] } +vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] } +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } -setCtxtTy :: OccEnv -> CtxtTy -> OccEnv -setCtxtTy env ctxt = env { occ_ctxt = ctxt } +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +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 -oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] + , Bool ) -- True <=> all binders are one-shot -- The result binders have one-shot-ness set that they might not have had originally. -- This happens in (build (\cn -> e)). Here the occurrence analyser -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations -oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs - = go ctxt bndrs [] +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] True where - go _ [] rev_bndrs = reverse rev_bndrs - - go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs - | isId bndr = go ctxt bndrs (bndr':rev_bndrs) - where - bndr' | lin_ctxt = setOneShotLambda bndr - | otherwise = bndr - - go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) + go ctxt [] rev_bndrs linear + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs + , linear ) + + go ctxt (bndr:bndrs) rev_bndrs lin_acc + | isId bndr + = case ctxt of + [] -> go [] bndrs (bndr:rev_bndrs) (lin_acc && one_shot) + (linear : ctxt) + | one_shot -> go ctxt bndrs (bndr : rev_bndrs) lin_acc + | linear -> go ctxt bndrs (bndr': rev_bndrs) lin_acc + | otherwise -> go ctxt bndrs (bndr : rev_bndrs) False + | otherwise + = go ctxt bndrs (bndr:rev_bndrs) lin_acc + where + one_shot = isOneShotBndr bndr + bndr' = setOneShotLambda bndr addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args - = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) True ++ ctxt } \end{code} @@ -1717,7 +1723,7 @@ information right. \begin{code} mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does two things: a) makes the occ_ctxt = OccVanilla +-- Does two 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 diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index a5eb116d82..4c3c72d301 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -145,8 +145,8 @@ instance MonadUnique SimplM where (us1, us2) -> return (us1, us2, sc)) getUniqueM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqFromSupply us1, us2, sc)) + = SM (\_st_env us sc -> case takeUniqFromSupply us of + (u, us') -> return (u, us', sc)) getUniquesM = SM (\_st_env us sc -> case splitUniqSupply us of diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7bc10de43f..ab4937e8f3 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -15,15 +15,17 @@ module SimplUtils ( simplEnvForGHCi, updModeForInlineRules, -- The continuation type - SimplCont(..), DupFlag(..), ArgInfo(..), + SimplCont(..), DupFlag(..), isSimplified, contIsDupable, contResultType, contInputType, contIsTrivial, contArgs, dropArgs, - pushSimplifiedArgs, countValArgs, countArgs, addArgTo, + pushSimplifiedArgs, countValArgs, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, + interestingCallContext, interestingArg, - interestingArg, mkArgInfo, + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo, + argInfoExpr, argInfoValArgs, abstractFloats ) where @@ -132,7 +134,7 @@ data SimplCont data ArgInfo = ArgInfo { ai_fun :: OutId, -- The function - ai_args :: [OutExpr], -- ...applied to these args (which are in *reverse* order) + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) ai_type :: OutType, -- Type of (f a1 ... an) ai_rules :: [CoreRule], -- Rules for this function @@ -149,10 +151,38 @@ data ArgInfo -- Always infinite } +data ArgSpec = ValArg OutExpr -- Apply to this + | CastBy OutCoercion -- Cast by this + +instance Outputable ArgSpec where + ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e + ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c + addArgTo :: ArgInfo -> OutExpr -> ArgInfo -addArgTo ai arg = ai { ai_args = arg : ai_args ai +addArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai , ai_type = applyTypeToArg (ai_type ai) arg } +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai + , ai_type = pSnd (coercionKind co) } + +argInfoValArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> ([OutExpr], SimplCont) +argInfoValArgs env args cont + = go args [] cont + where + go :: [ArgSpec] -> [OutExpr] -> SimplCont -> ([OutExpr], SimplCont) + go (ValArg e : as) acc cont = go as (e:acc) cont + go (CastBy co : as) acc cont = go as [] (CoerceIt co (pushSimplifiedArgs env acc cont)) + go [] acc cont = (acc, cont) + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +argInfoExpr fun args + = go args + where + go [] = Var fun + go (ValArg a : as) = go as `App` a + go (CastBy co : as) = mkCast (go as) co + instance Outputable SimplCont where ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg) @@ -258,21 +288,27 @@ countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont countArgs _ = 0 contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Uses substitution to turn each arg into an OutExpr -contArgs cont@(ApplyTo {}) - = case go [] cont of { (args, cont') -> (False, args, cont') } +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont where + lone (ApplyTo {}) = False -- See Note [Lone variables] in CoreUnfold + lone (CoerceIt {}) = False + lone _ = True + go args (ApplyTo _ arg se cont) - | isTypeArg arg = go args cont - | otherwise = go (is_interesting arg se : args) cont - go args cont = (reverse args, cont) + | isTypeArg arg = go args cont + | otherwise = go (is_interesting arg se : args) cont + go args (CoerceIt _ cont) = go args cont + go args cont = (False, reverse args, cont) is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg) -- Do *not* use short-cutting substitution here -- because we want to get as much IdInfo as possible -contArgs cont = (True, [], cont) - pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont pushSimplifiedArgs _env [] cont = cont pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont) @@ -641,19 +677,21 @@ activeUnfolding env where mode = getMode env -getUnfoldingInRuleMatch :: SimplEnv -> IdUnfoldingFun +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv -- When matching in RULE, we want to "look through" an unfolding -- (to see a constructor) if *rules* are on, even if *inlinings* -- are not. A notable example is DFuns, which really we want to -- match in rules like (op dfun) in gentle mode. Another example -- is 'otherwise' which we want exprIsConApp_maybe to be able to -- see very early on -getUnfoldingInRuleMatch env id - | unf_is_active = idUnfolding id - | otherwise = NoUnfolding +getUnfoldingInRuleMatch env + = (in_scope, id_unf) where + in_scope = seInScope env mode = getMode env - unf_is_active + id_unf id | unf_is_active id = idUnfolding id + | otherwise = NoUnfolding + unf_is_active id | not (sm_rules mode) = active_unfolding_minimal id | otherwise = isActive (sm_phase mode) (idInlineActivation id) @@ -1062,7 +1100,7 @@ mkLam _env bndrs body | not (any bad bndrs) -- Note [Casts and lambdas] = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos bndrs co)) } + ; return (mkCast lam (mkPiCos Representational bndrs co)) } where co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars @@ -1124,6 +1162,7 @@ because the latter is not well-kinded. \begin{code} tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] +-- and Note [Eta expansion to manifest arity] tryEtaExpand env bndr rhs = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags @@ -1471,7 +1510,7 @@ prepareAlts tries these things: Here "cannot match" includes knowledge from GADTs -It's a good idea do do this stuff before simplifying the alternatives, to +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 the list of constructors that are handled, to put into the IdInfo of the case binder, for use when simplifying the alternatives. diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 9939e20ba6..b65feb295b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -33,7 +33,6 @@ import CoreUtils import qualified CoreSubst import CoreArity import Rules ( lookupRule, getRules ) -import BasicTypes ( Arity ) import TysPrim ( realWorldStatePrimTy ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM, liftIO ) @@ -537,6 +536,11 @@ These strange casts can happen as a result of case-of-case \begin{code} +makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec) +makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e + ; return (env', ValArg e') } +makeTrivialArg env (CastBy co) = return (env, CastBy co) + makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr @@ -723,10 +727,10 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ (DFunUnfolding ar con ops) - = return (DFunUnfolding ar con ops') - where - ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops +simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = do { (env', bndrs') <- simplBinders env bndrs + ; args' <- mapM (simplExpr env') args + ; return (df { df_bndrs = bndrs', df_args = args' }) } simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity @@ -1393,12 +1397,6 @@ completeCall env var cont = do { ------------- Try inlining ---------------- dflags <- getDynFlags ; let (lone_variable, arg_infos, call_cont) = contArgs cont - -- The args are OutExprs, obtained by *lazily* substituting - -- in the args found in cont. These args are only examined - -- to limited depth (unless a rule fires). But we must do - -- the substitution; rule matching on un-simplified args would - -- be bogus - n_val_args = length arg_infos interesting_cont = interestingCallContext call_cont unfolding = activeUnfolding env var @@ -1447,9 +1445,12 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con | not (contIsTrivial cont) -- Only do this if there is a non-trivial = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it where -- again and again! - res = mkApps (Var fun) (reverse rev_args) + res = argInfoExpr fun rev_args cont_ty = contResultType cont +rebuildCall env info (CoerceIt co cont) + = rebuildCall env (addCastTo info co) cont + rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) = do { arg_ty' <- if isSimplified dup_flag then return arg_ty else simplType (se `setInScope` env) arg_ty @@ -1481,17 +1482,21 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty | otherwise = BoringCtxt -- Nothing interesting rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont -- No rules, common case + + | otherwise = do { -- We've accumulated a simplified call in <fun,rev_args> -- so try rewrite rules; see Note [RULEs apply to simplified arguments] -- See also Note [Rules for recursive functions] - ; let args = reverse rev_args - env' = zapSubstEnv env - ; mb_rule <- tryRules env rules fun args cont + ; let env' = zapSubstEnv env + (args, cont') = argInfoValArgs env' rev_args cont + ; mb_rule <- tryRules env' rules fun args cont' ; case mb_rule of { - Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ - pushSimplifiedArgs env' (drop n_args args) cont ; - -- n_args says how many args the rule consumed - ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules + Just (rule_rhs, cont'') -> simplExprF env' rule_rhs cont'' + + -- Rules don't match + ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules } } \end{code} @@ -1551,22 +1556,25 @@ all this at once is TOO HARD! \begin{code} tryRules :: SimplEnv -> [CoreRule] -> Id -> [OutExpr] -> SimplCont - -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of - -- args consumed by the rule + -> SimplM (Maybe (CoreExpr, SimplCont)) +-- The SimplEnv already has zapSubstEnv applied to it + tryRules env rules fn args call_cont | null rules = return Nothing | otherwise = do { dflags <- getDynFlags - ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env) - (getInScope env) fn args rules of { + ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) + fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> - do { checkedTick (RuleFired (ru_name rule)) - ; dflags <- getDynFlags ; dump dflags rule rule_rhs - ; return (Just (ruleArity rule, rule_rhs)) }}} + ; let cont' = pushSimplifiedArgs env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how many args the rule consumed + ; return (Just (rule_rhs, cont')) }}} where dump dflags rule rule_rhs | dopt Opt_D_dump_rule_rewrites dflags @@ -1585,7 +1593,6 @@ tryRules env rules fn args call_cont log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $ sep [text hdr, nest 4 details] - \end{code} Note [Rules for recursive functions] @@ -1857,17 +1864,16 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' = do { let rhs' = substExpr (text "rebuild-case") env rhs + env' = zapSubstEnv env out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this ; rule_base <- getSimplRules - ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont + ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont ; case mb_rule of - Just (n_args, res) -> simplExprF (zapSubstEnv env) - (mkApps res (drop n_args out_args)) - cont - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } rebuildCase env scrut case_bndr alts cont = reallyRebuildCase env scrut case_bndr alts cont @@ -2314,7 +2320,7 @@ mkDupableCont env cont@(StrictBind {}) mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) + ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info) ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) |