Use exprIsCheap in floating, just as the simplifier does

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index efd1b78..d4a0504 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -8,9 +8,7 @@ module Simplify ( simplTopBinds, simplExpr ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags        ( dopt, DynFlag(Opt_D_dump_inlinings),
-                         SimplifierSwitch(..)
-                       )
+import DynFlags

 import SimplMonad
 import Type hiding     ( substTy, extendTvSubst )
 import SimplEnv        
 import SimplMonad
 import Type hiding     ( substTy, extendTvSubst )
 import SimplEnv        

@@ -208,7 +206,8 @@ simplTopBinds env binds
                -- It's rather as if the top-level binders were imported.
        ; env <- simplRecBndrs env (bindersOfBinds binds)
        ; dflags <- getDOptsSmpl
                -- 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') }
        ; env' <- simpl_binds dump_flag env binds
        ; freeTick SimplifierDone
        ; return (getFloats env') }

@@ -216,6 +215,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.
        -- 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 $
     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 +359,7 @@ simplNonRecX :: SimplEnv
 simplNonRecX env bndr new_rhs
   = do { (env, bndr') <- simplBinder env bndr
        ; completeNonRecX env NotTopLevel NonRecursive
 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
 
 completeNonRecX :: SimplEnv
                -> TopLevelFlag -> RecFlag -> Bool

@@ -410,7 +412,7 @@ becomes
 prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Adds new floats to the env iff that allows us to return a good RHS
 
 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) }
 
   = do { (env', rhs') <- makeTrivial env rhs
        ; return (env', Cast rhs' co) }
 

@@ -735,8 +737,9 @@ simplCast env body co cont
   where
        addCoerce co cont = add_coerce co (coercionKind co) cont
 
   where
        addCoerce co cont = add_coerce co (coercionKind co) cont
 

-       add_coerce co (s1, k1) cont 
-         | s1 `coreEqType` k1 = 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)
        add_coerce co1 (s1, k2) (CoerceIt co2 cont)
          | (l1, t1) <- coercionKind co2
                 --     coerce T1 S1 (coerce S1 K1 e)

@@ -839,7 +842,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 }
 
   = 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) }
 
   = do { simplExprF (rhs_se `setFloats` env) rhs 
                     (StrictBind bndr bndrs body env cont) }
 

@@ -945,7 +948,7 @@ completeCall env var cont
        ; case maybe_rule of {
            Just (rule, rule_rhs) -> 
                tick (RuleFired (ru_name rule))                 `thenSmpl_`
        ; 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),
                   pprTrace "Rule fired" (vcat [
                        text "Rule:" <+> ftext (ru_name rule),
                        text "Before:" <+> ppr var <+> sep (map pprParendExpr args),

@@ -1123,18 +1126,10 @@ in action in spectral/cichelli/Prog.hs:
         [(m,n) | m <- [1..max], n <- [1..max]]
 Hence the check for NoCaseOfCase.
 
         [(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 .... }
 
     case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
                   ...other cases .... }

@@ -1196,6 +1191,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.
 
 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
 \begin{code}
 simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
 simplCaseBinder env scrut case_bndr