[commit: ghc] wip/cheap-build-osa1: Implement cheapBuild (8dd6a97)

git at git.haskell.org git at git.haskell.org
Wed Feb 21 06:50:19 UTC 2018


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/cheap-build-osa1
Link       : http://ghc.haskell.org/trac/ghc/changeset/8dd6a971d6785b09ac4da2505ee918a2aa20f0bd/ghc

>---------------------------------------------------------------

commit 8dd6a971d6785b09ac4da2505ee918a2aa20f0bd
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Tue Aug 4 09:07:11 2015 +0200

    Implement cheapBuild


>---------------------------------------------------------------

8dd6a971d6785b09ac4da2505ee918a2aa20f0bd
 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 2e2b7a3..115d635 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -748,8 +748,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 df13eaa..f6cff88 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -322,7 +322,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,
@@ -1059,7 +1059,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, dollarName :: Name
@@ -1067,6 +1068,7 @@ dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey
 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
@@ -2072,7 +2074,7 @@ typeLitNatDataConKey      = mkPreludeDataConUnique 108
 -}
 
 wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
-    buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
+    buildIdKey, cheapBuildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
     seqIdKey, eqStringIdKey,
     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
     runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
@@ -2105,6 +2107,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 17d4151..77662ba 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -197,6 +197,7 @@ not True = False
 otherwise = True
 
 build = errorWithoutStackTrace "urk"
+cheapBuild = errorWithoutStackTrace "urk"
 foldr = errorWithoutStackTrace "urk"
 #endif
 
@@ -1046,6 +1047,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
 --
@@ -1060,14 +1068,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
 
@@ -1084,17 +1094,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