X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=ea06d8d3ac6845e767eabef494cd8d57c4ad2ba5;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=9b9a5ad5931d41b902ba635148156bea21e9505c;hpb=7e18dae58b864c6f41e2905b0fb3644c43b65ca4;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 9b9a5ad..ea06d8d 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -6,12 +6,11 @@
 Support code for @Simplify@.
 
 \begin{code}
-#include "HsVersions.h"
-
 module SimplCase ( simplCase, bindLargeRhs ) where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(SmplLoop)		( simplBind, simplExpr, MagicUnfoldingFun )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
 
 import BinderInfo	-- too boring to try to select things...
 import CmdLineOpts	( SimplifierSwitch(..) )
@@ -20,9 +19,9 @@ import CoreUnfold	( Unfolding, SimpleUnfolding )
 import CoreUtils	( coreAltsType, nonErrorRHSs, maybeErrorApp,
 			  unTagBindersAlts, unTagBinders, coreExprType
 			)
-import Id		( idType, isDataCon, getIdDemandInfo,
-			  SYN_IE(DataCon), GenId{-instance Eq-},
-			  SYN_IE(Id)
+import Id		( idType, isDataCon, getIdDemandInfo, dataConArgTys,
+			  DataCon, GenId{-instance Eq-},
+			  Id
 			)
 import IdInfo		( willBeDemanded, DemandInfo )
 import Literal		( isNoRepLit, Literal{-instance Eq-} )
@@ -31,11 +30,11 @@ import PrelVals		( voidId )
 import PrimOp		( primOpOkForSpeculation, PrimOp{-instance Eq-} )
 import SimplEnv
 import SimplMonad
-import Type		( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
+import Type		( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
+import TyCon		( isDataTyCon )
 import TysPrim		( voidTy )
 import Unique		( Unique{-instance Eq-} )
-import Usage		( GenUsage{-instance Eq-} )
-import Util		( SYN_IE(Eager), runEager, appEager,
+import Util		( Eager, runEager, appEager,
 			  isIn, isSingleton, zipEqual, panic, assertPanic )
 \end{code}
 
@@ -131,7 +130,10 @@ simplCase env scrut alts rhs_c result_ty
   | maybeToBool maybe_error_app
   = 	-- Look for an application of an error id
     tick CaseOfError 	`thenSmpl_`
-    returnSmpl retyped_error_app
+    simplExpr env retyped_error_app [] result_ty
+		-- Ignore rhs_c!
+		-- We must apply simplExpr because "rhs" isn't yet simplified.
+		-- The ice is a little thin because body_ty is an OutType; but it's ok really
   where
     maybe_error_app 	   = maybeErrorApp scrut (Just result_ty)
     Just retyped_error_app = maybe_error_app
@@ -432,7 +434,7 @@ bindLargeRhs :: SimplEnv
 		       InExpr)		-- Modified rhs
 
 bindLargeRhs env args rhs_ty rhs_c
-  | null used_args && isPrimType rhs_ty
+  | null used_args && isUnpointedType rhs_ty
 	-- If we try to lift a primitive-typed something out
 	-- for let-binding-purposes, we will *caseify* it (!),
 	-- with potentially-disastrous strictness results.  So
@@ -501,6 +503,27 @@ simplAlts :: SimplEnv
 	  -> InAlts
 	  -> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
 	  -> SmplM OutAlts
+-- For single-constructor types
+--	case e of y -> b    ===>   case e of (a,b) -> let y = (a,b) in b
+
+simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
+  | maybeToBool maybe_data_ty && 
+    not (null cons) &&		-- Not an abstract type (can arise if we're pruning tydecl imports)
+    null other_cons
+  = ASSERT( isDataTyCon tycon )
+    newIds inst_con_arg_tys	`thenSmpl` \ new_bindees ->
+    let
+	new_args = [ (b, bad_occ_info) | b <- new_bindees ]
+	con_app  = mkCon con ty_args (map VarArg new_bindees)
+	new_rhs  = Let (NonRec bndr con_app) rhs
+    in
+    simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
+  where
+    maybe_data_ty		= splitAlgTyConApp_maybe (idType id)
+    Just (tycon, ty_args, cons)	= maybe_data_ty
+    (con:other_cons)		= cons
+    inst_con_arg_tys 		= dataConArgTys con ty_args
+    bad_occ_info     		= ManyOcc 0	-- Non-committal!
 
 simplAlts env scrut (AlgAlts alts deflt) rhs_c
   = mapSmpl do_alt alts					`thenSmpl` \ alts' ->
@@ -515,7 +538,7 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c
 	    new_env = case scrut of
 		       Var v -> extendEnvGivenNewRhs env1 v (Con con args)
 			     where
-				(_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
+				(_, ty_args, _) = splitAlgTyConApp (idType v)
 				args = map TyArg ty_args ++ map VarArg con_args'
 
 		       other -> env1
@@ -779,8 +802,7 @@ mkCoCase env scrut (AlgAlts outer_alts
 	 v | scrut_is_var = Var scrut_var
 	   | otherwise    = Con con (map TyArg arg_tys ++ map VarArg args)
 
-    arg_tys = --trace "SimplCase:getAppData...:2" $
-	      case (getAppDataTyConExpandingDicts (idType deflt_var)) of
+    arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
 		(_, arg_tys, _) -> arg_tys
 
 mkCoCase env scrut (PrimAlts
@@ -928,7 +950,6 @@ eq_args _	 _        = False
 
 eq_arg (LitArg 	 l1) (LitArg   l2) = l1	== l2
 eq_arg (VarArg 	 v1) (VarArg   v2) = v1	== v2
-eq_arg (TyArg  	 t1) (TyArg    t2) = t1 `eqTy` t2
-eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2
+eq_arg (TyArg  	 t1) (TyArg    t2) = t1 == t2
 eq_arg _	     _		   =  False
 \end{code}