[project @ 2002-11-21 11:31:51 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index aeaa760..1d9b987 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -26,7 +26,7 @@ import CmdLineOpts    ( SimplifierSwitch(..),
                        )
 import CoreSyn
 import CoreUtils       ( cheapEqExpr, exprType, 
-                         etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+                         etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
                          findDefault, exprOkForSpeculation, exprIsValue
                        )
 import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
@@ -42,7 +42,7 @@ import Type           ( Type, seqType, splitFunTys, dropForAlls, isStrictType,
 import TcType          ( isDictTy )
 import OccName         ( EncodedFS )
 import TyCon           ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon         ( dataConRepArity, dataConSig, dataConArgTys )
+import DataCon         ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
 import Util            ( lengthExceeds, mapAccumL )
 import Outputable
@@ -861,6 +861,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)]
@@ -885,7 +895,7 @@ mk_args missing_con inst_tys
   = getUniquesSmpl             `thenSmpl` \ tv_uniqs ->
     getUniquesSmpl             `thenSmpl` \ id_uniqs ->
     let
-       (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
+       ex_tyvars   = dataConExistentialTyVars missing_con
        ex_tyvars'  = zipWith mk tv_uniqs ex_tyvars
        mk uniq tv  = mkSysTyVar uniq (tyVarKind tv)
        arg_tys     = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
@@ -1170,6 +1180,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 +1235,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_`
@@ -1244,7 +1258,7 @@ mkCase1 scrut case_bndr alts      -- Identity case
 
        -- re_note wraps a coerce if it might be necessary
     re_note scrut = case head alts of
-                       (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
+                       (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
                        other                 -> scrut