From 6febb616f1ff46942434e9df39c6e4977b07cc6f Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Thu, 28 Feb 2008 08:30:50 +0000 Subject: [PATCH] Make explicit lists more fusable --- compiler/coreSyn/CoreUtils.lhs | 5 ++-- compiler/deSugar/DsExpr.lhs | 62 +++++++++++++++++++++++++++++++++++---- compiler/deSugar/DsListComp.lhs | 30 ++++--------------- compiler/deSugar/DsUtils.lhs | 22 ++++++++++++++ 4 files changed, 87 insertions(+), 32 deletions(-) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 05d429e..a4b0e6e 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5366c56..0633717 100644 --- 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' @@ -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: diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index a908c78..e5e1fd9 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -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 diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index f63b884..5eb33c8 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -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 -- 1.7.10.4