- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T25944] CprAnal: Detect recursive newtypes (#25944)
by Sebastian Graf (＠sgraf812) 26 Apr '25

26 Apr '25

Sebastian Graf pushed to branch wip/T25944 at Glasgow Haskell Compiler / GHC Commits: 6425a1f0 by Sebastian Graf at 2025-04-26T14:35:17+02:00 CprAnal: Detect recursive newtypes (#25944) While `cprTransformDataConWork` handles recursive data con workers, it did not detect the case when a newtype is responsible for the recursion. This is now detected in the `Cast` case of `cprAnal`. The same reproducer made it clear that `isRecDataCon` lacked congruent handling for `AppTy` and `CastTy`, now fixed. Furthermore, the new repro case T25944 triggered this bug via an infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`. While it should be much less likely to trigger such an infinite loop now that `isRecDataCon` has been fixed, I made sure to abort the loop after 10 iterations and emitting a warning instead. Fixes #25944. - - - - - 5 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - + testsuite/tests/cpranal/sigs/T25944.hs - + testsuite/tests/cpranal/sigs/T25944.stderr - testsuite/tests/cpranal/sigs/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate @@ -22,12 +23,15 @@ import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Unique.MemoFun +import GHC.Core import GHC.Core.FamInstEnv import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils -import GHC.Core +import GHC.Core.Coercion +import GHC.Core.Reduction import GHC.Core.Seq +import GHC.Core.TyCon import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet @@ -216,9 +220,13 @@ cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) cprAnal' env (Cast e co) - = (cpr_ty, Cast e' co) + = (cpr_ty', Cast e' co) where (cpr_ty, e') = cprAnal env e + cpr_ty' + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e') @@ -391,6 +399,18 @@ cprTransformDataConWork env con args mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 +isRecNewTyConApp :: AnalEnv -> Type -> Bool +isRecNewTyConApp env ty + --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined + | Just (tc, tc_args) <- splitTyConApp_maybe ty = + if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args + -> isRecNewTyConApp env rhs + | Just dc <- newTyConDataCon_maybe tc + -> ae_rec_dc env dc == DefinitelyRecursive + | otherwise + -> False + | otherwise = False + -- -- * Bindings -- @@ -414,12 +434,18 @@ cprFix orig_env orig_pairs | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, [(Id,CoreExpr)]) + abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ] + -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) loop n env pairs | found_fixpoint = (reset_env', pairs') + | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag @@ -519,8 +545,9 @@ cprAnalBind env id rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - | otherwise = rhs_ty + | rhs_ty == topCprType = topCprType -- cheap case first + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' -- See Note [OPAQUE pragma] @@ -639,7 +666,7 @@ data AnalEnv , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. , ae_rec_dc :: DataCon -> IsRecDataConResult - -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType } instance Outputable AnalEnv where @@ -1042,10 +1069,11 @@ Eliminating the shared 'c' binding in the process. And then What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this - case). This is the solution we adopt. Rationale: the benefit of CPR on - recursive data structures is slight, because it only affects the outer layer - of a potentially massive data structure. + A. Don't give recursive data constructors or casts representing recursive newtype constructors + the CPR property (the list in this case). This is the solution we adopt. + Rationale: the benefit of CPR on recursive data structures is slight, + because it only affects the outer layer of a potentially massive data + structure. B. Don't CPR any *recursive function*. That would be quite conservative, as it would also affect e.g. the factorial function. C. Flat CPR only for recursive functions. This prevents the asymptotic @@ -1055,11 +1083,14 @@ What can we do about it? `c` in the second eqn of `replicateC`). But we'd need to know which paths were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well. +We adopt solution (A). It is ad-hoc, but appears to work reasonably well. Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too: See Note [Detecting recursive data constructors]. We don't have to be perfect and can simply keep on unboxing if unsure. +(A) is implemented in `cprTransformDataConWork` for data types and in the +`Cast` case of `cprAnal` for newtypes. + Note [Detecting recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What qualifies as a "recursive data constructor" as per @@ -1075,12 +1106,15 @@ looks inside the following class of types, represented by `ty` (and responds types of its data constructors and check `tc_args` for recursion. C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to `rhs`, look into the `rhs` type. + D. If `ty = f a`, then look into `f` and `a` + E. If `ty = ty' |> co`, then look into `ty'` A few perhaps surprising points: 1. It deems any function type as non-recursive, because it's unlikely that a recursion through a function type builds up a recursive data structure. - 2. It doesn't look into kinds or coercion types because there's nothing to unbox. + 2. It doesn't look into kinds, literals or coercion types because we are + ultimately looking for value-level recursion. Same for promoted data constructors. 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; we simply look at its definition/DataCons and its field tys and look for ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -63,6 +63,7 @@ import Data.List ( unzip4 ) import GHC.Types.RepType import GHC.Unit.Types +import GHC.Core.TyCo.Rep {- ************************************************************************ @@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult - go_arg_ty fuel visited_tcs ty - --- | pprTrace "arg_ty" (ppr ty) False = undefined + go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $ + case coreFullView ty of + TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args + -- See Note [Detecting recursive data constructors], points (B) and (C) - | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty - = go_arg_ty fuel visited_tcs ty' + ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' -- See Note [Detecting recursive data constructors], point (A) - | Just (tc, tc_args) <- splitTyConApp_maybe ty - = go_tc_app fuel visited_tcs tc tc_args + CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' - | otherwise - = NonRecursiveOrUnsure + AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a + -- See Note [Detecting recursive data constructors], point (D) + + FunTy{} -> NonRecursiveOrUnsure + -- See Note [Detecting recursive data constructors], point (1) + + -- (TyVarTy{} | LitTy{} | CastTy{}) + _ -> NonRecursiveOrUnsure go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult go_tc_app fuel visited_tcs tc tc_args = case tyConDataCons_maybe tc of - --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args -- This is the only place where we look at tc_args, which might have -- See Note [Detecting recursive data constructors], point (C) and (5) ===================================== testsuite/tests/cpranal/sigs/T25944.hs ===================================== @@ -0,0 +1,114 @@ +{-# LANGUAGE UndecidableInstances, LambdaCase #-} + +-- | This file starts with a small reproducer for #25944 that is easy to debug +-- and then continues with a much larger MWE that is faithful to the original +-- issue. +module T25944 (foo, bar, popMinOneT, popMinOne) where + +import Data.Functor.Identity ( Identity(..) ) +import Data.Coerce + +data ListCons a b = Nil | a :- !b +newtype Fix f = Fix (f (Fix f)) -- Rec + +foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a) +foo a b = go a + where + -- The outer loop arranges it so that the base case `go as` of `go2` is + -- bottom on the first iteration of the loop. + go (Fix Nil) = Fix Nil + go (Fix (a :- as)) = Fix (a :- go2 b) + where + go2 (Fix Nil) = go as + go2 (Fix (b :- bs)) = Fix (b :- go2 bs) + +bar :: Int -> (Fix (ListCons Int), Int) +bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property + +-- Now the actual reproducer from #25944: + +newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) } + +cons :: Applicative m => a -> ListT m a -> ListT m a +cons x xs = ListT (pure (x :- xs)) + +nil :: Applicative m => ListT m a +nil = ListT (pure Nil) + +instance Functor m => Functor (ListT m) where + fmap f (ListT m) = ListT (go <$> m) + where + go Nil = Nil + go (a :- m) = f a :- (f <$> m) + +foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b) + -> (a -> b -> c) + -> c + -> ListT m a -> b +foldListT r c n = r h . runListT + where + h Nil = n + h (x :- ListT xs) = c x (r h xs) +{-# INLINE foldListT #-} + +mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b +mapListT = + foldListT + ((coerce :: + ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) -> + ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b)) + (=<<)) +{-# INLINE mapListT #-} + +instance Monad m => Applicative (ListT m) where + pure x = cons x nil + {-# INLINE pure #-} + liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs + {-# INLINE liftA2 #-} + +instance Monad m => Monad (ListT m) where + xs >>= f = mapListT (flip (mapListT cons) . f) nil xs + {-# INLINE (>>=) #-} + +infixr 5 :< +data Node w a b = Leaf a | !w :< b + deriving (Functor) + +bimapNode f g (Leaf x) = Leaf (f x) +bimapNode f g (x :< xs) = x :< g xs + +newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) } + +-- | The 'Heap' type, specialised to the 'Identity' monad. +type Heap w = HeapT w Identity + +instance Functor m => Functor (HeapT w m) where + fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT + +instance Monad m => Applicative (HeapT w m) where + pure = HeapT . pure . Leaf + (<*>) = liftA2 id + +instance Monad m => Monad (HeapT w m) where + HeapT m >>= f = HeapT (m >>= g) + where + g (Leaf x) = runHeapT (f x) + g (w :< xs) = pure (w :< (xs >>= f)) + +popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a)) +popMinOneT = go mempty [] . runHeapT + where + go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a)) + go' a Nothing = pure Nothing + go' a (Just (w, HeapT xs)) = go (a <> w) [] xs + + go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a)) + go w a (ListT xs) = xs >>= \case + Nil -> go' w (undefined) + Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a))) + (u :< x) :- xs -> go w ((u,x) : a) xs +{-# INLINE popMinOneT #-} + +popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a) +popMinOne = runIdentity . popMinOneT +{-# INLINE popMinOne #-} ===================================== testsuite/tests/cpranal/sigs/T25944.stderr ===================================== @@ -0,0 +1,17 @@ + +==================== Cpr signatures ==================== +T25944.$fApplicativeHeapT: +T25944.$fApplicativeListT: +T25944.$fFunctorHeapT: +T25944.$fFunctorListT: +T25944.$fFunctorNode: +T25944.$fMonadHeapT: +T25944.$fMonadListT: +T25944.bar: 1 +T25944.foo: +T25944.popMinOne: 2(1(1,)) +T25944.popMinOneT: +T25944.runHeapT: +T25944.runListT: + + ===================================== testsuite/tests/cpranal/sigs/all.T ===================================== @@ -12,3 +12,4 @@ test('T16040', normal, compile, ['']) test('T19232', normal, compile, ['']) test('T19398', normal, compile, ['']) test('T19822', normal, compile, ['']) +test('T25944', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6425a1f063df92bc9a50870bb7e377a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6425a1f063df92bc9a50870bb7e377a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Add test cases
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: d4765de4 by Andreas Klebinger at 2025-04-26T14:08:14+02:00 Add test cases - - - - - 8 changed files: - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/simplCore/should_compile/SpecTyFam.hs - + testsuite/tests/simplCore/should_compile/SpecTyFam.stderr - + testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +module Main(main) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# NOINLINE foo #-} +foo :: Int -> (String,Int) +-- We want specMe to be specialized, but not inlined +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.stdout ===================================== @@ -0,0 +1 @@ +500500 ===================================== testsuite/tests/perf/should_run/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -423,3 +423,12 @@ test('ByteCodeAsm', ], compile_and_run, ['-package ghc']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +# See also #19747 +test('SpecTyFamRun', [ grep_errmsg(r'foo') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm']) + , collect_stats('bytes allocated', 5)], + multimod_compile_and_run, + ['SpecTyFamRun', '-O2']) ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} + +module SpecTyFam(main, foo) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# OPAQUE foo #-} +foo :: Int -> (String,Int) +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.stderr ===================================== @@ -0,0 +1,78 @@ +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1} + +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1} +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n) +[LclIdX, + Arity=4, + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10 + Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}] +specMe + = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) } + + + +[2 of 2] Compiling SpecTyFam ( SpecTyFam.hs, SpecTyFam.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1} + +Rec { +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0} +$dCTuple2 :: (Show Bool, Num Int) +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt) + +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1} +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #) +[LclId, Arity=2] +$s$wspecMe + = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> + let { + $dNum :: Num Int + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] + $dNum = GHC.Internal.Num.$fNumInt } in + case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) } + +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0} +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int) +[LclId, + Arity=2, + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) + Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}] +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) } +end Rec } + +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0} +foo [InlPrag=OPAQUE] :: Int -> (String, Int) +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}] +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x + +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0} +main :: State# RealWorld -> (# State# RealWorld, () #) +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}] +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +main :: IO () +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ()) + + +------ Local rules for imported ids -------- +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe + + ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImplicitParams #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -543,3 +543,10 @@ test('T25883c', normal, compile_grep_core, ['']) test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="']) test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +test('SpecTyFam', [ grep_errmsg(r'\$wspecMe') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm'])], + multimod_compile, + ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4765de4afa1594688da2cb222a0c8d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4765de4afa1594688da2cb222a0c8d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] use inscope set
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 6e9567ff by Andreas Klebinger at 2025-04-26T13:56:37+02:00 use inscope set - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1282,7 +1282,7 @@ specCase :: SpecEnv specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] -- interestingDict scrut' (idType case_bndr) - interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut' + interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -3067,7 +3067,7 @@ mkCallUDs' env f args -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict (ISE emptyInScopeSet realIdUnfolding) arg + , interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) arg -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e9567ffa7a2a32ee68ce8a50e69866… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e9567ffa7a2a32ee68ce8a50e69866… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] aligned tests
by Serge S. Gulin (＠gulin.serge) 26 Apr '25

26 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: a73fdf14 by Serge S. Gulin at 2025-04-26T15:03:39+03:00 aligned tests - - - - - 1 changed file: - testsuite/tests/interface-stability/base-exports.stdout Changes: ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10491,6 +10491,7 @@ module System.Posix.Internals where c_lseek :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.COff -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.COff c_mkfifo :: GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_open :: CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt + c_openat :: GHC.Internal.Foreign.C.Types.CInt -> CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_pipe :: GHC.Internal.Ptr.Ptr GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_read :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Ptr.Ptr GHC.Internal.Word.Word8 -> GHC.Internal.Foreign.C.Types.CSize -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.CSsize c_s_isblk :: GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Foreign.C.Types.CInt View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a73fdf14f61ccac46b07a457ec263c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a73fdf14f61ccac46b07a457ec263c1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Disable trace for ci checks
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 701de524 by Andreas Klebinger at 2025-04-26T12:47:50+02:00 Disable trace for ci checks - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -68,6 +68,7 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) import GHC.Core.TyCon (tyConClass_maybe) import GHC.Core.DataCon (dataConTyCon) +import Control.Monad {- ************************************************************************ @@ -1704,7 +1705,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - ; pprTrace "spec_call" (vcat + ; when False $ pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci , text "useful: " <+> ppr useful View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/701de52480878d9ceaeb4ee8a692b50… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/701de52480878d9ceaeb4ee8a692b50… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Try simons version of isInterestingDict
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 9ec6b757 by Andreas Klebinger at 2025-04-26T12:37:22+02:00 Try simons version of isInterestingDict - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -14,8 +14,8 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -import GHC.Core.Multiplicity -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) +-- import GHC.Core.Multiplicity +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad @@ -66,6 +66,8 @@ import GHC.Core.Unfold import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1278,7 +1280,8 @@ specCase :: SpecEnv , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] - interestingDict scrut' (idType case_bndr) + -- interestingDict scrut' (idType case_bndr) + interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -3061,9 +3064,10 @@ mkCallUDs' env f args -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon pred af) + mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict arg (scaledThing pred) + , interestingDict (ISE emptyInScopeSet realIdUnfolding) arg + -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg @@ -3169,33 +3173,47 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool +-- interestingDict :: CoreExpr -> Type -> Bool +interestingDict :: InScopeEnv -> CoreExpr -> Bool -- A dictionary argument is interesting if it has *some* structure, -- see Note [Interesting dictionary arguments] -- NB: "dictionary" arguments include constraints of all sorts, -- including equality constraints; hence the Coercion case -- To make this work, we need to ensure that dictionaries have -- unfoldings in them. -interestingDict arg _arg_ty - -- No benefit to specalizing for a ~# b I believe - -- | (isEqPred arg_ty) = False - -- | - -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] - | otherwise = go arg - where - go (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - go (Type _) = False - go (Coercion _) = False - go (App fn (Type _)) = go fn - go (App fn (Coercion _)) = go fn - go (Tick _ a) = go a - go (Cast e _) = go e - go (Lit{}) = True - go (Case{}) = True - go (Let{}) = True - go (App{}) = True - go (Lam{}) = True +interestingDict env (Cast arg _) + = interestingDict env arg +interestingDict env arg + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , (not . isIPLikePred) (exprType arg) + = if isCTupleClass cls + then any (interestingDict env) args + else True + | otherwise + = False + + +-- interestingDict arg _arg_ty +-- -- No benefit to specalizing for a ~# b I believe +-- -- | (isEqPred arg_ty) = False +-- -- | +-- -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] +-- | otherwise = go arg +-- where +-- go (Var v) = hasSomeUnfolding (idUnfolding v) +-- || isDataConWorkId v +-- go (Type _) = False +-- go (Coercion _) = False +-- go (App fn (Type _)) = go fn +-- go (App fn (Coercion _)) = go fn +-- go (Tick _ a) = go a +-- go (Cast e _) = go e +-- go (Lit{}) = True +-- go (Case{}) = True +-- go (Let{}) = True +-- go (App{}) = True +-- go (Lam{}) = True -- go _ = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25944
by Sebastian Graf (＠sgraf812) 26 Apr '25

