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 62f226c..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) }
 

@@ -630,12 +632,12 @@ simplExprF env e cont
   = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
     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 $
 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
 
 simplExprF' env expr@(Lam _ _) cont 
   = simplLam env (map zap bndrs) body cont

@@ -733,12 +735,13 @@ simplCast env body co cont
   = do { co' <- simplType env co
        ; simplExprF env body (addCoerce co' cont) }
   where
   = 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
                 --     coerce T1 S1 (coerce S1 K1 e)
                -- ==>
                --      e,                      if T1=K1

@@ -751,11 +754,10 @@ simplCast env body co cont
          , s1 `coreEqType` t1  = cont           -- The coerces cancel out  
          | otherwise           = CoerceIt (mkTransCoercion co1 co2) 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  
                                -- 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
                -- ===> 
                 -- co : s1s2 :=: t1t2
                --      (coerce (T1->T2) (S1->S2) F) E
                -- ===> 

@@ -768,6 +770,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.
                -- 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 
          = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
          where
            -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and 

@@ -777,7 +781,7 @@ simplCast env body co cont
            new_arg    = mkCoerce (mkSymCoercion co1) arg'
           arg'       = substExpr arg_se arg
 
            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}
 
 
 \end{code}
 
 

@@ -838,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) }
 

@@ -944,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),

@@ -1122,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 .... }

@@ -1195,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