Commit 6febb616 authored by batterseapower's avatar batterseapower

Make explicit lists more fusable

parent 7a7b51ab
......@@ -1469,8 +1469,9 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
-- 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
......
......@@ -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'
......@@ -522,6 +519,59 @@ 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! 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:
......
......@@ -32,7 +32,6 @@ import DynFlags
import CoreUtils
import Var
import Type
import TysPrim
import TysWiredIn
import Match
import PrelNames
......@@ -65,17 +64,9 @@ dsListComp lquals body elt_ty = do
|| 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
......@@ -409,13 +400,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do
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}
%************************************************************************
......@@ -481,7 +466,6 @@ mkUnzipBind elt_tys = do
unzip_fn <- newSysLocalDs unzip_fn_ty
foldr_id <- dsLookupGlobalId foldrName
[us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
......@@ -493,10 +477,8 @@ mkUnzipBind elt_tys = do
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
......
......@@ -27,6 +27,7 @@ module DsUtils (
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
mkStringExpr, mkStringExprFS, mkIntegerExpr,
mkBuildExpr, mkFoldrExpr,
seqVar,
......@@ -913,6 +914,27 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment