X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=671697b2591e4e6e840901627efa8f9a1194bb10;hp=4105c881252d3c4e1bef93976e54dcf3779db1e3;hb=6d36af4aff6e12afa50dae2fad3993c385f8081d;hpb=b4dae163a4830e1984a656cdf66df957e840c77d

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 4105c88..671697b 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -10,16 +10,16 @@ module DsUtils (
 	EquationInfo(..), 
 	firstPat, shiftEqns,
 
-	mkDsLet,
+	mkDsLet, mkDsLets,
 
 	MatchResult(..), CanItFail(..), 
 	cantFailMatchResult, alwaysFailMatchResult,
 	extractMatchResult, combineMatchResults, 
 	adjustMatchResult,  adjustMatchResultDs,
-	mkCoLetsMatchResult, mkCoLetMatchResult,
+	mkCoLetMatchResult,
 	mkGuardedMatchResult, 
 	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
-	bindInMatchResult, bindOneInMatchResult,
+	wrapBind, wrapBinds,
 
 	mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
 	mkIntExpr, mkCharExpr,
@@ -191,13 +191,8 @@ firstPat :: EquationInfo -> Pat Id
 firstPat eqn = head (eqn_pats eqn)
 
 shiftEqns :: [EquationInfo] -> [EquationInfo]
--- Drop the outermost layer of the first pattern in each equation
-shiftEqns eqns = [ eqn { eqn_pats = shiftPats (eqn_pats eqn) }
-		 | eqn <- eqns ]
-
-shiftPats :: [Pat Id] -> [Pat Id]
-shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats ++ pats
-shiftPats (pat_with_no_sub_pats			    : pats) = pats
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
 \end{code}
 
 Functions on MatchResults
@@ -242,24 +237,16 @@ adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
   = MatchResult can_it_fail (\fail -> body_fn fail	`thenDs` \ body ->
 				      encl_fn body)
 
-bindInMatchResult :: [(Var,Var)] -> MatchResult -> MatchResult
-bindInMatchResult binds = adjustMatchResult (\e -> foldr bind e binds)
-  where
-    bind (new,old) body = bindMR new old body
-
-bindOneInMatchResult :: Var -> Var -> MatchResult -> MatchResult
-bindOneInMatchResult new old = adjustMatchResult (bindMR new old)
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 
-bindMR :: Var -> Var -> CoreExpr -> CoreExpr
-bindMR new old body
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body
   | new==old    = body
   | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
   | otherwise   = Let (NonRec new (Var old)) body
 
-mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds match_result
-  = adjustMatchResult (mkDsLets binds) match_result
-
 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 mkCoLetMatchResult bind match_result
   = adjustMatchResult (mkDsLet bind) match_result
@@ -292,7 +279,7 @@ mkCoAlgCaseMatchResult :: Id					-- Scrutinee
 mkCoAlgCaseMatchResult var ty match_alts 
   | isNewTyCon tycon		-- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
-    mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1
+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 
   | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
   = MatchResult CanFail mk_parrCase