Magnus pushed to branch wip/mangoiv/9.12.5-rc4 at Glasgow Haskell Compiler / GHC Commits: feec438d by Zubin Duggal at 2026-09-03T16:10:51+02:00 Add tests for absent fillers at dictionary types T27627 a unary class whose superclass is a non-unary class T27627a ...whose superclass is a Constraint-kinded type family T27627b ...whose superclass is a quantified constraint T27627c a unary class applied to itself, (UC (UC (TC a))) T27627e a (forall b. P b) dictionary that loops (cherry picked from commit 5f474953d1880232b5e6c5741f08746e28cd25ab) - - - - - 23 changed files: - + testsuite/tests/core-to-stg/T27627/Callee.hs - + testsuite/tests/core-to-stg/T27627/Caller.hs - + testsuite/tests/core-to-stg/T27627/Main.hs - + testsuite/tests/core-to-stg/T27627/T27627.stdout - + testsuite/tests/core-to-stg/T27627/all.T - + testsuite/tests/core-to-stg/T27627a/Callee.hs - + testsuite/tests/core-to-stg/T27627a/Caller.hs - + testsuite/tests/core-to-stg/T27627a/Main.hs - + testsuite/tests/core-to-stg/T27627a/T27627a.stdout - + testsuite/tests/core-to-stg/T27627a/all.T - + testsuite/tests/core-to-stg/T27627b/Callee.hs - + testsuite/tests/core-to-stg/T27627b/Caller.hs - + testsuite/tests/core-to-stg/T27627b/Main.hs - + testsuite/tests/core-to-stg/T27627b/T27627b.stdout - + testsuite/tests/core-to-stg/T27627b/all.T - + testsuite/tests/core-to-stg/T27627c/Callee.hs - + testsuite/tests/core-to-stg/T27627c/Caller.hs - + testsuite/tests/core-to-stg/T27627c/Main.hs - + testsuite/tests/core-to-stg/T27627c/T27627c.stdout - + testsuite/tests/core-to-stg/T27627c/all.T - + testsuite/tests/core-to-stg/T27627e.hs - + testsuite/tests/core-to-stg/T27627e.stdout - testsuite/tests/core-to-stg/all.T Changes: ===================================== testsuite/tests/core-to-stg/T27627/Callee.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +-- Not unary, so ($p1TC d) is not trivial and CorePrep binds it separately. +class Eq a => TC a where + tcDummy :: a -> Int + +-- Unary: at runtime a (UC a) dictionary is the (TC a) dictionary it wraps. +class TC a => UC a where {} + +instance TC Int where tcDummy _ = 0 +instance UC Int + +data Dict c where + Dict :: c => Dict c + +-- Ignores its argument, so the Dict below is absent-demanded. +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +-- Body compiles to discard (Dict @(Eq a) ($p1TC ($p1UC d))) +-- The Dict is a value, so CorePrep floats the selection out and evaluates it +-- at the head of b. -fno-worker-wrapper keeps the dictionary parameter. +{-# NOINLINE b #-} +b :: forall a. UC a => a -> Int +b _ = discard (Dict :: Dict (Eq a)) ===================================== testsuite/tests/core-to-stg/T27627/Caller.hs ===================================== @@ -0,0 +1,9 @@ +module Caller where + +import Callee + +-- b ignores its dictionary, so a's is absent. Worker/wrapper must not make a +-- filler: b speculates a superclass selection out of it. +{-# NOINLINE a #-} +a :: UC t => t -> Int +a x = b x + 1 ===================================== testsuite/tests/core-to-stg/T27627/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where +import Caller +main :: IO () +main = print (a (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27627/T27627.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627', + [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27627a/Callee.hs ===================================== @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +import Data.Kind (Constraint) + +-- Reduces to (TC a), so at runtime a (UC a) dictionary is a (TC a) dictionary. +type family F a :: Constraint +type instance F a = TC a + +-- Not unary. +class Eq a => TC a where + tcDummy :: a -> Int + +-- Unary: one superclass field, the unreduced (F a). +-- See (NBD1) in Note [NON-BOTTOM-DICTS invariant]. +class F a => UC a + +instance TC Int where tcDummy _ = 0 +instance UC Int + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +{-# NOINLINE b #-} +b :: forall a. UC a => a -> Int +b _ = discard (Dict :: Dict (Eq a)) ===================================== testsuite/tests/core-to-stg/T27627a/Caller.hs ===================================== @@ -0,0 +1,9 @@ +module Caller where + +import Callee + +-- b ignores its dictionary, so a's is absent. Worker/wrapper must not make a +-- filler: b speculates a superclass selection out of it. +{-# NOINLINE a #-} +a :: UC t => t -> Int +a x = b x + 1 ===================================== testsuite/tests/core-to-stg/T27627a/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main where + +import Caller + +main :: IO () +main = print (a (3 :: Int)) ===================================== testsuite/tests/core-to-stg/T27627a/T27627a.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627a/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627a', + [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27627b/Callee.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables, QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances, FlexibleInstances, RankNTypes #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +-- Not unary, so a (TC a) dictionary terminates. +class Eq a => TC a where + tcDummy :: a -> Int + +-- Unary: one superclass field, (forall a. TC (f a)). +-- See (NBD1) in Note [NON-BOTTOM-DICTS invariant]. +class (forall a. TC (f a)) => UQ f + +newtype Id a = MkId a +instance Eq (Id a) where _ == _ = True +instance TC (Id a) where tcDummy _ = 0 +instance UQ Id + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +{-# NOINLINE b #-} +b :: forall f. UQ f => f Int -> Int +b _ = discard (Dict :: Dict (Eq (f Int))) ===================================== testsuite/tests/core-to-stg/T27627b/Caller.hs ===================================== @@ -0,0 +1,9 @@ +module Caller where + +import Callee + +-- b ignores its dictionary, so a's is absent. Worker/wrapper must not make a +-- filler: b speculates a superclass selection out of it. +{-# NOINLINE a #-} +a :: UQ f => f Int -> Int +a x = b x + 1 ===================================== testsuite/tests/core-to-stg/T27627b/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main where + +import Callee +import Caller + +main :: IO () +main = print (a (MkId 3 :: Id Int)) ===================================== testsuite/tests/core-to-stg/T27627b/T27627b.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627b/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627b', + [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27627c/Callee.hs ===================================== @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +import Data.Kind (Constraint) + +class Eq a => TC a where + tcDummy :: a -> Int + +class c => UC (c :: Constraint) + +instance TC Int where tcDummy _ = 0 +instance c => UC c + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +{-# NOINLINE b #-} +b :: forall a. UC (UC (TC a)) => a -> Int +b _ = discard (Dict :: Dict (Eq a)) ===================================== testsuite/tests/core-to-stg/T27627c/Caller.hs ===================================== @@ -0,0 +1,7 @@ +module Caller where + +import Callee + +{-# NOINLINE a #-} +a :: UC (UC (TC t)) => t -> Int +a x = b x + 1 ===================================== testsuite/tests/core-to-stg/T27627c/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where +import Caller +main :: IO () +main = print (a (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27627c/T27627c.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627c/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627c', + [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27627e.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE QuantifiedConstraints, UndecidableInstances, FlexibleInstances, + UndecidableSuperClasses, FlexibleContexts, RankNTypes #-} +-- T27627b's class shape, with a method and a recursive instance. +module Main where + +class Eq a => TC a +class (forall a. TC (f a)) => UQ f where { uqDummy :: f Int -> Int } + +newtype Id a = MkId a +instance Eq (Id a) where _ == _ = True +instance UQ f => TC (f a) +instance UQ Id where uqDummy _ = 7 + +{-# NOINLINE dead #-} +dead :: TC a => a -> Int -> Int +dead _ n = n + 1 + +{-# NOINLINE useUQ #-} +useUQ :: UQ f => f Int -> Int -> Int +useUQ x n = dead x n + +main :: IO () +main = print (useUQ (MkId 3 :: Id Int) 41) ===================================== testsuite/tests/core-to-stg/T27627e.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -8,3 +8,4 @@ test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp test('T24334', normal, compile_and_run, ['-O']) test('T24463', normal, compile, ['-O']) test('T25924a', [ignore_stderr], compile_and_run, ['-O']) +test('T27627e', normal, compile_and_run, ['-O0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/feec438d628b953c892fdbcc35bc2c52... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/feec438d628b953c892fdbcc35bc2c52... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help