X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;fp=compiler%2FdeSugar%2FDsExpr.lhs;h=6d7d7622d3232e59e10127df7bbe8c853ac32770;hp=2512dddc5135e38a3357c4141e9369468677c551;hb=11f6e48e0d9a03b40b2e8a0b2fc1332f12552677;hpb=2e4cc75af2b8af9c971702de78b63c7c1a1a1a35

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 2512ddd..6d7d762 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -43,12 +43,14 @@ import Type
 import Coercion
 import CoreSyn
 import CoreUtils
+import CoreFVs
 import MkCore
 
 import DynFlags
 import StaticFlags
 import CostCentre
 import Id
+import Var
 import PrelInfo
 import DataCon
 import TysWiredIn
@@ -646,20 +648,28 @@ makes all list literals be generated via the simple route.
 
 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
+         || 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)