diff options
author | M Farkas-Dyck <strake888@proton.me> | 2022-09-18 20:23:23 -0800 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-11-08 12:53:55 -0500 |
commit | 68f49874aa217c2222c80c596ef11ffd992b459a (patch) | |
tree | 215cafabd967e33b9d1c70182474d3690d1767fa /compiler | |
parent | 5fe11fe612e1881bd4d1b9d5950d0d801e08e159 (diff) | |
download | haskell-68f49874aa217c2222c80c596ef11ffd992b459a.tar.gz |
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].
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Core/Coercion.hs | 49 | ||||
-rw-r--r-- | compiler/GHC/Core/Coercion/Opt.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/FamInstEnv.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Core/Lint.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Reduction.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/Core/Unify.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Data/List/Infinite.hs | 194 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Ppr.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Foreign.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Tc/Solver/Canonical.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Solver/Rewrite.hs | 20 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/TcType.hs | 2 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 |
16 files changed, 282 insertions, 88 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 57e2fcdc75..26fb6c35b4 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/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 {- ************************************************************************ diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 1449e2331d..ad4e1b4ada 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/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 diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 6fa8fc1273..d061d795a7 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/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 diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index e955e5befd..5ecb83d4a6 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/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 diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 086a727095..6c285db819 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/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) diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs index f15b335fd7..f97b9517b6 100644 --- a/compiler/GHC/Core/Reduction.hs +++ b/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]) - -} diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 188d5ff32f..596fef6b6f 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/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! diff --git a/compiler/GHC/Data/List/Infinite.hs b/compiler/GHC/Data/List/Infinite.hs new file mode 100644 index 0000000000..0dec54438f --- /dev/null +++ b/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". +-} diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs index 9d57e99b07..d28f835327 100644 --- a/compiler/GHC/HsToCore/Pmc/Ppr.hs +++ b/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 diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 1263d5104b..65e2695f66 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/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 diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index b8899e2431..d31cae7820 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/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 diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index a664092221..fa24c6286b 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/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' diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 332d59244a..b3affa011d 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/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 diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs index 6e8baf15a6..e746f35e41 100644 --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/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 diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index eae089c203..c0f42e056f 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 8e73f8b736..d065f4194e 100644 --- a/compiler/ghc.cabal.in +++ b/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 |