[Git][ghc/ghc][master] Define `Infinite` list and use where appropriate.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Nov 8 17:54:19 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
68f49874 by M Farkas-Dyck at 2022-11-08T12:53:55-05:00
Define `Infinite` list and use where appropriate.
Also add perf test for infinite list fusion.
In particular, in `GHC.Core`, often we deal with infinite lists of roles. Also in a few locations we deal with infinite lists of names.
Thanks to simonpj for helping to write the Note [Fusion for `Infinite` lists].
- - - - -
21 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Reduction.hs
- compiler/GHC/Core/Unify.hs
- + compiler/GHC/Data/List/Infinite.hs
- compiler/GHC/HsToCore/Pmc/Ppr.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/perf/compiler/InfiniteListFusion.hs
- + testsuite/tests/perf/compiler/InfiniteListFusion.stdout
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -119,7 +119,6 @@ in GHC.Builtin.Types.
-}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Builtin.Names
( Unique, Uniquable(..), hasKey, -- Re-exported for convenience
@@ -143,6 +142,8 @@ import GHC.Builtin.Uniques
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Data.FastString
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
import Language.Haskell.Syntax.Module.Name
@@ -154,9 +155,13 @@ import Language.Haskell.Syntax.Module.Name
************************************************************************
-}
-allNameStrings :: [String]
+allNameStrings :: Infinite String
-- Infinite list of a,b,c...z, aa, ab, ac, ... etc
-allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ]
+allNameStrings = Inf.allListsOf ['a'..'z']
+
+allNameStringList :: [String]
+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc
+allNameStringList = Inf.toList allNameStrings
{-
************************************************************************
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -63,6 +63,7 @@ module GHC.Core.Coercion (
splitForAllCo_ty_maybe, splitForAllCo_co_maybe,
nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,
+ tyConRoleListX, tyConRoleListRepresentational,
pickLR,
@@ -154,6 +155,8 @@ import GHC.Builtin.Types.Prim
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Types.Unique.FM
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -408,12 +411,10 @@ where co_rep1, co_rep2 are the coercions on the representations.
--
-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]
decomposeCo :: Arity -> Coercion
- -> [Role] -- the roles of the output coercions
- -- this must have at least as many
- -- entries as the Arity provided
+ -> Infinite Role -- the roles of the output coercions
-> [Coercion]
decomposeCo arity co rs
- = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]
+ = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]
-- Remember, Nth is zero-indexed
decomposeFunCo :: HasDebugCallStack
@@ -533,7 +534,7 @@ splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe co
| Just (ty, r) <- isReflCo_maybe co
= do { (tc, tys) <- splitTyConApp_maybe ty
- ; let args = zipWith mkReflCo (tyConRolesX r tc) tys
+ ; let args = zipWith mkReflCo (tyConRoleListX r tc) tys
; return (tc, args) }
splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)
splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos)
@@ -819,15 +820,14 @@ mkAppCo co arg
-- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)
= mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)
where
- zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg]
- zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys
- zip_roles _ _ = panic "zip_roles" -- but the roles are infinite...
+ zip_roles (Inf r1 _) [] = [downgradeRole r1 Nominal arg]
+ zip_roles (Inf r1 rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys
mkAppCo (TyConAppCo r tc args) arg
= case r of
Nominal -> mkTyConAppCo Nominal tc (args ++ [arg])
Representational -> mkTyConAppCo Representational tc (args ++ [arg'])
- where new_role = (tyConRolesRepresentational tc) !! (length args)
+ where new_role = tyConRolesRepresentational tc Inf.!! length args
arg' = downgradeRole new_role Nominal arg
Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])
mkAppCo co arg = AppCo co arg
@@ -1153,10 +1153,7 @@ mkNthCo r n co
, tc1 == tc2
= let len1 = length tys1
len2 = length tys2
- good_role = case coercionRole co of
- Nominal -> r == Nominal
- Representational -> r == (tyConRolesRepresentational tc1 !! n)
- Phantom -> r == Phantom
+ good_role = r == nthRole (coercionRole co) tc1 n
in len1 == len2 && n < len1 && good_role
| otherwise
@@ -1349,7 +1346,7 @@ setNominalRole_maybe r co
setNominalRole_maybe_helper co@(Refl _) = Just co
setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co
setNominalRole_maybe_helper (TyConAppCo Representational tc cos)
- = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos
+ = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos
; return $ TyConAppCo Nominal tc cos' }
setNominalRole_maybe_helper (FunCo Representational w co1 co2)
= do { co1' <- setNominalRole_maybe Representational co1
@@ -1393,27 +1390,33 @@ toPhantomCo co
-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational
applyRoles :: TyCon -> [Coercion] -> [Coercion]
-applyRoles tc cos
- = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos
+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational
-- the Role parameter is the Role of the TyConAppCo
-- defined here because this is intimately concerned with the implementation
-- of TyConAppCo
-- Always returns an infinite list (with a infinite tail of Nominal)
-tyConRolesX :: Role -> TyCon -> [Role]
+tyConRolesX :: Role -> TyCon -> Infinite Role
tyConRolesX Representational tc = tyConRolesRepresentational tc
-tyConRolesX role _ = repeat role
+tyConRolesX role _ = Inf.repeat role
+
+tyConRoleListX :: Role -> TyCon -> [Role]
+tyConRoleListX role = Inf.toList . tyConRolesX role
+
+-- Returns the roles of the parameters of a tycon, with an infinite tail
+-- of Nominal
+tyConRolesRepresentational :: TyCon -> Infinite Role
+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal
-- Returns the roles of the parameters of a tycon, with an infinite tail
-- of Nominal
-tyConRolesRepresentational :: TyCon -> [Role]
-tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal
+tyConRoleListRepresentational :: TyCon -> [Role]
+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational
nthRole :: Role -> TyCon -> Int -> Role
nthRole Nominal _ _ = Nominal
nthRole Phantom _ _ = Phantom
-nthRole Representational tc n
- = (tyConRolesRepresentational tc) `getNth` n
+nthRole Representational tc n = tyConRolesRepresentational tc Inf.!! n
ltRole :: Role -> Role -> Bool
-- Is one role "less" than another?
@@ -2034,7 +2037,7 @@ ty_co_subst !lc role ty
go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $
liftCoSubstTyVar lc r tv
go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2)
- go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)
+ go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)
go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2)
go r t@(ForAllTy (Bndr v _) ty)
= let (lc', v', h) = liftCoSubstVarBndr lc v
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -245,7 +245,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
(True, Nominal) ->
mkTyConAppCo Representational tc
(zipWith3 (opt_co3 env sym)
- (map Just (tyConRolesRepresentational tc))
+ (map Just (tyConRoleListRepresentational tc))
(repeat Nominal)
cos)
(False, Nominal) ->
@@ -254,7 +254,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
-- must use opt_co2 here, because some roles may be P
-- See Note [Optimising coercion optimisation]
mkTyConAppCo r tc (zipWith (opt_co2 env sym)
- (tyConRolesRepresentational tc) -- the current roles
+ (tyConRoleListRepresentational tc) -- the current roles
cos)
(_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)
@@ -546,7 +546,7 @@ opt_univ env sym prov role oty1 oty2
, equalLength tys1 tys2 -- see Note [Differing kinds]
-- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);
-- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps
- = let roles = tyConRolesX role tc1
+ = let roles = tyConRoleListX role tc1
arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2
arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos
in
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -63,6 +63,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Bag
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
{-
************************************************************************
@@ -1477,7 +1479,7 @@ normalise_type ty
Nothing ->
do { ArgsReductions redns res_co
<- normalise_args (typeKind nfun)
- (repeat Nominal)
+ (Inf.repeat Nominal)
arg_tys
; role <- getRole
; return $
@@ -1486,7 +1488,7 @@ normalise_type ty
(mkSymMCo res_co) } }
normalise_args :: Kind -- of the function
- -> [Role] -- roles at which to normalise args
+ -> Infinite Role -- roles at which to normalise args
-> [Type] -- args
-> NormM ArgsReductions
-- returns ArgsReductions (Reductions cos xis) res_co,
@@ -1496,7 +1498,7 @@ normalise_args :: Kind -- of the function
-- but the resulting application *will* be well-kinded
-- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow
normalise_args fun_ki roles args
- = do { normed_args <- zipWithM normalise1 roles args
+ = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args
; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }
where
(ki_binders, inner_ki) = splitPiTys fun_ki
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2177,7 +2177,7 @@ lintCoercion co@(TyConAppCo r tc cos)
; let (co_kinds, co_roles) = unzip (map coercionKindRole cos')
; lint_co_app co (tyConKind tc) (map pFst co_kinds)
; lint_co_app co (tyConKind tc) (map pSnd co_kinds)
- ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles
+ ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles
; return (TyConAppCo r tc cos') }
lintCoercion co@(AppCo co1 co2)
=====================================
compiler/GHC/Core/Reduction.hs
=====================================
@@ -35,6 +35,8 @@ import GHC.Core.TyCon ( TyCon )
import GHC.Core.Type
import GHC.Data.Pair ( Pair(Pair) )
+import GHC.Data.List.Infinite ( Infinite (..) )
+import qualified GHC.Data.List.Infinite as Inf
import GHC.Types.Var ( setTyVarKind )
import GHC.Types.Var.Env ( mkInScopeSet )
@@ -42,7 +44,7 @@ import GHC.Types.Var.Set ( TyCoVarSet )
import GHC.Utils.Misc ( HasDebugCallStack, equalLength )
import GHC.Utils.Outputable
-import GHC.Utils.Panic ( assertPpr, panic )
+import GHC.Utils.Panic ( assertPpr )
{-
%************************************************************************
@@ -788,7 +790,7 @@ simplifyArgsWorker :: HasDebugCallStack
-- the binders & result kind (not a Π-type) of the function applied to the args
-- list of binders can be shorter or longer than the list of args
-> TyCoVarSet -- free vars of the args
- -> [Role] -- list of roles, r
+ -> Infinite Role-- list of roles, r
-> [Reduction] -- rewritten type arguments, arg_i
-- each comes with the coercion used to rewrite it,
-- arg_co_i :: ty_i ~ arg_i
@@ -809,11 +811,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
where
orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs
- go :: LiftingContext -- mapping from tyvars to rewriting coercions
- -> [TyCoBinder] -- Unsubsted binders of function's kind
- -> Kind -- Unsubsted result kind of function (not a Pi-type)
- -> [Role] -- Roles at which to rewrite these ...
- -> [Reduction] -- rewritten arguments, with their rewriting coercions
+ go :: LiftingContext -- mapping from tyvars to rewriting coercions
+ -> [TyCoBinder] -- Unsubsted binders of function's kind
+ -> Kind -- Unsubsted result kind of function (not a Pi-type)
+ -> Infinite Role -- Roles at which to rewrite these ...
+ -> [Reduction] -- rewritten arguments, with their rewriting coercions
-> ArgsReductions
go !lc binders inner_ki _ []
-- The !lc makes the function strict in the lifting context
@@ -826,7 +828,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
kind_co | noFreeVarsOfType final_kind = MRefl
| otherwise = MCo $ liftCoSubst Nominal lc final_kind
- go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns)
+ go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns)
= -- We rewrite an argument ty with arg_redn = Reduction arg_co arg
-- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),
-- tcTypeKind(ty) = tcTypeKind(arg).
@@ -859,7 +861,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
(arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys
casted_args = assertPpr (equalLength arg_redns arg_cos)
(ppr arg_redns $$ ppr arg_cos)
- $ zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos
+ $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos
-- In general decomposePiCos can return fewer cos than tys,
-- but not here; because we're well typed, there will be enough
-- binders. Note that decomposePiCos does substitutions, so even
@@ -874,19 +876,3 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
= go zapped_lc bndrs new_inner roles casted_args
in
ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)
-
- go _ _ _ _ _ = panic
- "simplifyArgsWorker wandered into deeper water than usual"
- -- This debug information is commented out because leaving it in
- -- causes a ~2% increase in allocations in T9872d.
- -- That's independent of the analogous case in rewrite_args_fast
- -- in GHC.Tc.Solver.Rewrite:
- -- each of these causes a 2% increase on its own, so commenting them
- -- both out gives a 4% decrease in T9872d.
- {-
-
- (vcat [ppr orig_binders,
- ppr orig_inner_ki,
- ppr (take 10 orig_roles), -- often infinite!
- ppr orig_tys])
- -}
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1742,7 +1742,7 @@ pushRefl co =
-> Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2
, mkReflCo r ty1, mkReflCo r ty2 ])
Just (TyConApp tc tys, r)
- -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
+ -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))
Just (ForAllTy (Bndr tv _) ty, r)
-> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))
-- NB: NoRefl variant. Otherwise, we get a loop!
=====================================
compiler/GHC/Data/List/Infinite.hs
=====================================
@@ -0,0 +1,194 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHC.Data.List.Infinite
+ ( Infinite (..)
+ , head, tail
+ , filter
+ , (++)
+ , unfoldr
+ , (!!)
+ , groupBy
+ , dropList
+ , iterate
+ , concatMap
+ , allListsOf
+ , toList
+ , repeat
+ ) where
+
+import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise)
+import Control.Category (Category (..))
+import Control.Monad (guard)
+import qualified Data.Foldable as F
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified GHC.Base as List (build)
+
+data Infinite a = Inf a (Infinite a)
+ deriving (Foldable, Functor, Traversable)
+
+head :: Infinite a -> a
+head (Inf a _) = a
+{-# NOINLINE [1] head #-}
+
+tail :: Infinite a -> Infinite a
+tail (Inf _ as) = as
+{-# NOINLINE [1] tail #-}
+
+{-# RULES
+"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x
+#-}
+
+instance Applicative Infinite where
+ pure = repeat
+ Inf f fs <*> Inf a as = Inf (f a) (fs <*> as)
+
+mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b
+mapMaybe f = go
+ where
+ go (Inf a as) = let bs = go as in case f a of
+ Nothing -> bs
+ Just b -> Inf b bs
+{-# NOINLINE [1] mapMaybe #-}
+
+{-# RULES
+"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as
+"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f
+ #-}
+
+{-# INLINE [0] mapMaybeFB #-}
+mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r
+mapMaybeFB cons f a bs = case f a of
+ Nothing -> bs
+ Just r -> cons r bs
+
+filter :: (a -> Bool) -> Infinite a -> Infinite a
+filter f = mapMaybe (\ a -> a <$ guard (f a))
+{-# INLINE filter #-}
+
+infixr 5 ++
+(++) :: Foldable f => f a -> Infinite a -> Infinite a
+(++) = flip (F.foldr Inf)
+
+unfoldr :: (b -> (a, b)) -> b -> Infinite a
+unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b
+{-# INLINE unfoldr #-}
+
+(!!) :: Infinite a -> Int -> a
+Inf a _ !! 0 = a
+Inf _ as !! n = as !! (n-1)
+
+groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a)
+groupBy eq = go
+ where
+ go (Inf a as) = Inf (a:|bs) (go cs)
+ where (bs, cs) = span (eq a) as
+
+span :: (a -> Bool) -> Infinite a -> ([a], Infinite a)
+span p = spanJust (\ a -> a <$ guard (p a))
+{-# INLINE span #-}
+
+spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a)
+spanJust p = go
+ where
+ go as@(Inf a as')
+ | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs)
+ | otherwise = ([], as)
+
+iterate :: (a -> a) -> a -> Infinite a
+iterate f = go where go a = Inf a (go (f a))
+{-# NOINLINE [1] iterate #-}
+
+{-# RULES
+"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a)
+"iterateFB" [1] iterateFB Inf = iterate
+#-}
+
+iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b
+iterateFB c f a = go a
+ where go a = a `c` go (f a)
+{-# INLINE [0] iterateFB #-}
+
+concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b
+concatMap f = go where go (Inf a as) = f a ++ go as
+{-# NOINLINE [1] concatMap #-}
+
+{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-}
+
+{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-}
+
+foldr :: (a -> b -> b) -> Infinite a -> b
+foldr f = go where go (Inf a as) = f a (go as)
+{-# INLINE [0] foldr #-}
+
+build :: (forall b . (a -> b -> b) -> b) -> Infinite a
+build g = g Inf
+{-# INLINE [1] build #-}
+
+-- Analogous to 'foldr'/'build' fusion for '[]'
+{-# RULES
+"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f
+"foldr/id" foldr Inf = id
+
+"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f)
+#-}
+
+{-# RULES
+"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as
+"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g)
+"mapFB/id" forall c . mapFB c (\ x -> x) = c
+#-}
+
+mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c
+mapFB c f = \ x ys -> c (f x) ys
+{-# INLINE [0] mapFB #-}
+
+dropList :: [a] -> Infinite b -> Infinite b
+dropList [] bs = bs
+dropList (_:as) (Inf _ bs) = dropList as bs
+
+-- | Compute all lists of the given alphabet.
+-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@
+allListsOf :: [a] -> Infinite [a]
+allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as)
+
+-- See Note [Fusion for `Infinite` lists].
+toList :: Infinite a -> [a]
+toList = \ as -> List.build (\ c _ -> foldr c as)
+{-# INLINE toList #-}
+
+repeat :: a -> Infinite a
+repeat a = as where as = Inf a as
+{-# INLINE [0] repeat #-}
+
+repeatFB :: (a -> b -> b) -> a -> b
+repeatFB c x = xs where xs = c x xs
+{-# INLINE [0] repeatFB #-}
+
+{-# RULES
+"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a
+"repeatFB" [1] repeatFB Inf = repeat
+#-}
+
+{-
+Note [Fusion for `Infinite` lists]
+~~~~~~~~~~~~~~~~~~~~
+We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in
+GHC.Base to support fusion for regular lists. In particular, we define the following:
+• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a`
+• `foldr :: (a -> b -> b) -> Infinite a -> b`
+• A RULE `foldr f (build g) = g f`
+• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in
+ terms of `foldr`
+
+This can work across data types. For example, consider `toList :: Infinite a -> [a]`.
+We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]').
+Ergo, we define it in terms of 'Infinite.foldr' and `List.build`.
+
+For a bigger example, consider `List.map f (toList (Infinite.map g as))`
+
+We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`,
+and the list structure between `toList` and `List.map`. And indeed we do: see test
+"InfiniteListFusion".
+-}
=====================================
compiler/GHC/HsToCore/Pmc/Ppr.hs
=====================================
@@ -1,6 +1,5 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for
-- user facing pattern match warnings.
@@ -10,6 +9,8 @@ module GHC.HsToCore.Pmc.Ppr (
import GHC.Prelude
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Var.Env
@@ -101,12 +102,11 @@ prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList
attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))
-type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a
+type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a
-- Try nice names p,q,r,s,t before using the (ugly) t_i
-nameList :: [SDoc]
-nameList = map text ["p","q","r","s","t"] ++
- [ text ('t':show u) | u <- [(0 :: Int)..] ]
+nameList :: Infinite SDoc
+nameList = map text ["p","q","r","s","t"] Inf.++ flip Inf.unfoldr (0 :: Int) (\ u -> (text ('t':show u), u+1))
runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
@@ -117,7 +117,7 @@ runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
getCleanName :: Id -> PmPprM SDoc
getCleanName x = do
(renamings, name_supply) <- get
- let (clean_name:name_supply') = name_supply
+ let Inf clean_name name_supply' = name_supply
case lookupDVarEnv renamings x of
Just (_, nm) -> pure nm
Nothing -> do
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Data.FastString
import GHC.Data.Maybe (catMaybes)
import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)
import GHC.Hs.Type (pprLHsContext)
-import GHC.Builtin.Names (allNameStrings)
+import GHC.Builtin.Names (allNameStringList)
import GHC.Builtin.Types (filterCTuple)
import qualified GHC.LanguageExtensions as LangExt
import Data.List.NonEmpty (NonEmpty((:|)))
@@ -486,7 +486,7 @@ instance Diagnostic PsMessage where
, nest 2
(what
<+> tc'
- <+> hsep (map text (takeList tparms allNameStrings))
+ <+> hsep (map text (takeList tparms allNameStringList))
<+> equals_or_where) ] ]
where
-- Avoid printing a constraint tuple in the error message. Print
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -173,7 +173,7 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
children_only
= do { args <- unzipRedns <$>
zipWithM ( \ ty r -> go r rec_nts ty )
- tys (tyConRolesX role tc)
+ tys (tyConRoleListX role tc)
; return $ mkTyConAppRedn role tc args }
nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
nt_rhs = newTyConInstRhs tc tys
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -125,6 +126,8 @@ import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
+import GHC.Data.List.Infinite ( Infinite (..) )
+import qualified GHC.Data.List.Infinite as Inf
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Data.Bag( unitBag )
@@ -3693,12 +3696,10 @@ splitTyConKind skol_info in_scope avoid_occs kind
; uniqs <- newUniqueSupply
; rdr_env <- getLocalRdrEnv
; lvl <- getTcLevel
- ; let new_occs = [ occ
- | str <- allNameStrings
- , let occ = mkOccName tvName str
- , isNothing (lookupLocalRdrOcc rdr_env occ)
- -- Note [Avoid name clashes for associated data types]
- , not (occ `elem` avoid_occs) ]
+ ; let new_occs = Inf.filter (\ occ ->
+ isNothing (lookupLocalRdrOcc rdr_env occ) &&
+ -- Note [Avoid name clashes for associated data types]
+ not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings
new_uniqs = uniqsFromSupply uniqs
subst = mkEmptySubst in_scope
details = SkolemTv skol_info (pushTcLevel lvl) False
@@ -3716,8 +3717,8 @@ splitTyConKind skol_info in_scope avoid_occs kind
name = mkInternalName uniq occ loc
tv = mkTcTyVar name arg' details
subst' = extendSubstInScope subst tv
- (uniq:uniqs') = uniqs
- (occ:occs') = occs
+ uniq:uniqs' = uniqs
+ Inf occ occs' = occs
Just (Named (Bndr tv vis), kind')
-> go occs uniqs subst' (tcb : acc) kind'
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -1914,7 +1914,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
role = eqRelRole eq_rel
-- infinite, as tyConRolesX returns an infinite tail of Nominal
- tc_roles = tyConRolesX role tc
+ tc_roles = tyConRoleListX role tc
-- Add nuances to the location during decomposition:
-- * if the argument is a kind argument, remember this, so that error
@@ -3128,7 +3128,7 @@ unifyWanted rewriters loc role orig_ty1 orig_ty2
| tc1 == tc2, tys1 `equalLength` tys2
, isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
= do { cos <- zipWith3M (unifyWanted rewriters loc)
- (tyConRolesX role tc1) tys1 tys2
+ (tyConRoleListX role tc1) tys1 tys2
; return (mkTyConAppCo role tc1 cos) }
go ty1@(TyVarTy tv) ty2
=====================================
compiler/GHC/Tc/Solver/Rewrite.hs
=====================================
@@ -42,6 +42,8 @@ import Control.Monad
import Control.Applicative (liftA3)
import GHC.Builtin.Types.Prim (tYPETyCon)
import Data.List ( find )
+import GHC.Data.List.Infinite (Infinite)
+import qualified GHC.Data.List.Infinite as Inf
{-
************************************************************************
@@ -368,7 +370,7 @@ we skip adding to the cache here.
{-# INLINE rewrite_args_tc #-}
rewrite_args_tc
:: TyCon -- T
- -> Maybe [Role] -- Nothing: ambient role is Nominal; all args are Nominal
+ -> Maybe (Infinite Role) -- Nothing: ambient role is Nominal; all args are Nominal
-- Otherwise: no assumptions; use roles provided
-> [Type]
-> RewriteM ArgsReductions -- See the commentary on rewrite_args
@@ -392,7 +394,7 @@ rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet
rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
-- named.
-> Kind -> TcTyCoVarSet -- function kind; kind's free vars
- -> Maybe [Role] -> [Type] -- these are in 1-to-1 correspondence
+ -> Maybe (Infinite Role) -> [Type] -- these are in 1-to-1 correspondence
-- Nothing: use all Nominal
-> RewriteM ArgsReductions
-- This function returns ArgsReductions (Reductions cos xis) res_co
@@ -413,7 +415,7 @@ rewrite_args orig_binders
= case (orig_m_roles, any_named_bndrs) of
(Nothing, False) -> rewrite_args_fast orig_tys
_ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
- where orig_roles = fromMaybe (repeat Nominal) orig_m_roles
+ where orig_roles = fromMaybe (Inf.repeat Nominal) orig_m_roles
{-# INLINE rewrite_args_fast #-}
-- | fast path rewrite_args, in which none of the binders are named and
@@ -438,10 +440,10 @@ rewrite_args_fast orig_tys
-- | Slow path, compared to rewrite_args_fast, because this one must track
-- a lifting context.
rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
- -> [Role] -> [Type]
+ -> Infinite Role -> [Type]
-> RewriteM ArgsReductions
rewrite_args_slow binders inner_ki fvs roles tys
- = do { rewritten_args <- zipWithM rw roles tys
+ = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys
; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }
where
{-# INLINE rw #-}
@@ -587,7 +589,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
= do { het_redn <- case tcSplitTyConApp_maybe fun_xi of
Just (tc, xis) ->
do { let tc_roles = tyConRolesRepresentational tc
- arg_roles = dropList xis tc_roles
+ arg_roles = Inf.dropList xis tc_roles
; ArgsReductions (Reductions arg_cos arg_xis) kind_co
<- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys
@@ -608,7 +610,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)
`mkTcTransCo`
mkTcTyConAppCo Representational tc
- (zipWith mkReflCo tc_roles xis ++ arg_cos)
+ (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos)
; return $
mkHetReduction
@@ -616,7 +618,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
kind_co }
Nothing ->
do { ArgsReductions redns kind_co
- <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys
+ <- rewrite_vector (tcTypeKind fun_xi) (Inf.repeat Nominal) arg_tys
; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }
; role <- getRole
@@ -636,7 +638,7 @@ rewrite_ty_con_app tc tys
-- Rewrite a vector (list of arguments).
rewrite_vector :: Kind -- of the function being applied to these arguments
- -> [Role] -- If we're rewriting w.r.t. ReprEq, what roles do the
+ -> Infinite Role -- If we're rewriting w.r.t. ReprEq, what roles do the
-- args have?
-> [Type] -- the args to rewrite
-> RewriteM ArgsReductions
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -976,7 +976,7 @@ any_rewritable role tv_pred tc_pred should_expand
go_tc NomEq bvs _ tys = any (go NomEq bvs) tys
go_tc ReprEq bvs tc tys = any (go_arg bvs)
- (tyConRolesRepresentational tc `zip` tys)
+ (tyConRoleListRepresentational tc `zip` tys)
go_arg bvs (Nominal, ty) = go NomEq bvs ty
go_arg bvs (Representational, ty) = go ReprEq bvs ty
=====================================
compiler/ghc.cabal.in
=====================================
@@ -378,6 +378,7 @@ Library
GHC.Data.Graph.Ppr
GHC.Data.Graph.UnVar
GHC.Data.IOEnv
+ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -87,6 +87,7 @@ GHC.Data.FiniteMap
GHC.Data.Graph.Directed
GHC.Data.Graph.UnVar
GHC.Data.IOEnv
+GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -87,6 +87,7 @@ GHC.Data.FiniteMap
GHC.Data.Graph.Directed
GHC.Data.Graph.UnVar
GHC.Data.IOEnv
+GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
=====================================
testsuite/tests/perf/compiler/InfiniteListFusion.hs
=====================================
@@ -0,0 +1,9 @@
+module Main where
+
+import qualified GHC.Data.List.Infinite as Inf
+
+main :: IO ()
+main = print $ sum $ take (2^16) $ Inf.toList $ Inf.filter isEven $ Inf.iterate succ (0 :: Int)
+
+isEven :: Integral a => a -> Bool
+isEven n = 0 == mod n 2
=====================================
testsuite/tests/perf/compiler/InfiniteListFusion.stdout
=====================================
@@ -0,0 +1 @@
+4294901760
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -649,4 +649,9 @@ test('T21839c',
[ collect_compiler_stats('all', 1),
only_ways(['normal'])],
compile,
- ['-O'])
\ No newline at end of file
+ ['-O'])
+
+test ('InfiniteListFusion',
+ [collect_stats('bytes allocated',2), when(arch('i386'), skip)],
+ compile_and_run,
+ ['-O2 -package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68f49874aa217c2222c80c596ef11ffd992b459a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68f49874aa217c2222c80c596ef11ffd992b459a
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/20221108/7f8ccc75/attachment-0001.html>
More information about the ghc-commits
mailing list