Improve handling of partial applications involving casts

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 1be1ae3..1592583 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -8,14 +8,13 @@ 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 SimplUtils
 import Id
 import SimplMonad
 import Type hiding     ( substTy, extendTvSubst )
 import SimplEnv        
 import SimplUtils
 import Id

+import Var

 import IdInfo
 import Coercion
 import TcGadt          ( dataConCanMatch )
 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
                -- 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 +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.
        -- 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 +360,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

@@ -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))
 -}
 
   = 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
 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)
 
        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
 \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
   = 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
   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]
 \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
     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 :: 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 $
 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

@@ -732,12 +753,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

@@ -750,11 +772,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
                -- ===> 

@@ -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.
                -- 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 

@@ -776,7 +799,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}
 
 

@@ -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 }
 
   = 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) }
 

@@ -874,16 +897,8 @@ simplNote env InlineMe e cont
   = simplExprF env e cont
 
 simplNote env (CoreNote s) 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}
 
 
 \end{code}
 
 

@@ -951,7 +966,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),

@@ -1129,18 +1144,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 .... }

@@ -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.
 
 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