[Git][ghc/ghc][wip/T23782] Introduce 'headStrictMap' for use in derived instances
Matthew Craven (@clyring)
gitlab at gitlab.haskell.org
Sun Mar 31 15:25:24 UTC 2024
Matthew Craven pushed to branch wip/T23782 at Glasgow Haskell Compiler / GHC
Commits:
e2b56c2d by Matthew Craven at 2024-03-31T11:24:15-04:00
Introduce 'headStrictMap' for use in derived instances
Fixes #23782.
- - - - -
3 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- libraries/ghc-internal/src/GHC/Internal/Base.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -351,7 +351,7 @@ basicKnownKeyNames
getFieldName, setFieldName,
-- List operations
- concatName, filterName, mapName,
+ concatName, filterName, mapName, headStrictMapName,
zipName, foldrName, buildName, augmentName, appendName,
-- FFI primitive types that are not wired-in.
@@ -739,8 +739,9 @@ ltTag_RDR = nameRdrName ordLTDataConName
eqTag_RDR = nameRdrName ordEQDataConName
gtTag_RDR = nameRdrName ordGTDataConName
-map_RDR, append_RDR :: RdrName
+map_RDR, headStrictMap_RDR, append_RDR :: RdrName
map_RDR = nameRdrName mapName
+headStrictMap_RDR = nameRdrName headStrictMapName
append_RDR = nameRdrName appendName
foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR
@@ -1120,7 +1121,7 @@ considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible")
-- Random GHC.Internal.Base functions
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
- mapName, appendName, assertName,
+ mapName, headStrictMapName, appendName, assertName,
dollarName :: Name
dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey
otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey
@@ -1128,6 +1129,7 @@ foldrName = varQual gHC_INTERNAL_BASE (fsLit "foldr") foldrIdKey
buildName = varQual gHC_INTERNAL_BASE (fsLit "build") buildIdKey
augmentName = varQual gHC_INTERNAL_BASE (fsLit "augment") augmentIdKey
mapName = varQual gHC_INTERNAL_BASE (fsLit "map") mapIdKey
+headStrictMapName = varQual gHC_INTERNAL_BASE (fsLit "headStrictMap") headStrictMapIdKey
appendName = varQual gHC_INTERNAL_BASE (fsLit "++") appendIdKey
assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey
fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey
@@ -2390,8 +2392,10 @@ inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique
inlineIdKey = mkPreludeMiscIdUnique 120
-- see below
-mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique
+mapIdKey, headStrictMapIdKey, dollarIdKey,
+ coercionTokenIdKey, considerAccessibleIdKey :: Unique
mapIdKey = mkPreludeMiscIdUnique 121
+headStrictMapIdKey = mkPreludeMiscIdUnique 122
dollarIdKey = mkPreludeMiscIdUnique 123
coercionTokenIdKey = mkPreludeMiscIdUnique 124
considerAccessibleIdKey = mkPreludeMiscIdUnique 125
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -710,7 +710,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
enum_from tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFrom_RDR [mkVisPat a_Pat] $
untag_Expr [(a_RDR, ah_RDR)] $
- nlHsApps map_RDR
+ nlHsApps headStrictMap_RDR
[nlHsVar tag2con_RDR,
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
@@ -719,7 +719,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
enum_from_then tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFromThen_RDR (map mkVisPat [a_Pat, b_Pat]) $
untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
- nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
+ nlHsApp (nlHsVarApps headStrictMap_RDR [tag2con_RDR]) $
nlHsPar (enum_from_then_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR])
@@ -852,7 +852,7 @@ gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
= mkSimpleGeneratedFunBind loc range_RDR [mkVisPat $ nlTuplePat [a_Pat, b_Pat] Boxed] $
untag_Expr [(a_RDR, ah_RDR)] $
untag_Expr [(b_RDR, bh_RDR)] $
- nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
+ nlHsApp (nlHsVarApps headStrictMap_RDR [tag2con_RDR]) $
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR]))
=====================================
libraries/ghc-internal/src/GHC/Internal/Base.hs
=====================================
@@ -1882,7 +1882,7 @@ augment g xs = g (:) xs
map :: (a -> b) -> [a] -> [b]
{-# NOINLINE [0] map #-}
-- We want the RULEs "map" and "map/coerce" to fire first.
- -- map is recursive, so won't inline anyway,
+ -- map is recursive, so it won't inline anyway,
-- but saying so is more explicit, and silences warnings
map _ [] = []
map f (x:xs) = f x : map f xs
@@ -1913,7 +1913,7 @@ The rules for map work like this.
See also Note [Inline FB functions] in GHC.Internal.List
-* The "mapFB" rule optimises compositions of map
+* The "mapFB/mapFB" rule optimises compositions of map
* The "mapFB/id" rule gets rid of 'map id' calls.
You might think that (mapFB c id) will turn into c simply
@@ -1930,7 +1930,7 @@ The rules for map work like this.
{-# RULES
"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
-"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
+"mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
"mapFB/id" forall c. mapFB c (\x -> x) = c
#-}
@@ -1941,6 +1941,103 @@ The rules for map work like this.
{-# RULES "map/coerce" [1] map coerce = coerce #-}
-- See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt
+-- | Less lazy variant of 'map' that evaluates each /result/ list
+-- element to weak head normal form when it produces the corresponding
+-- cons cell.
+headStrictMap :: (a -> b) -> [a] -> [b]
+{-# NOINLINE [0] headStrictMap #-}
+-- See Note [The rules for map].
+-- headStrictMap is recursive, so it won't inline anyway,
+-- but saying so is more explicit, and silences warnings
+headStrictMap _ [] = []
+headStrictMap f (x:xs) = case f x of
+ !y -> y : headStrictMap f xs
+
+headStrictMapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] headStrictMapFB #-}
+-- See Note [Inline FB functions] in GHC.Internal.List
+headStrictMapFB c f = \x ys -> case f x of
+ !y -> c y ys
+
+partiallyHeadStrictMap :: (a -> (# b #)) -> [a] -> [b]
+{-# NOINLINE [0] partiallyHeadStrictMap #-}
+-- See Note [The rules for map].
+-- partiallyHeadStrictMap is recursive, so it won't inline anyway,
+-- but saying so is more explicit, and silences warnings
+partiallyHeadStrictMap f li = case li of
+ [] -> []
+ x : xs -> case f x of
+ (# y #) -> y : partiallyHeadStrictMap f xs
+
+partiallyHeadStrictMapFB :: (elt -> lst -> lst) -> (a -> (# elt #)) -> a -> lst -> lst
+{-# INLINE [0] partiallyHeadStrictMapFB #-}
+-- See Note [Inline FB functions] in GHC.Internal.List
+partiallyHeadStrictMapFB c f = \x ys -> case f x of
+ (# y #) -> c y ys
+
+-- See Note [The rules for map].
+{-# RULES
+"headStrictMap" [~1]
+ forall f xs.
+ headStrictMap f xs
+ = build (\c n -> foldr (headStrictMapFB c f) n xs)
+"headStrictMapList" [1]
+ forall f.
+ foldr (headStrictMapFB (:) f) []
+ = headStrictMap f
+
+"partiallyHeadStrictMap" [~1]
+ forall f xs.
+ partiallyHeadStrictMap f xs
+ = build (\c n -> foldr (partiallyHeadStrictMapFB c f) n xs)
+"partiallyHeadStrictMapList" [1]
+ forall f.
+ foldr (partiallyHeadStrictMapFB (:) f) []
+ = partiallyHeadStrictMap f
+
+
+"headStrictMapFB/headStrictMapFB"
+ forall c f g.
+ headStrictMapFB (headStrictMapFB c f) g
+ = headStrictMapFB c (\x -> f $! g x)
+"headStrictMapFB/partiallyHeadStrictMapFB"
+ forall c f g.
+ partiallyHeadStrictMapFB (headStrictMapFB c f) g
+ = headStrictMapFB c (\x -> case g x of (# y #) -> f y)
+"headStrictMapFB/mapFB"
+ forall c f g.
+ mapFB (headStrictMapFB c f) g
+ = headStrictMapFB c (\x -> f (g x))
+
+"partiallyHeadStrictMapFB/headStrictMapFB"
+ forall c f g.
+ headStrictMapFB (partiallyHeadStrictMapFB c f) g
+ = partiallyHeadStrictMapFB c (\x -> f $! g x)
+"partiallyHeadStrictMapFB/partiallyHeadStrictMapFB"
+ forall c f g.
+ partiallyHeadStrictMapFB (partiallyHeadStrictMapFB c f) g
+ = partiallyHeadStrictMapFB c (\x -> case g x of (# y #) -> f y)
+"partiallyHeadStrictMapFB/mapFB"
+ forall c f g.
+ mapFB (partiallyHeadStrictMapFB c f) g
+ = partiallyHeadStrictMapFB c (\x -> f (g x))
+
+"mapFB/headStrictMapFB"
+ forall c f g.
+ headStrictMapFB (mapFB c f) g
+ = partiallyHeadStrictMapFB c (\x -> case g x of !y -> (# f y #))
+"mapFB/partiallyHeadStrictMapFB"
+ forall c f g.
+ partiallyHeadStrictMapFB (mapFB c f) g
+ = partiallyHeadStrictMapFB c (\x -> case g x of (# y #) -> (# f y #))
+-- "mapFB/mapFB" rule is above
+
+
+"lazy partiallyHeadStrictMapFB"
+ forall c f.
+ partiallyHeadStrictMapFB c (\x -> (# f x #))
+ = mapFB c f
+ #-}
----------------------------------------------
-- append
----------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2b56c2dd28e5a5eb3583821d2492cfb71688a13
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2b56c2dd28e5a5eb3583821d2492cfb71688a13
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240331/eeb61bb1/attachment-0001.html>
More information about the ghc-commits
mailing list