[project @ 1999-11-01 17:09:54 by simonpj]

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

diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs
index ee12ab9..d424653 100644 (file)
--- a/ghc/compiler/simplCore/CSE.lhs
+++ b/ghc/compiler/simplCore/CSE.lhs
@@ -25,7 +25,7 @@ import UniqFM
 
 
                        Simple common sub-expression
-
+                       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we see
        x1 = C a b
        x2 = C x1 b
@@ -37,12 +37,12 @@ When we then see
        y1 = C a b
        y2 = C y1 b
 we replace the C a b with x1.  But then we *dont* want to
-add   x1 -> y  to the mapping.  Rather, we want the reverse, y -> x1
+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
 so that a subsequent binding
-       z = C y b
+       y2 = C y1 b
 will get transformed to C x1 b, and then to x2.  
 
-So we carry an extra var->var mapping which we apply before looking up in the
+So we carry an extra var->var mapping which we apply *before* looking up in the
 reverse mapping.
 
 
@@ -56,7 +56,33 @@ For example, consider
                      h = \x -> x+x
                  in ...
 
-Here we must *not* do CSE on the x+x!
+Here we must *not* do CSE on the inner x+x!
+
+
+Another important wrinkle
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+       f = \x -> case x of wild { 
+                       (a:as) -> case a of wild1 {
+                                   (p,q) -> ...(wild1:as)...
+
+Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
+But that's not quite obvious.  In general we want to keep it as (wild1:as),
+but for CSE purpose that's a bad idea.
+
+So we add the binding (wild1 -> a) to the extra var->var mapping.
+
+
+Yet another wrinkle
+~~~~~~~~~~~~~~~~~~~
+Consider
+       case (h x) of y -> ...(h x)...
+
+We'd like to replace (h x) in the alternative, by y.  But because of
+the preceding "Another important wrinkle", we only want to add the mapping
+       scrutinee -> case binder
+to the CSE mapping if the scrutinee is a non-trivial expression.
 
 
 %************************************************************************
@@ -119,18 +145,28 @@ cseExpr env (Lam b e)                = Lam b (cseExpr env e)
 cseExpr env (Let bind e)          = let (env1, bind') = cseBind env bind
                                     in Let bind' (cseExpr env1 e)
 cseExpr env (Type t)              = Type t
-cseExpr env (Case scrut bndr alts) = Case (tryForCSE env scrut) bndr (cseAlts env bndr alts) 
+cseExpr env (Case scrut bndr alts) = Case scrut' bndr (cseAlts env scrut' bndr alts)
+                                  where
+                                    scrut' = tryForCSE env scrut
 
 
-cseAlts env bndr alts
+cseAlts env new_scrut bndr alts
   = map cse_alt alts
   where
+    (con_target, alt_env)
+       = case new_scrut of
+               Var v -> (v,    extendSubst env bndr v)         -- See "another important wrinkle"
+                                                               -- map: bndr -> v
+
+               other -> (bndr, extendCSEnv env bndr new_scrut) -- See "yet another wrinkle"
+                                                               -- map: new_scrut -> bndr
+
     arg_tys = case splitTyConApp_maybe (idType bndr) of
                Just (_, arg_tys) -> map Type arg_tys
                other             -> pprPanic "cseAlts" (ppr bndr)
 
     cse_alt (con, args, rhs)
-       | null args || not (isBoxedDataCon con) = (con, args, cseExpr env rhs)
+       | null args || not (isBoxedDataCon con) = (con, args, cseExpr alt_env rhs)
                -- Don't try CSE if there are no args; it just increases the number
                -- of live vars.  E.g.
                --      case x of { True -> ....True.... }
@@ -138,7 +174,7 @@ cseAlts env bndr alts
                -- Hence the 'null args', which also deal with literals and DEFAULT
                -- And we can't CSE on unboxed tuples
        | otherwise
-       = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
+       = (con, args, cseExpr (extendCSEnv alt_env con_target (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
 \end{code}