X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=dffdd75212206ead238a652ac81f1e75551ddc9c;hp=43edcf5f058342fcdc22a77faf2b008e8a42a6f1;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=bb394e57361d9910b05f1145cbc894d33759d2a6

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 43edcf5..dffdd75 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -13,7 +13,7 @@ import DynFlags	( dopt, DynFlag(Opt_D_dump_inlinings),
 			)
 import SimplMonad
 import SimplEnv	
-import SimplUtils	( mkCase, mkLam, mkDataConAlt,
+import SimplUtils	( mkCase, mkLam, 
 			  SimplCont(..), DupFlag(..), LetRhsFlag(..), 
 			  mkRhsStop, mkBoringStop,  mkLazyArgStop, pushContArgs,
 			  contResultType, countArgs, contIsDupable, contIsRhsOrArg,
@@ -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 )
@@ -611,7 +608,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
 	-- means that we can avoid tests in exprIsConApp, for example.
 	-- This is important: if exprIsConApp says 'yes' for a recursive
 	-- thing, then we can get into an infinite loop
-
 	-- If the unfolding is a value, the demand info may
 	-- go pear-shaped, so we nuke it.  Example:
 	--	let x = (a,b) in
@@ -814,9 +810,12 @@ simplCast env body co cont
            -- t2 :=: s2 with left and right on the curried form: 
            --    (->) t1 t2 :=: (->) s1 s2
            [co1, co2] = decomposeCo 2 co
-           new_arg    = mkCoerce (mkSymCoercion co1) (substExpr arg_env arg)
-           arg_env    = setInScope arg_se env
-           result     = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
+           new_arg    = mkCoerce (mkSymCoercion co1) arg'
+	   arg'       = case arg_se of
+			  Nothing     -> arg
+			  Just arg_se -> substExpr (setInScope arg_se env) arg
+           result     = ApplyTo dup new_arg (Just $ zapSubstEnv env) 
+				(addCoerce co2 cont)
        addCoerce co cont = CoerceIt co cont
     in
     simplType env co		`thenSmpl` \ co' ->
@@ -1517,6 +1516,7 @@ simplDefault :: SimplEnv
 
 simplDefault env case_bndr' imposs_cons cont Nothing
   = return []	-- No default branch
+
 simplDefault env case_bndr' imposs_cons cont (Just rhs)
   | 	-- This branch handles the case where we are 
 	-- scrutinisng an algebraic data type
@@ -1549,7 +1549,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
@@ -1557,7 +1560,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
 
 	two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
 
-  | otherwise
+  | otherwise 
   = simplify_default imposs_cons
   where
     cant_match tys data_con = not (dataConCanMatch data_con tys)
@@ -1693,7 +1696,7 @@ knownCon env scrut con args bndr alts cont
 				  simplExprF env rhs cont
 
 	(DataAlt dc, bs, rhs)  
-		-> ASSERT( n_drop_tys + length bs == length args )
+		-> -- ASSERT( n_drop_tys + length bs == length args )
 		   bind_args env dead_bndr bs (drop n_drop_tys args)	$ \ env ->
 		   let
 			-- It's useful to bind bndr to scrut, rather than to a fresh
@@ -1713,6 +1716,7 @@ knownCon env scrut con args bndr alts cont
 		   simplNonRecX env bndr bndr_rhs		$ \ env ->
 		   simplExprF env rhs cont
 	        where
+		   dead_bndr  = isDeadBinder bndr
 		   n_drop_tys = tyConArity (dataConTyCon dc)
 
 -- Ugh!