Remove an unnecessary #ifdef DEBUG

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index dce8870..b823437 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -17,7 +17,6 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 #include "HsVersions.h"
 
-
 import Match
 import MatchLit
 import DsBinds
@@ -44,6 +43,7 @@ import Type
 import CoreSyn
 import CoreUtils
 
+import DynFlags
 import CostCentre
 import Id
 import PrelInfo
@@ -306,11 +306,8 @@ dsExpr (HsIf guard_expr then_expr else_expr)
 \underline{\bf Various data construction things}
 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-dsExpr (ExplicitList ty xs)
-  = go xs
-  where
-    go []     = return (mkNilExpr ty)
-    go (x:xs) = mkConsExpr ty <$> dsLExpr x <*> go xs
+dsExpr (ExplicitList elt_ty xs) 
+  = dsExplicitList elt_ty xs
 
 -- we create a list from the array elements and convert them into a list using
 -- `PrelPArr.toP'
@@ -508,10 +505,8 @@ dsExpr (HsBinTick ixT ixF e) = do
 
 \begin{code}
 
-#ifdef DEBUG
 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
-#endif
 
 
 findField :: [HsRecField Id arg] -> Name -> [arg]
@@ -522,6 +517,64 @@ findField rbinds lbl
 
 %--------------------------------------------------------------------
 
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations.  Essentially, whenever we see a list literal
+[x_1, ..., x_n] we:
+
+1. Find the tail of the list that can be allocated statically (say
+   [x_k, ..., x_n]) by later stages and ensure we desugar that
+   normally: this makes sure that we don't cause a code size increase
+   by having the cons in that expression fused (see later) and hence
+   being unable to statically allocate any more
+
+2. For the prefix of the list which cannot be allocated statically,
+   say [x_1, ..., x_(k-1)], we turn it into an expression involving
+   build so that if we find any foldrs over it it will fuse away
+   entirely!
+   
+   So in this example we will desugar to:
+   build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
+   
+   If fusion fails to occur then build will get inlined and (since we
+   defined a RULE for foldr (:) []) we will get back exactly the
+   normal desugaring for an explicit list.
+
+This optimisation can be worth a lot: up to 25% of the total
+allocation in some nofib programs. Specifically
+
+        Program           Size    Allocs   Runtime  CompTime
+        rewrite          +0.0%    -26.3%      0.02     -1.8%
+           ansi          -0.3%    -13.8%      0.00     +0.0%
+           lift          +0.0%     -8.7%      0.00     -2.3%
+
+Of course, if rules aren't turned on then there is pretty much no
+point doing this fancy stuff, and it may even be harmful.
+\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 not (dopt Opt_RewriteRules dflags)
+        then return $ mkListExpr elt_ty xs'
+        else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
+  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
+
+spanTail :: (a -> Bool) -> [a] -> ([a], [a])
+spanTail f xs = (reverse rejected, reverse satisfying)
+    where (satisfying, rejected) = span f $ reverse xs
+\end{code}
+
 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 handled in DsListComp).  Basically does the translation given in the
 Haskell 98 report:
@@ -532,7 +585,7 @@ dsDo        :: [LStmt Id]
        -> Type                 -- Type of the whole expression
        -> DsM CoreExpr
 
-dsDo stmts body result_ty
+dsDo stmts body _result_ty
   = go (map unLoc stmts)
   where
     go [] = dsLExpr body