[project @ 2003-07-21 15:14:18 by ross]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 90151b9..b57b4b1 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -25,12 +25,13 @@ import CmdLineOpts  ( SimplifierSwitch(..),
                          opt_SimplCaseMerge, opt_UF_UpdateInPlace
                        )
 import CoreSyn
-import CoreUtils       ( cheapEqExpr, exprType, 
+import CoreFVs         ( exprFreeVars )
+import CoreUtils       ( cheapEqExpr, exprType, exprIsTrivial,
                          etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
                          findDefault, exprOkForSpeculation, exprIsValue
                        )
 import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id              ( Id, idType, idInfo, 
+import Id              ( Id, idType, idInfo, isDataConWorkId,
                          mkSysLocal, isDeadBinder, idNewDemandInfo,
                          idUnfolding, idNewStrictness
                        )
@@ -44,6 +45,7 @@ import OccName                ( EncodedFS )
 import TyCon           ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
 import DataCon         ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
+import VarSet
 import Util            ( lengthExceeds, mapAccumL )
 import Outputable
 \end{code}
@@ -222,6 +224,9 @@ getContArgs chkr fun orig_cont
        --      * (error "Hello") arg
        --      * f (error "Hello") where f is strict
        --      etc
+       -- Then, especially in the first of these cases, we'd like to discard
+       -- the continuation, leaving just the bottoming expression.  But the
+       -- type might not be right, so we may have to add a coerce.
     go acc ss inl cont 
        | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
        | otherwise                       = (reverse acc, cont,             inl)
@@ -273,6 +278,9 @@ interestingArg :: OutExpr -> Bool
 interestingArg (Var v)          = hasSomeUnfolding (idUnfolding v)
                                        -- Was: isValueUnfolding (idUnfolding v')
                                        -- But that seems over-pessimistic
+                                || isDataConWorkId v
+                                       -- This accounts for an argument like
+                                       -- () or [], which is definitely interesting
 interestingArg (Type _)                 = False
 interestingArg (App fn (Type _)) = interestingArg fn
 interestingArg (Note _ a)       = interestingArg a
@@ -540,17 +548,17 @@ tryEtaReduce bndrs body
        -- efficient here:
        --  (a) we already have the binders
        --  (b) we can do the triviality test before computing the free vars
-       --      [in fact I take the simple path and look for just a variable]
   = go (reverse bndrs) body
   where
     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun       -- Loop round
-    go []       (Var fun)     | ok_fun fun   = Just (Var fun)  -- Success!
+    go []       fun           | ok_fun fun   = Just fun                -- Success!
     go _        _                           = Nothing          -- Failure!
 
-    ok_fun fun = not (fun `elem` bndrs) && 
-                (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs)
+    ok_fun fun =  exprIsTrivial fun
+              && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
+              && (exprIsValue fun || all ok_lam bndrs)
     ok_lam v = isTyVar v || isDictTy (idType v)
-       -- The isEvaldUnfolding is because eta reduction is not 
+       -- The exprIsValue is because eta reduction is not 
        -- valid in general:  \x. bot  /=  bot
        -- So we need to be sure that the "fun" is a value.
        --
@@ -861,6 +869,16 @@ prepareDefault case_bndr handled_cons (Just rhs)
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
     Just all_cons <- tyConDataCons_maybe tycon,
+    not (null all_cons),       -- This is a tricky corner case.  If the data type has no constructors,
+                               -- which GHC allows, then the case expression will have at most a default
+                               -- alternative.  We don't want to eliminate that alternative, because the
+                               -- invariant is that there's always one alternative.  It's more convenient
+                               -- to leave     
+                               --      case x of { DEFAULT -> e }     
+                               -- as it is, rather than transform it to
+                               --      error "case cant match"
+                               -- which would be quite legitmate.  But it's a really obscure corner, and
+                               -- not worth wasting code on.
     let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
     let missing_cons      = [con | con <- all_cons, 
                                   not (con `elem` handled_data_cons)]
@@ -1170,6 +1188,16 @@ I don't really know how to improve this situation.
 
 \begin{code}
 --------------------------------------------------
+--     0. Check for empty alternatives
+--------------------------------------------------
+
+#ifdef DEBUG
+mkCase1 scrut case_bndr []
+  = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
+    returnSmpl scrut
+#endif
+
+--------------------------------------------------
 --     1. Eliminate the case altogether if poss
 --------------------------------------------------
 
@@ -1215,12 +1243,6 @@ mkCase1 scrut case_bndr [(con,bndrs,rhs)]
 --     2. Identity case
 --------------------------------------------------
 
-#ifdef DEBUG
-mkCase1 scrut case_bndr []
-  = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
-    returnSmpl scrut
-#endif
-
 mkCase1 scrut case_bndr alts   -- Identity case
   | all identity_alt alts
   = tick (CaseIdentity case_bndr)              `thenSmpl_`