[commit: ghc] wip/cheap-build: Implement cheapBuild (780c268)
git at git.haskell.org
git at git.haskell.org
Thu Mar 16 17:21:09 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/cheap-build
Link : http://ghc.haskell.org/trac/ghc/changeset/780c268fa9255e37c8d018705c5003fb42afdc32/ghc
>---------------------------------------------------------------
commit 780c268fa9255e37c8d018705c5003fb42afdc32
Author: Ben Gamari <ben at smart-cactus.org>
Date: Tue Aug 4 09:07:11 2015 +0200
Implement cheapBuild
>---------------------------------------------------------------
780c268fa9255e37c8d018705c5003fb42afdc32
compiler/coreSyn/CoreUnfold.hs | 5 +++--
compiler/prelude/PrelNames.hs | 9 +++++---
libraries/base/GHC/Base.hs | 48 ++++++++++++++++++++++++++++++++++++------
3 files changed, 50 insertions(+), 12 deletions(-)
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 0e3efbf..d198062 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -746,8 +746,9 @@ funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
-- Size for functions that are not constructors or primops
-- Note [Function applications]
funSize dflags top_args fun n_val_args voids
- | fun `hasKey` buildIdKey = buildSize
- | fun `hasKey` augmentIdKey = augmentSize
+ | fun `hasKey` buildIdKey = buildSize
+ | fun `hasKey` cheapBuildIdKey = buildSize
+ | fun `hasKey` augmentIdKey = augmentSize
| otherwise = SizeIs size arg_discount res_discount
where
some_val_args = n_val_args > 0
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index e3ebd6a..bcb780d 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -319,7 +319,7 @@ basicKnownKeyNames
-- List operations
concatName, filterName, mapName,
- zipName, foldrName, buildName, augmentName, appendName,
+ zipName, foldrName, buildName, cheapBuildName, augmentName, appendName,
-- FFI primitive types that are not wired-in.
stablePtrTyConName, ptrTyConName, funPtrTyConName,
@@ -1051,7 +1051,8 @@ groupWithName :: Name
groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
-- Random PrelBase functions
-fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
+fromStringName, otherwiseIdName, foldrName,
+ buildName, cheapBuildName, augmentName,
mapName, appendName, assertName,
breakpointName, breakpointCondName, breakpointAutoName,
opaqueTyConName :: Name
@@ -1059,6 +1060,7 @@ fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey
foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey
buildName = varQual gHC_BASE (fsLit "build") buildIdKey
+cheapBuildName = varQual gHC_BASE (fsLit "cheapBuild") cheapBuildIdKey
augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey
mapName = varQual gHC_BASE (fsLit "map") mapIdKey
appendName = varQual gHC_BASE (fsLit "++") appendIdKey
@@ -2051,7 +2053,7 @@ typeLitNatDataConKey = mkPreludeDataConUnique 108
-}
wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
- buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
+ buildIdKey, cheapBuildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,
noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
@@ -2085,6 +2087,7 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21
typeErrorIdKey = mkPreludeMiscIdUnique 22
divIntIdKey = mkPreludeMiscIdUnique 23
modIntIdKey = mkPreludeMiscIdUnique 24
+cheapBuildIdKey = mkPreludeMiscIdUnique 25
unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
returnIOIdKey, newStablePtrIdKey,
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index ffcd7ff..c4afa83 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -188,6 +188,7 @@ not True = False
otherwise = True
build = errorWithoutStackTrace "urk"
+cheapBuild = errorWithoutStackTrace "urk"
foldr = errorWithoutStackTrace "urk"
#endif
@@ -879,6 +880,13 @@ build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build g = g (:) []
+-- | 'cheapBuild' is just like build, except that the simplifier views
+-- it as cheap to construct (similar to to a data constructor).
+cheapBuild :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
+{-# INLINE CONLIKE [1] cheapBuild #-}
+cheapBuild g = g (:) []
+-- See Note [cheapBuild]
+
-- | A list producer that can be fused with 'foldr'.
-- This function is merely
--
@@ -893,14 +901,16 @@ augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
augment g xs = g (:) xs
{-# RULES
-"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (build g) = g k z
+"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (build g) = g k z
+"fold/cheapBuild" forall k z (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (cheapBuild g) = g k z
-"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (augment g xs) = g k (foldr k z xs)
+"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (augment g xs) = g k (foldr k z xs)
-"foldr/id" foldr (:) [] = \x -> x
-"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
+"foldr/id" foldr (:) [] = \x -> x
+"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
-- Only activate this from phase 1, because that's
-- when we disable the rule that expands (++) into foldr
@@ -917,17 +927,41 @@ augment g xs = g (:) xs
"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .
foldr k z (x:build g) = k x (g k z)
+"foldr/cons/cheapBuild"
+ forall k z x (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (x:cheapBuild g) = k x (g k z)
"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
(h::forall b. (a->b->b) -> b -> b) .
augment g (build h) = build (\c n -> g c (h c n))
+"augment/cheapBuild"
+ forall (g::forall b. (a->b->b) -> b -> b)
+ (h::forall b. (a->b->b) -> b -> b) .
+ augment g (cheapBuild h) = cheapBuild (\c n -> g c (h c n))
"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
- augment g [] = build g
+ augment g [] = build g
#-}
-- This rule is true, but not (I think) useful:
-- augment g (augment h t) = augment (\cn -> g c (h c n)) t
+
+{-
+Note [cheapBuild]
+~~~~~~~~~~~~~~~~~
+cheapBuild is just like build, except that it is CONLIKE
+It is used in situations where fusion is more imortant than sharing,
+ie in situation where its argument function 'g' in (cheapBuild g) is
+cheap.
+Main example: enumerations of one kind or another:
+ f x = let xs = [x..]
+ go = \y. ....go y'....(map (h y) xs)...
+ in ...
+Here we woud like to fuse the map with the [x..].
+
+See Trac #7206.
+-}
+
----------------------------------------------
-- map
----------------------------------------------
More information about the ghc-commits
mailing list