[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: EPA: Move the 'where' annotation for PatSynBind

7 Jul 2026


      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.

    

Marge Bot (＠marge-bot)

tags

participants (1)