X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=159258308b5e985145dea2e19ce47d126fae6e2b;hb=b2cc243ada84e94e37e4b9442b11bf59da6f2469;hp=1be1ae375c0d97932fe089d125b9a78736c8a2dd;hpb=7a327c1297615a9498e7117a0017b09ff2458d53;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1be1ae3..1592583 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -8,14 +8,13 @@ module Simplify ( simplTopBinds, simplExpr ) where #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 ) @@ -208,7 +207,8 @@ simplTopBinds env binds -- 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') } @@ -216,6 +216,9 @@ simplTopBinds env binds -- 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 $ @@ -357,7 +360,7 @@ simplNonRecX :: SimplEnv 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 @@ -397,6 +400,7 @@ completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs = 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 @@ -406,27 +410,43 @@ becomes 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] @@ -553,7 +573,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info -\end{code} +\end{code} @@ -626,15 +646,16 @@ simplExprC env expr cont simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF env e cont = -- pprTrace "simplExprF" (ppr e $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ - simplExprF' env e cont +simplExprF env e cont + = -- 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 @@ -732,12 +753,13 @@ simplCast env body co 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 @@ -750,11 +772,10 @@ simplCast env body co cont , 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 -- ===> @@ -767,6 +788,8 @@ simplCast env body co cont -- 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 @@ -776,7 +799,7 @@ simplCast env body co cont 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} @@ -837,7 +860,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont = 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) } @@ -874,16 +897,8 @@ simplNote env InlineMe e 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} @@ -951,7 +966,7 @@ completeCall env var cont ; 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), @@ -1129,18 +1144,10 @@ in action in spectral/cichelli/Prog.hs: [(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 .... } @@ -1202,6 +1209,15 @@ The point is that we bring into the envt a binding 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