X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=a58e9b4b892b8fcb5def528fa338874413f6fbb3;hb=0472771eb382f4707c3c793dfab76a48b4c9cbc3;hp=94009fd1fabea7045989325577350377d75a8f0d;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 94009fd..a58e9b4 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -643,6 +643,9 @@ Example: the foldr/single rule in GHC.Base
    foldr k z [x] = ...
 We do not want to generate a build invocation on the LHS of this RULE!
 
+We fix this by disabling rules in rule LHSs, and testing that
+flag here; see Note [Desugaring RULE left hand sides] in Desugar
+
 To test this I've added a (static) flag -fsimple-list-literals, which
 makes all list literals be generated via the simple route.  
 
@@ -656,6 +659,8 @@ dsExplicitList elt_ty xs
        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
        ; if opt_SimpleListLiterals 	       		-- -fsimple-list-literals
          || not (dopt Opt_EnableRewriteRules dflags)	-- Rewrite rules off
+	    	-- Don't generate a build if there are no rules to eliminate it!
+		-- See Note [Desugaring RULE left hand sides] in Desugar
          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
          then return $ mkListExpr elt_ty xs'
          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
@@ -749,8 +754,7 @@ dsDo stmts body result_ty
         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 	body_ty    = mkAppTy m_ty tup_ty
-        tup_ty     = mkCoreTupTy (map idType tup_ids)
-                  -- mkCoreTupTy deals with singleton case
+        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
@@ -848,8 +852,7 @@ dsMDo tbl stmts body result_ty
 	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 	body_ty = mkAppTy m_ty tup_ty
-	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-		  -- mkCoreTupTy deals with singleton case
+	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 
 	return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
 			      (mkLHsTupleExpr rets)