diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T21577.hs | 98 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
3 files changed, 101 insertions, 1 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index b318c75f59..f1cc2bd4ea 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1794,7 +1794,8 @@ pushCoercionIntoLambda in_scope x e co -- so we extend the substitution with x |-> (x' |> sym co1). in Just (x', substExpr subst e `mkCast` co2) | otherwise - = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + -- See #21555 / #21577 for a case where this trace fired but the cause was benign + = -- pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) Nothing pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion diff --git a/testsuite/tests/simplCore/should_compile/T21577.hs b/testsuite/tests/simplCore/should_compile/T21577.hs new file mode 100644 index 0000000000..a0c94fc79a --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21577.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} + + +module T21577 (bar) where + +import GHC.Generics +import GHC.Exts (Constraint) +import Data.Coerce (coerce) +import Data.Kind (Type) + +data A = A () + deriving Generic + +data B = B A + +-- This avoids callstack stuff in core dumps +undefined' :: a +undefined' = undefined' + +ba :: Optic A_Setter B B A A +ba = castOptic $ lens (\(B a) -> a) (\_ -> B) + +aunit :: Optic A_Setter A A () () +aunit = case foo (Market id Right) of + Market _ _ -> Optic undefined' + where + foo :: Profunctor p => p i () () -> p i A A + foo = dimap from to . dimap coerce coerce + +bar :: Monad m => m [B] +bar = do + _ <- pure [] + pure $ over (mapped %% ba) inner [] + where + -- NB: inlining inner hides the bug + inner = over aunit id + +class Profunctor p where + dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d + +class Mapping p where + -- Uncommenting this line avoids the OOM + --wibble :: p i a b -> () + roam :: ((a -> b) -> s -> t) -> p i a b -> p i s t + +first' :: Mapping p => p i a b -> p i (a, c) (b, c) +first' = roam (\f (a, x) -> (f a, x)) + +----- +-- Some minimised code originating from optics-core and indexed-profunctors follows + +newtype Optic (k :: OpticKind) s t a b + = Optic (forall p i. (Profunctor p, Constraints k p) => p i a b -> p i s t) + +castOptic :: forall s t a b. Optic A_Lens s t a b -> Optic A_Setter s t a b +castOptic (Optic o) = Optic o + +infixl 9 %% +(%%) :: forall s t u v a b. Optic A_Setter s t u v -> Optic A_Setter u v a b -> Optic A_Setter s t a b +Optic o %% Optic o' = Optic (o . o') + +over + :: forall s t a b. Optic A_Setter s t a b -> (a -> b) -> s -> t +over (Optic o) f = runFunArrow $ o (FunArrow f) + +lens :: (s -> a) -> (s -> b -> t) -> Optic A_Lens s t a b +lens get set = Optic $ dimap (\s -> (get s, s)) (\(b, s) -> set s b) . first' + +mapped :: Functor f => Optic A_Setter (f a) (f b) a b +mapped = Optic (roam fmap) + +type OpticKind = Type + +data A_Lens :: OpticKind +data A_Setter :: OpticKind + +-- Changing this into a synonym hides the OOM bug +type family Constraints (k :: OpticKind) (p :: Type -> Type -> Type -> Type) :: Constraint where + Constraints A_Lens p = Mapping p + Constraints A_Setter p = Mapping p + +data Market a b i s t = Market (b -> t) (s -> Either t a) + +instance Profunctor (Market a b) where + dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) + +-- NB: changing this to data hides the OOM bug +newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b } + +instance Profunctor FunArrow where + dimap f g (FunArrow k) = FunArrow (g . k . f) + +instance Mapping FunArrow where + --wibble _ = () + roam f (FunArrow k) = FunArrow $ f k diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 0c52c80480..b92f24cd5b 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -293,6 +293,7 @@ test('T16978a', normal, compile, ['-O']) test('T16978b', normal, compile, ['-O']) test('T16979a', normal, compile, ['-O']) test('T16979b', normal, compile, ['-O']) +test('T21577', normal, compile, ['-O']) test('T17140', [extra_files(['T17140a.hs'])], makefile_test, |