-- no thunks involved at all.
--
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
--- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
--- update flag on it.
+-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
+-- update flag on it and (iii) in DsExpr to decide how to expand
+-- list literals
--
-- The basic idea is that rhsIsStatic returns True only if the RHS is
-- (a) a value lambda
#include "HsVersions.h"
-
import Match
import MatchLit
import DsBinds
import CoreSyn
import CoreUtils
+import DynFlags
import CostCentre
import Id
import PrelInfo
\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'
%--------------------------------------------------------------------
+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! However, if it does occur
+ then we can potentially save quite a bit of allocation (up to 25\%
+ of the total in some nofib programs!)
+
+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:
import CoreUtils
import Var
import Type
-import TysPrim
import TysWiredIn
import Match
import PrelNames
|| isParallelComp quals
-- Foldr-style desugaring can't handle parallel list comprehensions
then deListComp quals body (mkNilExpr elt_ty)
- else do -- Foldr/build should be enabled, so desugar
- -- into foldrs and builds
- [n_tyvar] <- newTyVarsDs [alphaTyVar]
-
- let n_ty = mkTyVarTy n_tyvar
- c_ty = mkFunTys [elt_ty, n_ty] n_ty
- [c, n] <- newSysLocalsDs [c_ty, n_ty]
-
- result <- dfListComp c n quals body
- build_id <- dsLookupGlobalId buildName
- return (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result)
+ else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
+ -- Foldr/build should be enabled, so desugar
+ -- into foldrs and builds
where
-- We must test for ParStmt anywhere, not just at the head, because an extension
pat core_rest (Var b)
-- now build the outermost foldr, and return
- foldr_id <- dsLookupGlobalId foldrName
- return (Var foldr_id `App` Type x_ty
- `App` Type b_ty
- `App` mkLams [x, b] core_expr
- `App` Var n_id
- `App` core_list1)
-
+ mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
\end{code}
%************************************************************************
unzip_fn <- newSysLocalDs unzip_fn_ty
- foldr_id <- dsLookupGlobalId foldrName
[us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
folder_body = mkLams [ax, axs] folder_body_outer_case
- unzip_body = mkApps (Var foldr_id) [Type elt_tuple_ty, Type elt_list_tuple_ty, folder_body, nil_tuple, Var ys]
- unzip_body_saturated = mkLams [ys] unzip_body
-
- return (unzip_fn, unzip_body_saturated)
+ unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+ return (unzip_fn, mkLams [ys] unzip_body)
where
elt_tuple_ty = mkBigCoreTupTy elt_tys
elt_tuple_list_ty = mkListTy elt_tuple_ty
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
mkStringExpr, mkStringExprFS, mkIntegerExpr,
+ mkBuildExpr, mkFoldrExpr,
seqVar,
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
+mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr
+mkFoldrExpr elt_ty result_ty c n list = do
+ foldr_id <- dsLookupGlobalId foldrName
+ return (Var foldr_id `App` Type elt_ty
+ `App` Type result_ty
+ `App` c
+ `App` n
+ `App` list)
+
+mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
+mkBuildExpr elt_ty mk_build_inside = do
+ [n_tyvar] <- newTyVarsDs [alphaTyVar]
+ let n_ty = mkTyVarTy n_tyvar
+ c_ty = mkFunTys [elt_ty, n_ty] n_ty
+ [c, n] <- newSysLocalsDs [c_ty, n_ty]
+
+ build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
+
+ build_id <- dsLookupGlobalId buildName
+ return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
+
mkCoreSel :: [Id] -- The tuple args
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
projects / ghc-hetmet.git / commitdiff