X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=7c4a2ce86940982c912716a6006423a6840faecb;hb=c248518fe81b6d2807d3bcbb8a09ae14facce1ad;hp=f9cc644157f0f9c086e09cbf7c27221e08c04ccf;hpb=6fcf90065dc4e75b7dc6bbf238a9891a71ae5a86;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f9cc644..7c4a2ce 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -26,8 +26,6 @@ import Id		( Id, idType, idInfo, idArity, isDataConWorkId,
 			  idNewDemandInfo, setIdInfo, 
 			  setIdOccInfo, zapLamIdInfo, setOneShotLambda
 			)
-import MkId		( eRROR_ID )
-import Literal		( mkStringLit )
 import IdInfo		( OccInfo(..), isLoopBreaker,
 			  setArityInfo, zapDemandInfo,
 			  setUnfoldingInfo, 
@@ -35,7 +33,7 @@ import IdInfo		( OccInfo(..), isLoopBreaker,
 			)
 import NewDemand	( isStrictDmd )
 import TcGadt		( dataConCanMatch )
-import DataCon		( DataCon, dataConTyCon, dataConRepStrictness )
+import DataCon		( dataConTyCon, dataConRepStrictness )
 import TyCon		( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
 import CoreSyn
 import PprCore		( pprParendExpr, pprCoreExpr )
@@ -44,19 +42,18 @@ import CoreUtils	( exprIsDupable, exprIsTrivial, needsCaseBinding,
 			  exprIsConApp_maybe, mkPiTypes, findAlt, 
 			  exprType, exprIsHNF, findDefault, mergeAlts,
 			  exprOkForSpeculation, exprArity, 
-			  mkCoerce, mkSCC, mkInlineMe, applyTypeToArg
+			  mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
+                          dataConRepInstPat
 			)
 import Rules		( lookupRule )
 import BasicTypes	( isMarkedStrict )
 import CostCentre	( currentCCS )
 import Type		( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
-			  splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe,
-			  isTyVarTy, mkTyVarTys, isFunTy, tcEqType
+			  coreEqType, splitTyConApp_maybe,
+			  isTyVarTy, isFunTy, tcEqType
 			)
 import Coercion         ( Coercion, coercionKind,
-                          mkTransCoercion, mkLeftCoercion, mkRightCoercion, 
-                          mkSymCoercion, splitCoercionKind_maybe, decomposeCo  )
-import Var		( tyVarKind, mkTyVar )
+                          mkTransCoercion, mkSymCoercion, splitCoercionKind_maybe, decomposeCo  )
 import VarEnv		( elemVarEnv, emptyVarEnv )
 import TysPrim		( realWorldStatePrimTy )
 import PrelInfo		( realWorldPrimId )
@@ -636,7 +633,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
     final_id					`seq`
     -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
     returnSmpl (unitFloat env final_id new_rhs, env)
-
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
     loop_breaker = isLoopBreaker occ_info
@@ -1552,7 +1548,10 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
 
 	[con] -> 	-- It matches exactly one constructor, so fill it in
 		 do { tick (FillInCaseDefault case_bndr')
-		    ; con_alt <- mkDataConAlt con inst_tys rhs
+                    ; us <- getUniquesSmpl
+                    ; let (ex_tvs, co_tvs, arg_ids) =
+                              dataConRepInstPat us con inst_tys
+                    ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)
 		    ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
 			-- The simplAlt must succeed with Just because we have
 			-- already filtered out construtors that can't match