#include "HsVersions.h"
-import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
- SimplifierSwitch(..)
- )
+import DynFlags
import SimplMonad
import Type hiding ( substTy, extendTvSubst )
import SimplEnv
import SimplUtils
import Id
+import Var
import IdInfo
import Coercion
import TcGadt ( dataConCanMatch )
-- It's rather as if the top-level binders were imported.
; env <- simplRecBndrs env (bindersOfBinds binds)
; dflags <- getDOptsSmpl
- ; let dump_flag = dopt Opt_D_dump_inlinings dflags
+ ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
+ dopt Opt_D_dump_rule_firings dflags
; env' <- simpl_binds dump_flag env binds
; freeTick SimplifierDone
; return (getFloats env') }
-- We need to track the zapped top-level binders, because
-- they should have their fragile IdInfo zapped (notably occurrence info)
-- That's why we run down binds and bndrs' simultaneously.
+ --
+ -- The dump-flag emits a trace for each top-level binding, which
+ -- helps to locate the tracing for inlining and rule firing
simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
simpl_binds dump env [] = return env
simpl_binds dump env (bind:binds) = do { env' <- trace dump bind $
simplNonRecX env bndr new_rhs
= do { (env, bndr') <- simplBinder env bndr
; completeNonRecX env NotTopLevel NonRecursive
- (isStrictBndr bndr) bndr bndr' new_rhs }
+ (isStrictId bndr) bndr bndr' new_rhs }
completeNonRecX :: SimplEnv
-> TopLevelFlag -> RecFlag -> Bool
= thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
-}
+----------------------------------
prepareRhs takes a putative RHS, checks whether it's a PAP or
constructor application and, if so, converts it to ANF, so that the
resulting thing can be inlined more easily. Thus
t2 = g b
x = (t1,t2)
+We also want to deal well cases like this
+ v = (f e1 `cast` co) e2
+Here we want to make e1,e2 trivial and get
+ x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
+That's what the 'go' loop in prepareRhs does
+
\begin{code}
prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
-
-prepareRhs env (Cast rhs co) -- Note [Float coersions]
+prepareRhs env (Cast rhs co) -- Note [Float coercions]
= do { (env', rhs') <- makeTrivial env rhs
; return (env', Cast rhs' co) }
prepareRhs env rhs
- | (Var fun, args) <- collectArgs rhs -- It's an application
- , let n_args = valArgCount args
- , n_args > 0 -- ...but not a trivial one
- , isDataConWorkId fun || n_args < idArity fun -- ...and it's a constructor or PAP
- = go env (Var fun) args
+ = do { (is_val, env', rhs') <- go 0 env rhs
+ ; return (env', rhs') }
where
- go env fun [] = return (env, fun)
- go env fun (arg : args) = do { (env', arg') <- makeTrivial env arg
- ; go env' (App fun arg') args }
-
-prepareRhs env rhs -- The default case
- = return (env, rhs)
+ go n_val_args env (Cast rhs co)
+ = do { (is_val, env', rhs') <- go n_val_args env rhs
+ ; return (is_val, env', Cast rhs' co) }
+ go n_val_args env (App fun (Type ty))
+ = do { (is_val, env', rhs') <- go n_val_args env fun
+ ; return (is_val, env', App rhs' (Type ty)) }
+ go n_val_args env (App fun arg)
+ = do { (is_val, env', fun') <- go (n_val_args+1) env fun
+ ; case is_val of
+ True -> do { (env'', arg') <- makeTrivial env' arg
+ ; return (True, env'', App fun' arg') }
+ False -> return (False, env, App fun arg) }
+ go n_val_args env (Var fun)
+ = return (is_val, env, Var fun)
+ where
+ is_val = n_val_args > 0 -- There is at least one arg
+ -- ...and the fun a constructor or PAP
+ && (isDataConWorkId fun || n_val_args < idArity fun)
+ go n_val_args env other
+ = return (False, env, other)
\end{code}
Note [Float coercions]
= -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
simplExprF' env e cont
-simplExprF' env (Var v) cont = simplVar env v cont
+simplExprF' env (Var v) cont = simplVar env v cont
simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
simplExprF' env (Note n expr) cont = simplNote env n expr cont
simplExprF' env (Cast body co) cont = simplCast env body co cont
simplExprF' env (App fun arg) cont = simplExprF env fun $
- ApplyTo NoDup arg env cont
+ ApplyTo NoDup arg env cont
simplExprF' env expr@(Lam _ _) cont
= simplLam env (map zap bndrs) body cont
= do { co' <- simplType env co
; simplExprF env body (addCoerce co' cont) }
where
- addCoerce co cont
- | (s1, k1) <- coercionKind co
- , s1 `coreEqType` k1 = cont
- addCoerce co1 (CoerceIt co2 cont)
- | (s1, k1) <- coercionKind co1
- , (l1, t1) <- coercionKind co2
+ addCoerce co cont = add_coerce co (coercionKind co) cont
+
+ add_coerce co (s1, k1) cont -- co :: ty~ty
+ | s1 `coreEqType` k1 = cont -- is a no-op
+
+ add_coerce co1 (s1, k2) (CoerceIt co2 cont)
+ | (l1, t1) <- coercionKind co2
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- e, if T1=K1
, s1 `coreEqType` t1 = cont -- The coerces cancel out
| otherwise = CoerceIt (mkTransCoercion co1 co2) cont
- addCoerce co (ApplyTo dup arg arg_se cont)
- | not (isTypeArg arg) -- This whole case only works for value args
+ add_coerce co (s1s2, t1t2) (ApplyTo dup arg arg_se cont)
+ | not (isTypeArg arg) -- This whole case only works for value args
-- Could upgrade to have equiv thing for type apps too
- , Just (s1s2, t1t2) <- splitCoercionKind_maybe co
- , isFunTy s1s2
+ , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
-- co : s1s2 :=: t1t2
-- (coerce (T1->T2) (S1->S2) F) E
-- ===>
-- with the InExpr in the argument, so we simply substitute
-- to make it all consistent. It's a bit messy.
-- But it isn't a common case.
+ --
+ -- Example of use: Trac #995
= ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
where
-- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
new_arg = mkCoerce (mkSymCoercion co1) arg'
arg' = substExpr arg_se arg
- addCoerce co cont = CoerceIt co cont
+ add_coerce co _ cont = CoerceIt co cont
\end{code}
= do { tick (PreInlineUnconditionally bndr)
; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
- | isStrictBndr bndr
+ | isStrictId bndr
= do { simplExprF (rhs_se `setFloats` env) rhs
(StrictBind bndr bndrs body env cont) }
= simplExprF env e cont
simplNote env (CoreNote s) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note (CoreNote s) e') cont }
-
-simplNote env note@(TickBox {}) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note note e') cont }
-
-simplNote env note@(BinaryTickBox {}) e cont
- = do { e' <- simplExpr env e
- ; rebuild env (Note note e') cont }
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note (CoreNote s) e') cont
\end{code}
; case maybe_rule of {
Just (rule, rule_rhs) ->
tick (RuleFired (ru_name rule)) `thenSmpl_`
- (if dopt Opt_D_dump_inlinings dflags then
+ (if dopt Opt_D_dump_rule_firings dflags then
pprTrace "Rule fired" (vcat [
text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
[(m,n) | m <- [1..max], n <- [1..max]]
Hence the check for NoCaseOfCase.
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider case (v `cast` co) of x { I# ->
- ... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case. We can get this neatly by
-arranging that inside the outer case we add the unfolding
- v |-> x `cast` (sym co)
-to v. Then we should inline v at the inner case, cancel the casts, and away we go
-
-Note 2
-~~~~~~
-There is another situation when we don't want to do it. If we have
+Note [Suppressing the case binder-swap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is another situation when it might make sense to suppress the
+case-expression binde-swap. If we have
case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
...other cases .... }
after the outer case, and that makes (a,b) alive. At least we do unless
the case binder is guaranteed dead.
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider case (v `cast` co) of x { I# ->
+ ... (case (v `cast` co) of {...}) ...
+We'd like to eliminate the inner case. We can get this neatly by
+arranging that inside the outer case we add the unfolding
+ v |-> x `cast` (sym co)
+to v. Then we should inline v at the inner case, cancel the casts, and away we go
+
\begin{code}
simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
simplCaseBinder env scrut case_bndr
projects / ghc-hetmet.git / blobdiff