Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 383ddcd4 by Alan Zimmerman at 2026-07-06T07:08:16-04:00 EPA: Move the 'where' annotation for PatSynBind This allows us to move it out of the MatchGroup exact print annotation too - - - - - fa74c7d3 by fendor at 2026-07-07T11:26:11-04:00 Add 'backendInfoTableMapValidity' backend predicate Check whether the backend supports the `-finfo-table-map` flag and ignore it otherwise. Improve by-design documentation of `backendCodeOutput`. `Backend` is **abstract by design**. Make this clearer in `backendCodeOutput` which is incorrectly being used as a proxy for `Backend`. Instead, define the desired property predicates in GHC.Driver.Backend In the process, make `backendCodeOutput` total. - - - - - 90829fe4 by fendor at 2026-07-07T11:26:11-04:00 Add failing test for `-finfo-table-map` and bytecode backend If you compile a module using the bytecode backend, with -finfo-table-map, then the info table map doesn't get populated for the module. This is because the -finfo-table-map code path is implemented mostly in the StgToCmm phase which isn't run when creating bytecode. Ticket #27039 - - - - - d26601c5 by mangoiv at 2026-07-07T11:26:12-04:00 ci: don't fail nightly if there have been no changes that night Fixes #27127 - - - - - 30 changed files: - .gitlab-ci.yml - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/deSugar/should_fail/all.T - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/bytecodeIPE.hs - + testsuite/tests/ghci/scripts/bytecodeIPE.script - + testsuite/tests/ghci/scripts/bytecodeIPE.stdout - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1307,7 +1307,8 @@ ghcup-metadata-nightly-push: - git config user.name "GHC GitLab CI" - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN@gitlab.haskell.org/ghc/ghcup-metadata.git - git add . - - git commit -m "Update metadata" + # a metadata nightly run may result in no changes. We reflect that in the commit message. + - git diff --cached --quiet && git commit --allow-empty -m "Updated metadata - no changes" || git commit -m "Update metadata" - git push gitlab_origin HEAD:updates rules: # Only run the update on scheduled nightly pipelines, ie once a day ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -352,7 +352,10 @@ def main() -> None: with open(args.metadata, 'r') as file: ghcup_metadata = yaml.safe_load(file) if args.version in ghcup_metadata['ghcupDownloads']['GHC']: - raise RuntimeError("Refusing to override existing version in metadata") + # if there are days without a commit, then the nightly metadata + # is up to date by default, no need to fail, no need to upload anything + print("Refusing to override existing version in metadata, exiting") + sys.exit() setNightlyTags(ghcup_metadata) ghcup_metadata['ghcupDownloads']['GHC'][args.version] = new_yaml print(yaml.dump(ghcup_metadata)) ===================================== compiler/GHC/Driver/Backend.hs ===================================== @@ -99,6 +99,7 @@ module GHC.Driver.Backend , backendPostHscPipeline , backendNormalSuccessorPhase , backendName + , backendInfoTableMapValidity , backendValidityOfCImport , backendValidityOfCExport @@ -117,7 +118,6 @@ import GHC.Driver.Phases import GHC.Utils.Error -import GHC.Utils.Panic import GHC.Driver.Pipeline.Monad import GHC.Platform @@ -368,7 +368,8 @@ data PrimitiveImplementation -- We expect one function per back end—or more precisely, one function -- for each back end that writes code to a file. (The interpreter -- does not write to files; its output lives only in memory.) - +-- +-- See Note [Backend Defunctionalization] data DefunctionalizedCodeOutput = NcgCodeOutput | ViaCCodeOutput @@ -680,6 +681,18 @@ backendSupportsBreakpoints = \case Named Bytecode -> True Named NoBackend -> False +-- | Return is 'IsValid' if the backend supports @-finfo-table-map@. +-- If 'backendInfoTableMapValidity' returns 'NotValid', then the driver ignores +-- the flag @-finfo-table-map@, since the backend doesn't support generating +-- the info table map. +backendInfoTableMapValidity :: Backend -> Validity' String +backendInfoTableMapValidity (Named NCG) = IsValid +backendInfoTableMapValidity (Named LLVM) = NotValid "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)" +backendInfoTableMapValidity (Named ViaC) = IsValid +backendInfoTableMapValidity (Named JavaScript) = NotValid "-finfo-table-map is incompatible with the javascript backend" +backendInfoTableMapValidity (Named Bytecode) = IsValid -- We are not generating any objects, so @-finfo-table-map@ is not expected to work. Avoid warning for GHCi. +backendInfoTableMapValidity (Named NoBackend) = IsValid -- We are not generating code, so we ignore it any way + -- | If this flag is set, then the driver forces the -- optimization level to 0, issuing a warning message if -- the command line requested a higher optimization level. @@ -768,20 +781,33 @@ backendCDefs (Named NoBackend) = NoCDefs -- > -> Set UnitId -- ^ dependencies -- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` -- > -> IO a -backendCodeOutput :: Backend -> DefunctionalizedCodeOutput -backendCodeOutput (Named NCG) = NcgCodeOutput -backendCodeOutput (Named LLVM) = LlvmCodeOutput -backendCodeOutput (Named ViaC) = ViaCCodeOutput -backendCodeOutput (Named JavaScript) = JSCodeOutput -backendCodeOutput (Named Bytecode) = panic "backendCodeOutput: bytecodeBackend" -backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" +-- +-- See Note [Backend Defunctionalization] +-- +-- === __WARNING__ +-- +-- Do NOT use 'backendCodeOutput' (or other functions in this module) as a +-- proxy for the 'Backend', which is __abstract by design__. +-- +-- If you need to determine some property of the backend, do NOT match on +-- 'DefunctionalizedCodeOutput'; Instead, write a new property predicate in +-- this module. This makes it easier to add new backends because essentially +-- all backend properties depended upon throughout the compiler are all found +-- here. +backendCodeOutput :: Backend -> Maybe DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = Just NcgCodeOutput +backendCodeOutput (Named LLVM) = Just LlvmCodeOutput +backendCodeOutput (Named ViaC) = Just ViaCCodeOutput +backendCodeOutput (Named JavaScript) = Just JSCodeOutput +backendCodeOutput (Named Bytecode) = Nothing +backendCodeOutput (Named NoBackend) = Nothing backendUseJSLinker :: Backend -> Bool backendUseJSLinker (Named NCG) = False backendUseJSLinker (Named LLVM) = False backendUseJSLinker (Named ViaC) = False backendUseJSLinker (Named JavaScript) = True -backendUseJSLinker (Named Bytecode) = False +backendUseJSLinker (Named Bytecode) = False backendUseJSLinker (Named NoBackend) = False -- | This (defunctionalized) function tells the compiler ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -4,7 +4,6 @@ \section{Code output phase} -} - module GHC.Driver.CodeOutput ( codeOutput , outputForeignStubs @@ -50,7 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.Utils.Exception ( bracket ) import GHC.Utils.Ppr (Mode(..)) -import GHC.Utils.Panic.Plain ( pgmError ) +import GHC.Utils.Panic.Plain ( panic, pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) @@ -124,11 +123,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g ; let dus1 = newTagDUniqSupply CodeGenTag dus0 ; (stubs, a) <- case backendCodeOutput (backend dflags) of - NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1 - final_stream - ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps - LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream - JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream + Just NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1 + final_stream + Just ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps + Just LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream + Just JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } ===================================== compiler/GHC/Driver/Main/Compile.hs ===================================== @@ -670,7 +670,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do -- next withTiming after this will be "Assembler" (hard code only). withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ case backendCodeOutput (backend dflags) of - JSCodeOutput -> + Just JSCodeOutput -> do let js_config = initStgToJSConfig dflags @@ -696,7 +696,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos) - _ -> + Just _ -> do cmms <- {-# SCC "StgToCmm" #-} doCodeGen hsc_env this_mod denv tycons @@ -724,6 +724,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1 return ( output_filename, stub_c_exists, foreign_fps , Just stg_cg_infos, Just cmm_cg_infos) + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" -- The part of CgGuts that we need for HscInteractive ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -741,7 +741,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do let home_unit = hsc_home_unit hsc_env case backendCodeOutput (backend dflags) of - JSCodeOutput -> do + Just JSCodeOutput -> do empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode src)) @@ -750,7 +750,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do _ <- runPipeline (hsc_hooks hsc_env) pipeline pure () - _ -> do + Just _ -> do empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode src)) @@ -758,6 +758,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub _ <- runPipeline (hsc_hooks hsc_env) pipeline pure () + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -276,7 +276,7 @@ import GHC.Data.FastString import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable -import GHC.Utils.Error (emptyDiagOpts, logInfo) +import GHC.Utils.Error (emptyDiagOpts, logInfo, Validity'(..)) import GHC.Settings import GHC.CmmToAsm.CFG.Weight import GHC.Core.Opt.CallerCC @@ -3855,8 +3855,8 @@ makeDynFlagsConsistent dflags && os == OSMinGW32 && arch == ArchAArch64 = case backendCodeOutput (backend dflags) of - LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" - NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" + Just LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" + Just NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" _ -> (dflags, mempty, mempty) -- When we do ghci, force using dyn ways if the target RTS linker @@ -3902,9 +3902,8 @@ makeDynFlagsConsistent dflags in dflags_c | gopt Opt_InfoTableMap dflags - , LlvmCodeOutput <- backendCodeOutput (backend dflags) - = loop (gopt_unset dflags Opt_InfoTableMap) - "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)" + , NotValid msg <- backendInfoTableMapValidity (backend dflags) + = loop (gopt_unset dflags Opt_InfoTableMap) msg | otherwise = (dflags, mempty, mempty) where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -147,11 +147,12 @@ data AnnPSB = AnnPSB { ap_pattern :: EpToken "pattern", ap_larrow :: Maybe (EpUniToken "<-" "←"), - ap_equal :: Maybe (EpToken "=") + ap_equal :: Maybe (EpToken "="), + ap_where :: Maybe (EpToken "where") } deriving Data instance NoAnn AnnPSB where - noAnn = AnnPSB noAnn noAnn noAnn + noAnn = AnnPSB noAnn noAnn noAnn noAnn -- --------------------------------------------------------------------- ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -68,7 +68,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationGrhsAnn `extQ` annotationAnnList `extQ` annotationEpAnnListWhere - `extQ` annotationAnnListWhere + `extQ` annotationAnnListUnit `extQ` annotationAnnListCommas `extQ` annotationAnnListEpaLocation `extQ` annotationNoEpAnns @@ -377,9 +377,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") - annotationAnnListWhere :: AnnList (EpToken "where") -> SDoc - annotationAnnListWhere anns = case ba of - BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList (EpToken \"where\")") + annotationAnnListUnit :: AnnList () -> SDoc + annotationAnnListUnit anns = case ba of + BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList ()") NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) $$ vcat (gmapQ showAstData' anns) ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1654,7 +1654,7 @@ type instance XMG GhcRn b = (Origin, -- See Note [Generated code and pat MatchGroupAnn) type instance XMG GhcTc b = MatchGroupTc -type MatchGroupAnn = AnnList (EpToken "where") +type MatchGroupAnn = AnnList () data MatchGroupTc = MatchGroupTc ===================================== compiler/GHC/Parser.y ===================================== @@ -1760,19 +1760,19 @@ pattern_synonym_decl :: { LHsDecl GhcPs } {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 ImplicitBidirectional - (AnnPSB (epTok $1) Nothing (Just (epTok $3)))) } + (AnnPSB (epTok $1) Nothing (Just (epTok $3)) Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) } + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls {% do { let (name, args) = $2 ; mg <- mkPatSynMatchGroup name $5 ; amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 (ExplicitBidirectional mg) - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing (Just (sndOf3 $ unLoc $5)) )) }} pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs) } @@ -1789,11 +1789,13 @@ cvars1 :: { [RecordPatSynField GhcPs] } | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2) ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} -where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) } +where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) () [])) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) () [])) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -3535,7 +3537,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))) } +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) noAnn []))) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -723,9 +723,9 @@ tyConToDataCon (L loc tc) occ = rdrNameOcc tc mkPatSynMatchGroup :: LocatedN RdrName - -> LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) + -> LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, ann)) = +mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, _, ann)) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr (locA loc)) ; return $ mkMatchGroup FromSource ann (L ld matches) } @@ -1772,11 +1772,11 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -> PV (LocatedA b) -- | Disambiguate "case ... of ..." mkHsCasePV :: SrcSpan -> LHsExpr GhcPs - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnHsCase -> PV (LocatedA b) -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" mkHsLamPV :: SrcSpan -> HsLamVariant - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnLam -> PV (LocatedA b) -- | Function argument representation ===================================== testsuite/tests/deSugar/should_fail/all.T ===================================== @@ -6,7 +6,9 @@ test('DsStrictFail', exit_code(1), compile_and_run, ['']) test( 'T21701', - [omit_ways(llvm_ways)], # -finfo-table-map does not work with -fllvm (#26435) + [ omit_ways(llvm_ways), # -finfo-table-map does not work with -fllvm (#26435) + when(js_arch(), skip) # javascript doesn't support -finfo-table-map yet and yields a warning we don't want to handle here + ], compile, ['-Wall -finfo-table-map'] ) ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -86,7 +86,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -385,6 +385,14 @@ test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script']) test('ListTuplePunsPprNoAbbrevTuple', [limit_stdout_lines(14)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script']) test('T24459', normal, ghci_script, ['T24459.script']) test('T24632', normal, ghci_script, ['T24632.script']) +# bytecode backend doesn't support '-finfo-table-map' (#27039) +test('bytecodeIPE', + [ extra_hc_opts('-finfo-table-map') + , extra_files(['bytecodeIPE.hs']) + , req_rts_linker + , when(arch('wasm32') or arch('javascript'), skip) + ], + ghci_script, ['bytecodeIPE.script']) # Test package renaming in GHCi session test('GhciPackageRename', ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.hs ===================================== @@ -0,0 +1,12 @@ +module BytecodeIPE where + +import Data.Maybe (isJust) +import GHC.InfoProv (whereFrom) + +marker :: String +marker = id "bytecode-stub-init" +{-# NOINLINE marker #-} + +-- `whereFrom` only succeeds if the module's IPE initializer ran. +probe :: IO Bool +probe = isJust <$> whereFrom marker ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.script ===================================== @@ -0,0 +1,2 @@ +:load bytecodeIPE.hs +probe ===================================== testsuite/tests/ghci/scripts/bytecodeIPE.stdout ===================================== @@ -0,0 +1 @@ +False ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2232,7 +2232,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -94,7 +94,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -218,7 +218,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -371,7 +371,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -34,7 +34,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -271,7 +271,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -578,7 +578,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -840,7 +840,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1056,7 +1056,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1162,7 +1162,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1270,7 +1270,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1786,7 +1786,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1914,7 +1914,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2040,7 +2040,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2153,7 +2153,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2281,7 +2281,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2402,7 +2402,7 @@ (EpaSpan { DumpSemis.hs:38:7 })) ,(EpTok (EpaSpan { DumpSemis.hs:38:8 }))] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -1018,7 +1018,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1753,7 +1753,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -108,7 +108,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -207,7 +207,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -330,7 +330,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -525,7 +525,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -646,7 +646,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -763,7 +763,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -555,7 +555,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1165,7 +1165,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2326,7 +2326,7 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (PSB{ psb_ext = AnnPSB ap al ae + exact (PSB{ psb_ext = AnnPSB ap al ae aw , psb_id = psyn, psb_args = details , psb_def = pat , psb_dir = dir }) = do @@ -2349,23 +2349,24 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where ac' <- markEpToken ac return (psyn', RecCon (ao',ac') vs') - (al', ae', pat', dir') <- + (al', ae', pat', dir', aw') <- case dir of Unidirectional -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat - return (al', ae, pat', dir) + return (al', ae, pat', dir, aw) ImplicitBidirectional -> do ae' <- mapM markEpToken ae pat' <- markAnnotated pat - return (al, ae', pat', dir) + return (al, ae', pat', dir, aw) ExplicitBidirectional mg -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat + aw' <- mapM markEpToken aw mg' <- markAnnotated mg - return (al', ae, pat', ExplicitBidirectional mg') + return (al', ae, pat', ExplicitBidirectional mg', aw') - return (PSB{ psb_ext = AnnPSB ap' al' ae' + return (PSB{ psb_ext = AnnPSB ap' al' ae' aw' , psb_id = psyn', psb_args = details' , psb_def = pat' , psb_dir = dir' }) @@ -3249,11 +3250,10 @@ instance (Typeable body, = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches) exact (MG (origin,an) (L l matches)) = do - an0 <- markLensFun an lal_rest markEpToken -- 'where', only for PatSynBind - (an1,matches') <- markAnnListA' an0 $ \a -> do + (an0,matches') <- markAnnListA' an $ \a -> do m' <- markAnnotated matches return (a,m') - return (MG (origin, an1) (L l matches')) + return (MG (origin, an0) (L l matches')) -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f701cd6d2d73348cb0afb1364891cec... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f701cd6d2d73348cb0afb1364891cec... You're receiving this email because of your account on gitlab.haskell.org.