Correct spelling

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 28193eb..c3fb34d 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -410,7 +410,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 +630,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 +733,12 @@ 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 
+         | s1 `coreEqType` k1 = cont
+       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 +751,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 +767,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 +778,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}
 
 

@@ -875,16 +876,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}
 
 

@@ -1130,18 +1123,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 .... }

@@ -1203,6 +1188,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