X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=3b304c6ccb5b7c252cd9702c71a45d9a8bdfa734;hb=90ff2572a3a792dec28d22dd147f7ab48374be9b;hp=1ff6f8fbceebcd46c434d48aeb4f2d4258bd3176;hpb=e9f23b4cc3df781f2fc84b48716a7779ecc8ab06;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 1ff6f8f..3b304c6 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -40,7 +40,7 @@ import SimplMonad
 import Type
 import TyCon
 import DataCon
-import TcGadt	( dataConCanMatch )
+import Unify	( dataConCannotMatch )
 import VarSet
 import BasicTypes
 import Util
@@ -123,12 +123,12 @@ instance Outputable LetRhsFlag where
 
 instance Outputable SimplCont where
   ppr (Stop ty is_rhs _)  	     = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
-  ppr (ApplyTo dup arg se cont)      = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$ 
-					  nest 2 (pprSimplEnv se)) $$ ppr cont
+  ppr (ApplyTo dup arg se cont)      = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg)
+					  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg f _ _ cont)         = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ 
-				       (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont
+				       (nest 4 (ppr alts)) $$ ppr cont 
   ppr (CoerceIt co cont)	     = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
 
 data DupFlag = OkToDup | NoDup
@@ -774,10 +774,11 @@ activeInline env id
   where
     prag = idInlinePragma id
 
-activeRule :: SimplEnv -> Maybe (Activation -> Bool)
+activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
-activeRule env
-  | opt_RulesOff = Nothing
+activeRule dflags env
+  | not (dopt Opt_RewriteRules dflags)
+  = Nothing	-- Rewriting is off
   | otherwise
   = case getMode env of
 	SimplGently  -> Just isAlwaysActive
@@ -1192,20 +1193,19 @@ prepareAlts scrut case_bndr' alts
 	; let (alts_wo_default, maybe_deflt) = findDefault alts
 	      alt_cons = [con | (con,_,_) <- alts_wo_default]
 	      imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
-		-- "imposs_deflt_cons" are handled either by the context, 
-		-- OR by a branch in this case expression.
-		-- Don't include DEFAULT!!
+		-- "imposs_deflt_cons" are handled 
+		--   EITHER by the context, 
+		--   OR by a non-DEFAULT branch in this case expression.
 
 	; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app 
 					 imposs_deflt_cons maybe_deflt
 
-	; let trimmed_alts = filter possible_alt alts_wo_default
-	      merged_alts = mergeAlts default_alts trimmed_alts
+	; let trimmed_alts = filterOut impossible_alt alts_wo_default
+	      merged_alts = mergeAlts trimmed_alts default_alts
 		-- We need the mergeAlts in case the new default_alt 
 		-- has turned into a constructor alternative.
 		-- The merge keeps the inner DEFAULT at the front, if there is one
-		-- and eliminates any inner_alts that are shadowed by the outer_alts
-
+		-- and interleaves the alternatives in the right order
 
 	; return (imposs_deflt_cons, merged_alts) }
   where
@@ -1216,10 +1216,10 @@ prepareAlts scrut case_bndr' alts
 		    Var v -> otherCons (idUnfolding v)
 		    other -> []
 
-    possible_alt :: CoreAlt -> Bool
-    possible_alt (con, _, _) | con `elem` imposs_cons = False
-    possible_alt (DataAlt con, _, _) = dataConCanMatch inst_tys con
-    possible_alt alt		    = True
+    impossible_alt :: CoreAlt -> Bool
+    impossible_alt (con, _, _) | con `elem` imposs_cons = True
+    impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
+    impossible_alt alt		       = False
 
 
 --------------------------------------------------
@@ -1262,7 +1262,17 @@ prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
   = do	{ tick (CaseMerge outer_bndr)
 
 	; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
-	; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts] }
+	; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
+					       not (con `elem` imposs_cons) ]
+		-- NB: filter out any imposs_cons.  Example:
+		--	case x of 
+		--	  A -> e1
+		--	  DEFAULT -> case x of 
+		--			A -> e2
+		--			B -> e3
+		-- When we merge, we must ensure that e1 takes 
+		-- precedence over e2 as the value for A!  
+	}
     	-- Warning: don't call prepareAlts recursively!
     	-- Firstly, there's no point, because inner alts have already had
     	-- mkCase applied to them, so they won't have a case in their default
@@ -1297,9 +1307,8 @@ prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just
 				-- which would be quite legitmate.  But it's a really obscure corner, and
 				-- not worth wasting code on.
   , let imposs_data_cons = [con | DataAlt con <- imposs_cons]	-- We now know it's a data type 
-	is_possible con  = not (con `elem` imposs_data_cons)
-			   && dataConCanMatch inst_tys con
-  = case filter is_possible all_cons of
+	impossible con  = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
+  = case filterOut impossible all_cons of
 	[]    -> return []	-- Eliminate the default alternative
 				-- altogether if it can't match
 
@@ -1352,7 +1361,7 @@ mkCase :: OutExpr -> OutId -> OutType
 -- put an error case here insteadd
 mkCase scrut case_bndr ty []
   = pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
-    return (mkApps (Var eRROR_ID)
+    return (mkApps (Var rUNTIME_ERROR_ID)
 		   [Type ty, Lit (mkStringLit "Impossible alternative")])