Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f191714a by Vladislav Zavialov at 2026-09-29T10:42:22-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - 5e12c24d by Alan Zimmerman at 2026-09-29T10:42:23-04:00 EPA: Use EpaLocation in EpVirtualBraces Haddock processing uses EpLayout.EpVirtualBraces to record the current layout column, for allocating haddock comments correctly. For exact printing, we need the line as well as the col, so we know how many lines to skip when the indented code block starts. This commit updates EpLayout.EpVirtualBraces so that it carries an EpaLocation instead of just the Int column, to allow it to be used for both purposes. It is a simple mechanical change, with no other impact, but it allows us to use EpLayout instead of AnnListLayout in AnnList, in the next commit in this series. - - - - - 28 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -945,13 +945,13 @@ body :: { ([TrailingAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,EpLayout) } : '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) } - | vocurly top close { (fst $2, snd $2, EpVirtualBraces (getVOCURLY $1)) } + | vocurly top close { (fst $2, snd $2, EpVirtualBraces (glR $1)) } body2 :: { ([TrailingAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,EpLayout) } : '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) } - | missing_module_keyword top close { ([], snd $2, EpVirtualBraces leftmostColumn) } + | missing_module_keyword top close { ([], snd $2, EpVirtualBraces (EpaDelta noSrcSpan (SameLine 0) [])) } top :: { ([TrailingAnn] @@ -1855,7 +1855,7 @@ decllist_cls : '{' decls_cls '}' { sLL $1 $> ((epTok $1, fst $ unLoc $2, epTok $3) ,snd $ unLoc $2, epExplicitBraces $1 $3) } | vocurly decls_cls close { let { L l (anns, decls) = $2 } - in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (getVOCURLY $1)) } + in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (glR $1)) } -- Class body -- @@ -4305,7 +4305,6 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline,FunLike) getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x -getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l getINTEGERs (L _ (ITinteger (IL src _ _))) = src getCHARs (L _ (ITchar src _)) = src ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Parser.Annotation ( getEpTokenBufSpan, getEpTokenLoc, getEpUniTokenLoc, TokDcolon, TokDarrow, TokRarrow, TokForall, TokStar, - EpLayout(..), + EpLayout(..), getEpaLocationCol, EpaComment(..), EpaCommentTok(..), IsUnicodeSyntax(..), HasE(..), @@ -282,7 +282,9 @@ data EpLayout = -- bar :: a -- @ EpVirtualBraces - !Int -- ^ Layout column (indentation level, begins at 1) + !EpaLocation -- ^ Layout column (indentation level, begins at 1) + -- We keep this as an 'EpaLocation' so exact printing + -- can use it too. | -- | Empty or compiler-generated blocks do not have layout information -- associated with them. @@ -290,6 +292,14 @@ data EpLayout = deriving instance Data EpLayout +-- | Used in 'GHC.Parser.Haddock' to get layout column. It assumes +-- | there is a RealSrcSpan in it, falling back to zero otherwise +getEpaLocationCol :: EpaLocation -> Int +getEpaLocationCol loc + = case loc of + EpaSpan (RealSrcSpan l _) -> srcSpanStartCol l + _ -> leftmostColumn -- should never happen in Parser output + -- --------------------------------------------------------------------- data EpaComment = ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -392,8 +392,9 @@ addHaddockInterleaveItems layout get_doc_item = go with_layout = case layout of EpNoLayout -> id EpExplicitBraces{} -> id - EpVirtualBraces n -> - let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } + EpVirtualBraces n' -> + let n = getEpaLocationCol n' + loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) instance HasHaddock (LocatedA (HsDecl GhcPs)) where @@ -1304,7 +1305,7 @@ mkDocDecl layout (L l_comment hdk_comment) indent_mismatch = case layout of EpNoLayout -> False EpExplicitBraces{} -> False - EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) + EpVirtualBraces n -> getEpaLocationCol n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -34,7 +34,7 @@ { T22919.hs:1:8-13 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { T22919.hs:2:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -34,7 +34,7 @@ "-- ^ Run any arbitrary IO code") { Test20239.hs:7:86 }))])) (EpVirtualBraces - (1)) + (EpaSpan { Test20239.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -40,7 +40,7 @@ "-- Trailing comment, should be in HsModule extension point") { ZeroWidthSemi.hs:6:5 }))])) (EpVirtualBraces - (1)) + (EpaSpan { ZeroWidthSemi.hs:6:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T17544.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -64,7 +64,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:6:3 }))) [] (Nothing) (L @@ -243,7 +243,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:10:3 }))) [] (Nothing) (L @@ -423,7 +423,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:14:3 }))) [] (Nothing) (L @@ -603,7 +603,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { T17544.hs:18:3 }))) [] (Nothing) (L ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T17544_kw.hs:13:1 })) (Nothing) (Nothing)) (Just @@ -412,7 +412,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (5))) + (EpaSpan { T17544_kw.hs:22:5 }))) [] (Nothing) (L ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T24221.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaDelta { <no location info> } (SameLine 0) [])) (Nothing) (Nothing)) (Nothing) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpParsedAst.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -41,7 +41,7 @@ { DumpParsedAstComments.hs:1:1-28 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpParsedAstComments.hs:9:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -45,7 +45,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { DumpSemis.hs:4:1 })) (Nothing) (Nothing)) (Just @@ -1336,7 +1336,7 @@ (EpTok (EpaSpan { <no location info> })) []) (EpVirtualBraces - (3))) + (EpaSpan { DumpSemis.hs:29:3 }))) [] (Nothing) (L ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { KindSigs.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T15323.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20452.hs:5:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -68,7 +68,7 @@ "-- end 2") { T20718.hs:10:1-8 }))])) (EpVirtualBraces - (1)) + (EpaSpan { T20718.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20718b.stderr ===================================== @@ -55,7 +55,7 @@ { T20718b.hs:6:1-21 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20718b.hs:8:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T20846.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -24,7 +24,7 @@ (EpaComments [])) (EpVirtualBraces - (1)) + (EpaSpan { T23315.hsig:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/AnnotationNoListTuplePuns.stdout ===================================== @@ -47,7 +47,7 @@ "-- comment post B") { AnnotationNoListTuplePuns.hs:17:3 }))])) (EpVirtualBraces - (1)) + (EpaSpan { AnnotationNoListTuplePuns.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -244,7 +244,7 @@ { AnnotationNoListTuplePuns.ppr.hs:1:1-32 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -28,7 +28,7 @@ [] [])) (EpVirtualBraces - (1)) + (EpaSpan { T18791.hs:4:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -34,7 +34,7 @@ { Test20297.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test20297.hs:5:1 })) (Nothing) (Nothing)) (Just @@ -476,7 +476,7 @@ { Test20297.ppr.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test20297.ppr.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -34,7 +34,7 @@ { Test24533.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test24533.hs:4:1 })) (Nothing) (Nothing)) (Just @@ -694,7 +694,7 @@ { Test24533.ppr.hs:1:1 }))] [])) (EpVirtualBraces - (1)) + (EpaSpan { Test24533.ppr.hs:3:1 })) (Nothing) (Nothing)) (Just ===================================== testsuite/tests/simplCore/should_compile/T7803.hs ===================================== @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -ddump-simpl #-} + +-- #7803: foo1 should be fully specialised at Double. In the bug report +-- it ended up calling the overloaded exp5Tail (with a dictionary argument), +-- because the specialiser ran before the overloaded call was floated to +-- the top level. So the dumped Core for this module must mention no +-- exp5Tail at all. +module T7803 (foo1) where + +import T7803a + +bar :: Floating a => a -> a -> a +bar z = subtract (evaluate integ z) . evaluate integ + where + integ = indefinite (Piecewise [Poly4 1]) +{-# SPECIALIZE bar :: Double -> Double -> Double #-} + +foo :: Floating a => a -> a -> a +foo x = bar x +{-# SPECIALIZE foo :: Double -> Double -> Double #-} + +foo1 :: Double -> Double -> Double +foo1 x = foo x ===================================== testsuite/tests/simplCore/should_compile/T7803.stderr ===================================== @@ -0,0 +1 @@ +foo1 ===================================== testsuite/tests/simplCore/should_compile/T7803a.hs ===================================== @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T7803a + ( Evaluate (..) + , HasIntegral (..) + , Poly4 (..) + , Domain + , IntOfLogPoly4 (..) + , Piecewise (..) + ) where + +import Data.Kind (Constraint, Type) + +class Evaluate poly where + evaluate :: (Domain' poly a) => poly a -> a -> a + +class Evaluate (IntegralOf poly) => HasIntegral poly where + type IntegralOf poly :: Type -> Type + indefinite :: (Domain' poly a, Domain' (IntegralOf poly) a) + => poly a -> IntegralOf poly a + +type family Domain (f :: Type -> Type) a :: Constraint + +class Domain f a => Domain' f a +instance Domain f a => Domain' f a + +newtype Poly4 a = Poly4 { poly4_a :: a } + +type instance Domain Poly4 a = Fractional a + +data IntOfLogPoly4 a = IntOfLogPoly4 { ilp4_k :: !a, ilp4_u :: !a } + +type instance Domain IntOfLogPoly4 a = Floating a + +instance Evaluate IntOfLogPoly4 where + evaluate (IntOfLogPoly4 k _) x = k + x * exp5Tail (- log x) + {-# INLINE evaluate #-} + +{-# RULES "exp5Tail/Double" exp5Tail = exp5TailDouble #-} +{-# NOINLINE exp5Tail #-} + +exp5Tail :: (Floating a) => a -> a +exp5Tail x = x / 120 + +exp5TailDouble :: Double -> Double +exp5TailDouble x = x / 120 + +instance HasIntegral Poly4 where + type IntegralOf Poly4 = IntOfLogPoly4 + indefinite = \ (Poly4 a) -> IntOfLogPoly4 0 a + {-# INLINE indefinite #-} + +newtype Piecewise poly a = Piecewise { unPiecewise :: [poly a] } + +type instance Domain (Piecewise poly) a = (Domain poly a, Num a) + +instance (Evaluate poly) => Evaluate (Piecewise poly) where + evaluate = \ (Piecewise pp) x -> + case pp of + p : _ -> evaluate p x + [] -> error "evaluate: empty Piecewise" + {-# INLINE evaluate #-} + +instance (HasIntegral poly) => HasIntegral (Piecewise poly) where + type IntegralOf (Piecewise poly) = Piecewise (IntegralOf poly) + indefinite (Piecewise m) = Piecewise $ map indefinite m + {-# INLINE indefinite #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -148,6 +148,13 @@ test('T7785', [ only_ways(['optasm']), grep_errmsg(r'SPEC') ], compile, ['-ddump-cse']) +# T7803: we expect NO calls to the overloaded 'exp5Tail' in T7803.hs +# In the bug report #7803, the unspecialised call was signalled by 'exp5Tail' +# in foo1's Core, so we grep for that; also for 'foo1', lest we dump nothing +# One module, T7803.hs, has OPTIONS_GHC -ddump-simpl +test('T7803', [ grep_errmsg(r'exp5Tail|foo1') ], + multimod_compile, ['T7803', '-O2 -v0 -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) + test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b27f65f41a0224783fdd91951f83d0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b27f65f41a0224783fdd91951f83d0... 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