X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=ef69b479893e843f34244b57fb8a6ea0b3538827;hp=e89270c40442066ca1adcb7b18e64dea80ca79d6;hb=85f969a6585c06168645114d9524e7169dbc6e32;hpb=f04dead93a15af1cb818172f207b8a81d2c81298

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index e89270c..ef69b47 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -43,6 +43,7 @@ import Type
 import Coercion
 import CoreSyn
 import CoreUtils
+import CoreFVs
 import MkCore
 
 import DynFlags
@@ -50,6 +51,7 @@ import StaticFlags
 import CostCentre
 import Id
 import Var
+import VarSet
 import PrelInfo
 import DataCon
 import TysWiredIn
@@ -209,7 +211,9 @@ dsExpr (HsVar var)     	      = return (Var var)
 dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsCoercion co_fn
+                                   ; e' <- dsExpr e
+                                   ; return (co_fn' e') }
 
 dsExpr (NegApp expr neg_expr) 
   = App <$> dsExpr neg_expr <*> dsLExpr expr
@@ -319,6 +323,9 @@ dsExpr (HsDo ListComp stmts body result_ty)
 dsExpr (HsDo DoExpr stmts body result_ty)
   = dsDo stmts body result_ty
 
+dsExpr (HsDo GhciStmt stmts body result_ty)
+  = dsDo stmts body result_ty
+
 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
   = dsMDo tbl stmts body result_ty
 
@@ -639,28 +646,40 @@ 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.  
 
 
 \begin{code}
-
 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 -- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty xs = do
-    dflags <- getDOptsDs
-    xs' <- mapM dsLExpr xs
-    if  opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
-        then return $ mkListExpr elt_ty xs'
-        else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+dsExplicitList elt_ty xs
+  = do { dflags <- getDOptsDs
+       ; xs' <- mapM dsLExpr 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) }
   where
-    mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
-        let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
-            static_suffix' = mkListExpr elt_ty static_suffix
-        
-        folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
-        let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
-        return build_body
+    is_static :: CoreExpr -> Bool
+    is_static e = all is_static_var (varSetElems (exprFreeVars e))
+
+    is_static_var :: Var -> Bool
+    is_static_var v 
+      | isId v = isExternalName (idName v)  -- Top-level things are given external names
+      | otherwise = False                   -- Type variables
+
+    mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
+      = do { let suffix' = mkListExpr elt_ty suffix
+           ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
+           ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 
 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 spanTail f xs = (reverse rejected, reverse satisfying)
@@ -738,8 +757,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
@@ -837,8 +855,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)