26 Apr '25

Sebastian Graf pushed new branch wip/T25944 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25944 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] aligned tests
by Serge S. Gulin (＠gulin.serge) 26 Apr '25

26 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: 3ba16e48 by Serge S. Gulin at 2025-04-26T11:20:01+03:00 aligned tests - - - - - 2 changed files: - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - testsuite/tests/ghc-api/fixed-nodes/all.T Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -556,6 +556,8 @@ foreign import javascript interruptible "h$open" c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt foreign import javascript interruptible "h$open" c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt +foreign import javascript interruptible "h$openat" + c_openat :: CInt -> CFilePath -> CInt -> CMode -> IO CInt foreign import javascript interruptible "h$base_read" c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize foreign import javascript interruptible "h$base_read" ===================================== testsuite/tests/ghc-api/fixed-nodes/all.T ===================================== @@ -2,7 +2,6 @@ test('FixedNodes', [extra_run_opts(f'"{config.libdir}"'), extra_files(['T1A.hs', 'T1B.hs', 'T1C.hs']), wasm_broken(25953), - js_broken(25953) ], compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ba16e485d3725684ce76816270a7ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ba16e485d3725684ce76816270a7ab… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Wibble
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 4fc55232 by Andreas Klebinger at 2025-04-26T09:36:42+02:00 Wibble - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -3176,7 +3176,7 @@ interestingDict :: CoreExpr -> Type -> Bool -- including equality constraints; hence the Coercion case -- To make this work, we need to ensure that dictionaries have -- unfoldings in them. -interestingDict arg arg_ty +interestingDict arg _arg_ty -- No benefit to specalizing for a ~# b I believe -- | (isEqPred arg_ty) = False -- | View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4fc55232c1be5a4fc9e14bb88d84bbd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4fc55232c1be5a4fc9e14bb88d84bbd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/enforce-namespaces] WIP: Take subordinate 'type' specifiers into account
by Vladislav Zavialov (＠int-index) 26 Apr '25

26 Apr '25

Vladislav Zavialov pushed to branch wip/int-index/enforce-namespaces at Glasgow Haskell Compiler / GHC Commits: b911a6f1 by Vladislav Zavialov at 2025-04-26T02:18:54+02:00 WIP: Take subordinate 'type' specifiers into account - - - - - 29 changed files: - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst - testsuite/tests/driver/RecompExports/RecompExports1.stderr - testsuite/tests/driver/RecompExports/RecompExports4.stderr - testsuite/tests/module/T21826.stderr - testsuite/tests/module/mod81.stderr - testsuite/tests/module/mod91.stderr - + testsuite/tests/rename/should_compile/T22581c.hs - + testsuite/tests/rename/should_compile/T22581c_helper.hs - + testsuite/tests/rename/should_compile/T22581d.script - + testsuite/tests/rename/should_compile/T22581d.stdout - + testsuite/tests/rename/should_compile/T25991a.hs - + testsuite/tests/rename/should_compile/T25991a_helper.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T22581a.hs - + testsuite/tests/rename/should_fail/T22581a.stderr - + testsuite/tests/rename/should_fail/T22581a_helper.hs - + testsuite/tests/rename/should_fail/T22581b.hs - + testsuite/tests/rename/should_fail/T22581b.stderr - + testsuite/tests/rename/should_fail/T22581b_helper.hs - + testsuite/tests/rename/should_fail/T25991b1.hs - + testsuite/tests/rename/should_fail/T25991b2.hs - + testsuite/tests/rename/should_fail/T25991b_helper.hs - testsuite/tests/rename/should_fail/T9006.stderr - testsuite/tests/rename/should_fail/all.T Changes: ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -1256,7 +1256,7 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) -- 'BadImportW' is only constructed below in 'handle_bad_import', in -- the 'EverythingBut' case, so that's what we pass to -- 'badImportItemErr'. - reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails + (reason : _) <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails pure (TcRnDodgyImports (DodgyImportsHiding reason)) warning_msg (DeprecatedExport n w) = pure $ TcRnPragmaWarning @@ -1268,15 +1268,15 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of Failed err -> do - msg <- lookup_err_msg err - addErr (TcRnImportLookup msg) + msgs <- lookup_err_msgs err + mapM_ addErr [TcRnImportLookup msg | msg <- msgs] return Nothing Succeeded a -> return (Just a) - lookup_err_msg err = case err of + lookup_err_msgs err = case err of BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails - IllegalImport -> pure ImportLookupIllegal - QualImportError rdr -> pure (ImportLookupQualified rdr) + IllegalImport -> pure [ImportLookupIllegal] + QualImportError rdr -> pure [ImportLookupQualified rdr] -- For each import item, we convert its RdrNames to Names, -- and at the same time compute all the GlobalRdrElt corresponding @@ -1362,13 +1362,24 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) -- See Note [Importing DuplicateRecordFields] case lookupChildren subnames rdr_ns of - Failed rdrs -> failLookupWith $ - BadImport (IEThingWith (deprecation, ann) ltc wc rdrs noDocstring) - (IsSubordinate { subordinate_parent = gre}) + Failed errs -> failLookupWith $ BadImport ie subordinate_err -- We are trying to import T( a,b,c,d ), and failed -- to find 'b' and 'd'. So we make up an import item -- to report as failing, namely T( b, d ). - -- c.f. #15412 + -- c.f. #15413 + where + items = map lce_wrapped_name errs + ie = IEThingWith (deprecation, ann) ltc wc items noDocstring + subordinate_err = + assertPpr (length unavailable + length nontype == length items) + (ppr items) $ + IsSubordinateError { subordinate_err_parent = gre + , subordinate_err_unavailable = unavailable + , subordinate_err_nontype = nontype } + unavailable = + [ (occNameFS . rdrNameOcc . ieWrappedName) wname + | LookupChildNotFound (L _ wname) <- errs ] + nontype = [ g | LookupChildNonType _ g <- errs ] Succeeded childnames -> return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' noDocstring @@ -1414,13 +1425,15 @@ data IELookupWarning | DeprecatedExport Name (WarningTxt GhcRn) -- | Is this import/export item a subordinate or not? -data IsSubordinate - = IsSubordinate { subordinate_parent :: GlobalRdrElt } +data IsSubordinateError + = IsSubordinateError { subordinate_err_parent :: !GlobalRdrElt + , subordinate_err_unavailable :: [FastString] + , subordinate_err_nontype :: [GlobalRdrElt] } | IsNotSubordinate data IELookupError = QualImportError RdrName - | BadImport (IE GhcPs) IsSubordinate + | BadImport (IE GhcPs) IsSubordinateError | IllegalImport failLookupWith :: IELookupError -> IELookupM a @@ -1603,9 +1616,14 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] +data LookupChildError + = LookupChildNotFound { lce_wrapped_name :: !(LIEWrappedName GhcPs) } + | LookupChildNonType { lce_wrapped_name :: !(LIEWrappedName GhcPs) + , _lce_nontype_item :: !GlobalRdrElt } + lookupChildren :: [GlobalRdrElt] -> [LIEWrappedName GhcPs] - -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed + -> MaybeErr [LookupChildError] -- The ones for which the lookup failed [LocatedA GlobalRdrElt] -- (lookupChildren all_kids rdr_items) maps each rdr_item to its -- corresponding Name all_kids, if the former exists @@ -1623,21 +1641,25 @@ lookupChildren all_kids rdr_items = Failed fails where mb_xs = map doOne rdr_items - fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] - oks = [ ok | Succeeded ok <- mb_xs ] + fails = [ err | Failed err <- mb_xs ] + oks = [ ok | Succeeded ok <- mb_xs ] oks :: [[LocatedA GlobalRdrElt]] - doOne item@(L l r) - = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [g] - | not $ isRecFldGRE g - -> Succeeded [L l g] - Just gs - | all isRecFldGRE gs - -> Succeeded $ map (L l) gs - _ -> Failed item + doOne :: LIEWrappedName GhcPs -> MaybeErr LookupChildError [LocatedA GlobalRdrElt] + doOne item@(L l r) = + case r of + IEName{} | notNull val_gs -> Succeeded [L l g | g <- val_gs] + IEName{} | notNull typ_gs -> Succeeded [L l g | g <- typ_gs] + IEType{} | notNull typ_gs -> Succeeded [L l g | g <- typ_gs] + IEType{} | (g:_) <- val_gs -> Failed $ LookupChildNonType item g + _ -> Failed $ LookupChildNotFound item + where + fs = (occNameFS . rdrNameOcc . ieWrappedName) r + gs = fromMaybe [] (lookupFsEnv kid_env fs) + (val_gs, typ_gs) = partition (isValNameSpace . greNameSpace) gs -- See Note [Children for duplicate record fields] + kid_env :: FastStringEnv [GlobalRdrElt] kid_env = extendFsEnvList_C (++) emptyFsEnv [(occNameFS (occName x), [x]) | x <- all_kids] @@ -2297,9 +2319,10 @@ DRFPatSynExport for a test of this. -} badImportItemErr - :: ModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinate + :: ModIface -> ImpDeclSpec -> IE GhcPs + -> IsSubordinateError -> [AvailInfo] - -> TcRn ImportLookupReason + -> TcRn [ImportLookupReason] -- non-empty badImportItemErr iface decl_spec ie sub avails = do patsyns_enabled <- xoptM LangExt.PatternSynonyms expl_ns_enabled <- xoptM LangExt.ExplicitNamespaces @@ -2307,20 +2330,24 @@ badImportItemErr iface decl_spec ie sub avails = do hsc_env <- getTopEnv let rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just imp_spec) all_avails - pure (ImportLookupBad (importErrorKind dflags rdr_env expl_ns_enabled) iface decl_spec ie patsyns_enabled) + pure [ImportLookupBad k iface decl_spec ie patsyns_enabled | k <- importErrorKind dflags rdr_env expl_ns_enabled ] where importErrorKind dflags rdr_env expl_ns_enabled | any checkIfTyCon avails = case sub of - IsNotSubordinate -> BadImportAvailTyCon expl_ns_enabled - IsSubordinate {} -> BadImportNotExportedSubordinates unavailableChildren - | any checkIfVarName avails = BadImportAvailVar - | Just con <- find checkIfDataCon avails = BadImportAvailDataCon (availOccName con) - | otherwise = BadImportNotExported suggs + IsNotSubordinate -> [BadImportAvailTyCon expl_ns_enabled] + IsSubordinateError { subordinate_err_parent = gre + , subordinate_err_unavailable = unavailable + , subordinate_err_nontype = nontype } + -> [BadImportNotExportedSubordinates gre unavailable | notNull unavailable] ++ + [BadImportNonTypeSubordinates gre nontype | notNull nontype ] + | any checkIfVarName avails = [BadImportAvailVar] + | Just con <- find checkIfDataCon avails = [BadImportAvailDataCon (availOccName con)] + | otherwise = [BadImportNotExported suggs] where suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr what_look = case sub of - IsNotSubordinate -> WL_TyCon_or_TermVar - IsSubordinate gre -> + IsNotSubordinate -> WL_TyCon_or_TermVar + IsSubordinateError { subordinate_err_parent = gre } -> case greInfo gre of IAmTyCon ClassFlavour -> WL_TyCon_or_TermVar @@ -2359,9 +2386,6 @@ badImportItemErr iface decl_spec ie sub avails = do importedFS = occNameFS $ rdrNameOcc rdr imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } all_avails = mi_exports iface - unavailableChildren = case ie of - IEThingWith _ _ _ ns _ -> map (rdrNameOcc . ieWrappedName . unLoc) ns - _ -> panic "importedChildren failed pattern match: no children" addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () addDupDeclErr gres@(gre :| _) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3305,6 +3305,7 @@ instance Diagnostic TcRnMessage where ++ [ImportSuggestion occ $ CouldAddTypeKeyword mod_name] BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par] BadImportNotExportedSubordinates{} -> noHints + BadImportNonTypeSubordinates{} -> noHints TcRnImportLookup{} -> noHints TcRnUnusedImport{} @@ -5889,15 +5890,30 @@ pprImportLookup = \case where tycon_occ = rdrNameOcc $ ieName ie tycon = parenSymOcc tycon_occ (ppr tycon_occ) - BadImportNotExportedSubordinates ns -> + BadImportNotExportedSubordinates gre unavailable -> withContext - [ text "an item called" <+> quotes sub <+> text "is exported, but it does not export any children" - , text "(constructors, class methods or field names) called" - <+> pprWithCommas (quotes . ppr) ns <> dot + [ what <+> text "called" <+> parent_name <+> text "is exported, but it does not export" + , text "any" <+> what_children <+> text "called" <+> unavailable_names <> dot ] where - sub_occ = rdrNameOcc $ ieName ie - sub = parenSymOcc sub_occ (ppr sub_occ) + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + unavailable_names = pprWithCommas (quotes . ppr) unavailable + (what, what_children) = case greInfo gre of + IAmTyCon ClassFlavour -> (text "a class", text "class methods or associated types") + IAmTyCon _ -> (text "a data type", text "constructors or record fields") + _ -> (text "an item", text "children") + BadImportNonTypeSubordinates gre nontype -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported," + , sep [ text "but its subordinate" <+> "item" <> plural nontype <+> nontype_names + , isOrAre nontype <+> "not in the type namespace." ] ] + where + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + nontype_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nontype + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" BadImportAvailDataCon dataType_occ -> withContext [ text "an item called" <+> quotes datacon ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5846,7 +5846,9 @@ data BadImportKind -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@ | BadImportAvailDataCon OccName -- | The parent does not export the given children. - | BadImportNotExportedSubordinates [OccName] + | BadImportNotExportedSubordinates !GlobalRdrElt [FastString] + -- | Incorrect @type@ keyword when importing subordinates that aren't types. + | BadImportNonTypeSubordinates !GlobalRdrElt [GlobalRdrElt] -- | Incorrect @type@ keyword when importing something which isn't a type. | BadImportAvailVar deriving Generic ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -756,6 +756,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "BadImportNotExported" = 61689 GhcDiagnosticCode "BadImportAvailDataCon" = 35373 GhcDiagnosticCode "BadImportNotExportedSubordinates" = 10237 + GhcDiagnosticCode "BadImportNonTypeSubordinates" = 51433 GhcDiagnosticCode "BadImportAvailTyCon" = 56449 GhcDiagnosticCode "BadImportAvailVar" = 12112 ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -82,6 +82,9 @@ Compiler :ghc-ticket:`20875`, :ghc-ticket:`21172`, :ghc-ticket:`22257`, :ghc-ticket:`25238`, :ghc-ticket:`25834`. +- The compiler no longer accepts invalid ``type`` namespace specifiers in + subordinate import lists (:ghc-ticket:`22581`). + - A new flag, :ghc-flag:`-Wuseless-specialisations`, controls warnings emitted when GHC determines that a SPECIALISE pragma would have no effect. ===================================== docs/users_guide/exts/explicit_namespaces.rst ===================================== @@ -34,6 +34,20 @@ disambiguate this case, thus: :: module N( f, type (++) ) where data family a ++ b = L a | R b +It is also possible to use the ``type`` namespace specifier in subordinate +import and export lists: +:: + + module N (C(type (#))) where + class C a b where + type a # b + (#) :: a -> b -> (a # b) + module M where + import N as T (C(type (#))) + import N as D (C((#))) + -- (T.#) is the associated type + -- (D.#) is the class method + The extension :extension:`ExplicitNamespaces` is implied by :extension:`TypeOperators` and (for some reason) by :extension:`TypeFamilies`. ===================================== testsuite/tests/driver/RecompExports/RecompExports1.stderr ===================================== @@ -3,6 +3,6 @@ RecompExports1_N.hs:3:25: error: [GHC-61689] RecompExports1_N.hs:3:30: error: [GHC-10237] In the import of ‘RecompExports1_M’: - an item called ‘T’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘Foo’. + a data type called ‘T’ is exported, but it does not export + any constructors or record fields called ‘Foo’. ===================================== testsuite/tests/driver/RecompExports/RecompExports4.stderr ===================================== @@ -1,10 +1,10 @@ RecompExports4_N.hs:3:26: error: [GHC-10237] In the import of ‘RecompExports4_M’: - an item called ‘T’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘fld’. + a data type called ‘T’ is exported, but it does not export + any constructors or record fields called ‘fld’. RecompExports4_N.hs:3:39: error: [GHC-10237] In the import of ‘RecompExports4_M’: - an item called ‘C’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘meth’. + a class called ‘C’ is exported, but it does not export + any class methods or associated types called ‘meth’. ===================================== testsuite/tests/module/T21826.stderr ===================================== @@ -1,4 +1,3 @@ - T21826.hs:3:29: error: [GHC-56449] In the import of ‘Data.Type.Equality’: an item called ‘(~)’ is exported, but it is a type. @@ -24,13 +23,13 @@ T21826.hs:5:21: error: [GHC-61689] T21826.hs:6:21: error: [GHC-10237] In the import of ‘Data.Maybe’: - an item called ‘Maybe’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘Some’. + a data type called ‘Maybe’ is exported, but it does not export + any constructors or record fields called ‘Some’. T21826.hs:7:21: error: [GHC-10237] In the import of ‘Data.Maybe’: - an item called ‘Maybe’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘Some’, ‘Mk’. + a data type called ‘Maybe’ is exported, but it does not export + any constructors or record fields called ‘Some’, ‘Mk’. T21826.hs:8:20: error: [GHC-12112] In the import of ‘Data.List’: @@ -55,3 +54,4 @@ T21826.hs:13:21: error: [GHC-56449] Suggested fix: Add the ‘type’ keyword to the import statement: import Data.Maybe ( type Maybe ) + ===================================== testsuite/tests/module/mod81.stderr ===================================== @@ -1,5 +1,5 @@ - mod81.hs:3:16: error: [GHC-10237] In the import of ‘Prelude’: - an item called ‘Either’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘Foo’. + a data type called ‘Either’ is exported, but it does not export + any constructors or record fields called ‘Foo’. + ===================================== testsuite/tests/module/mod91.stderr ===================================== @@ -1,5 +1,5 @@ - mod91.hs:3:16: error: [GHC-10237] In the import of ‘Prelude’: - an item called ‘Eq’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘eq’. + a class called ‘Eq’ is exported, but it does not export + any class methods or associated types called ‘eq’. + ===================================== testsuite/tests/rename/should_compile/T22581c.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module T22581c where + +import T22581c_helper (K(type T), C(type (#), type Tf, type Df)) + +type T' :: K +type T' = T + +type C' a = C a +type (#.) a b = a # b +type Tf' a = Tf a +type Df' a = Df a \ No newline at end of file ===================================== testsuite/tests/rename/should_compile/T22581c_helper.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeData, TypeFamilies #-} + +module T22581c_helper (K(T), C((#), Tf, Df)) where + +type data K = T + +class C a where + type a # b + type Tf a + data Df a \ No newline at end of file ===================================== testsuite/tests/rename/should_compile/T22581d.script ===================================== @@ -0,0 +1,2 @@ +:set -XExplicitNamespaces +import Data.Functor.Product (Product(type Pair)) ===================================== testsuite/tests/rename/should_compile/T22581d.stdout ===================================== @@ -0,0 +1,5 @@ +<interactive>:2:30: error: [GHC-51433] + In the import of ‘Data.Functor.Product’: + a data type called ‘Product’ is exported, + but its subordinate item ‘Pair’ is not in the type namespace. + ===================================== testsuite/tests/rename/should_compile/T25991a.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies, DataKinds #-} + +module T25991a where + +import T25991a_helper as T (C(type (#))) +import T25991a_helper as D (C((#))) + +type S a b = a T.# b +f a b = a D.# b \ No newline at end of file ===================================== testsuite/tests/rename/should_compile/T25991a_helper.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T25991a_helper (C(..)) where + +class C a b where + type a # b + (#) :: a -> b -> () ===================================== testsuite/tests/rename/should_compile/all.T ===================================== @@ -229,4 +229,7 @@ test('T14032d', normal, compile, ['']) test('T24621_normal', normal, compile, ['']) test('T24621_th', req_th, compile, ['']) test('T24732', normal, compile_and_run, ['-package "base(Prelude, Text.Printf as P\')"']) -test('T25182', [extra_files(['ReExportTuples.hs'])], multimod_compile, ['T25182', '-v0']) \ No newline at end of file +test('T25182', [extra_files(['ReExportTuples.hs'])], multimod_compile, ['T25182', '-v0']) +test('T22581c', [extra_files(['T22581c_helper.hs'])], multimod_compile, ['T22581c', '-v0']) +test('T22581d', combined_output, ghci_script, ['T22581d.script']) +test('T25991a', [extra_files(['T25991a_helper.hs'])], multimod_compile, ['T25991a', '-v0']) ===================================== testsuite/tests/rename/should_fail/T22581a.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module T22581a where + +import T22581a_helper (T(type MkT)) + +t :: T +t = MkT ===================================== testsuite/tests/rename/should_fail/T22581a.stderr ===================================== @@ -0,0 +1,5 @@ +T22581a.hs:5:24: error: [GHC-51433] + In the import of ‘T22581a_helper’: + a data type called ‘T’ is exported, + but its subordinate item ‘MkT’ is not in the type namespace. + ===================================== testsuite/tests/rename/should_fail/T22581a_helper.hs ===================================== @@ -0,0 +1,3 @@ +module T22581a_helper (T(MkT)) where + +data T = MkT ===================================== testsuite/tests/rename/should_fail/T22581b.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module T22581b where + +import T22581b_helper (T(type MkT1, MkT2, MkT3, unT)) + ===================================== testsuite/tests/rename/should_fail/T22581b.stderr ===================================== @@ -0,0 +1,10 @@ +T22581b.hs:5:24: error: [GHC-51433] + In the import of ‘T22581b_helper’: + a data type called ‘T’ is exported, + but its subordinate item ‘MkT1’ is not in the type namespace. + +T22581b.hs:5:24: error: [GHC-10237] + In the import of ‘T22581b_helper’: + a data type called ‘T’ is exported, but it does not export + any constructors or record fields called ‘MkT3’, ‘unT’. + ===================================== testsuite/tests/rename/should_fail/T22581b_helper.hs ===================================== @@ -0,0 +1,3 @@ +module T22581b_helper (T(MkT1, MkT2)) where + +data T = MkT1 | MkT2 ===================================== testsuite/tests/rename/should_fail/T25991b1.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds #-} + +module T25991b1 where + +import T25991b_helper (C((#))) + +type S a b = a # b \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T25991b2.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds #-} + +module T25991b2 where + +import T25991b_helper (C(type (#))) + +f a b = a # b \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T25991b_helper.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T25991b_helper (C(..)) where + +class C a b where + type a # b + (#) :: a -> b -> () ===================================== testsuite/tests/rename/should_fail/T9006.stderr ===================================== @@ -1,5 +1,5 @@ - T9006.hs:3:16: error: [GHC-10237] In the import of ‘T9006a’: - an item called ‘T’ is exported, but it does not export any children - (constructors, class methods or field names) called ‘T’. + a data type called ‘T’ is exported, but it does not export + any constructors or record fields called ‘T’. + ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -237,3 +237,7 @@ test('T25877', [extra_files(['T25877_aux.hs'])], multimod_compile_fail, ['T25877 test('T23501_fail', normal, compile_fail, ['']) test('T23501_fail_ext', normal, compile_fail, ['']) test('T25437', normal, compile_fail, ['']) +test('T22581a', [extra_files(['T22581a_helper.hs'])], multimod_compile_fail, ['T22581a', '-v0']) +test('T22581b', [extra_files(['T22581b_helper.hs'])], multimod_compile_fail, ['T22581b', '-v0']) +test('T25991b1', [extra_files(['T25991b_helper.hs'])], multimod_compile_fail, ['T25991b1', '-v0']) +test('T25991b2', [extra_files(['T25991b_helper.hs'])], multimod_compile_fail, ['T25991b2', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b911a6f11acbafe2bd7b0c79cbdb9c5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b911a6f11acbafe2bd7b0c79cbdb9c5… You're receiving this email because of your account on gitlab.haskell.org.

1 0