Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

30 changed files:

Changes:

  • .gitlab-ci.yml
    ... ... @@ -1307,7 +1307,8 @@ ghcup-metadata-nightly-push:
    1307 1307 
         - git config user.name "GHC GitLab CI"
    1308 1308 
         - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN@gitlab.haskell.org/ghc/ghcup-metadata.git
    1309 1309 
         - git add .
    1310 
    -    - git commit -m "Update metadata"
    1310 
    +    # a metadata nightly run may result in no changes. We reflect that in the commit message.
    1311 
    +    - git diff --cached --quiet && git commit --allow-empty -m "Updated metadata - no changes" || git commit -m "Update metadata"
    1311 1312 
         - git push gitlab_origin HEAD:updates
    1312 1313 
       rules:
    1313 1314 
         # 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:
    352 352 
             with open(args.metadata, 'r') as file:
    353 353 
                 ghcup_metadata = yaml.safe_load(file)
    354 354 
                 if  args.version in ghcup_metadata['ghcupDownloads']['GHC']:
    355 
    -                raise RuntimeError("Refusing to override existing version in metadata")
    355 
    +                # if there are days without a commit, then the nightly metadata
    356 
    +                # is up to date by default, no need to fail, no need to upload anything
    357 
    +                print("Refusing to override existing version in metadata, exiting")
    358 
    +                sys.exit()
    356 359 
                 setNightlyTags(ghcup_metadata)
    357 360 
                 ghcup_metadata['ghcupDownloads']['GHC'][args.version] = new_yaml
    358 361 
                 print(yaml.dump(ghcup_metadata))

  • compiler/GHC/Driver/Backend.hs
    ... ... @@ -99,6 +99,7 @@ module GHC.Driver.Backend
    99 99 
        , backendPostHscPipeline
    100 100 
        , backendNormalSuccessorPhase
    101 101 
        , backendName
    102 
    +   , backendInfoTableMapValidity
    102 103 
        , backendValidityOfCImport
    103 104 
        , backendValidityOfCExport
    104 105
    ... ... @@ -117,7 +118,6 @@ import GHC.Driver.Phases
    117 118
    118 119
    119 120 
     import GHC.Utils.Error
    120 
    -import GHC.Utils.Panic
    121 121
    122 122 
     import GHC.Driver.Pipeline.Monad
    123 123 
     import GHC.Platform
    ... ... @@ -368,7 +368,8 @@ data PrimitiveImplementation
    368 368 
     -- We expect one function per back end—or more precisely, one function
    369 369 
     -- for each back end that writes code to a file.  (The interpreter
    370 370 
     -- does not write to files; its output lives only in memory.)
    371 
    -
    371 
    +--
    372 
    +-- See Note [Backend Defunctionalization]
    372 373 
     data DefunctionalizedCodeOutput
    373 374 
       = NcgCodeOutput
    374 375 
       | ViaCCodeOutput
    ... ... @@ -680,6 +681,18 @@ backendSupportsBreakpoints = \case
    680 681 
       Named Bytecode -> True
    681 682 
       Named NoBackend   -> False
    682 683
    684 
    +-- | Return is 'IsValid' if the backend supports @-finfo-table-map@.
    685 
    +-- If 'backendInfoTableMapValidity' returns 'NotValid', then the driver ignores
    686 
    +-- the flag @-finfo-table-map@, since the backend doesn't support generating
    687 
    +-- the info table map.
    688 
    +backendInfoTableMapValidity :: Backend -> Validity' String
    689 
    +backendInfoTableMapValidity (Named NCG)        = IsValid
    690 
    +backendInfoTableMapValidity (Named LLVM)       = NotValid "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
    691 
    +backendInfoTableMapValidity (Named ViaC)       = IsValid
    692 
    +backendInfoTableMapValidity (Named JavaScript) = NotValid "-finfo-table-map is incompatible with the javascript backend"
    693 
    +backendInfoTableMapValidity (Named Bytecode)   = IsValid -- We are not generating any objects, so @-finfo-table-map@ is not expected to work. Avoid warning for GHCi.
    694 
    +backendInfoTableMapValidity (Named NoBackend)  = IsValid -- We are not generating code, so we ignore it any way
    695 
    +
    683 696 
     -- | If this flag is set, then the driver forces the
    684 697 
     -- optimization level to 0, issuing a warning message if
    685 698 
     -- the command line requested a higher optimization level.
    ... ... @@ -768,20 +781,33 @@ backendCDefs (Named NoBackend) = NoCDefs
    768 781 
     -- > -> Set UnitId -- ^ dependencies
    769 782 
     -- > -> Stream IO RawCmmGroup a -- results from `StgToCmm`
    770 783 
     -- > -> IO a
    771 
    -backendCodeOutput :: Backend -> DefunctionalizedCodeOutput
    772 
    -backendCodeOutput (Named NCG)         = NcgCodeOutput
    773 
    -backendCodeOutput (Named LLVM)        = LlvmCodeOutput
    774 
    -backendCodeOutput (Named ViaC)        = ViaCCodeOutput
    775 
    -backendCodeOutput (Named JavaScript)  = JSCodeOutput
    776 
    -backendCodeOutput (Named Bytecode) = panic "backendCodeOutput: bytecodeBackend"
    777 
    -backendCodeOutput (Named NoBackend)   = panic "backendCodeOutput: noBackend"
    784 
    +--
    785 
    +-- See Note [Backend Defunctionalization]
    786 
    +--
    787 
    +-- === __WARNING__
    788 
    +--
    789 
    +-- Do NOT use 'backendCodeOutput' (or other functions in this module) as a
    790 
    +-- proxy for the 'Backend', which is __abstract by design__.
    791 
    +--
    792 
    +-- If you need to determine some property of the backend, do NOT match on
    793 
    +-- 'DefunctionalizedCodeOutput'; Instead, write a new property predicate in
    794 
    +-- this module. This makes it easier to add new backends because essentially
    795 
    +-- all backend properties depended upon throughout the compiler are all found
    796 
    +-- here.
    797 
    +backendCodeOutput :: Backend -> Maybe DefunctionalizedCodeOutput
    798 
    +backendCodeOutput (Named NCG)         = Just NcgCodeOutput
    799 
    +backendCodeOutput (Named LLVM)        = Just LlvmCodeOutput
    800 
    +backendCodeOutput (Named ViaC)        = Just ViaCCodeOutput
    801 
    +backendCodeOutput (Named JavaScript)  = Just JSCodeOutput
    802 
    +backendCodeOutput (Named Bytecode)    = Nothing
    803 
    +backendCodeOutput (Named NoBackend)   = Nothing
    778 804
    779 805 
     backendUseJSLinker :: Backend -> Bool
    780 806 
     backendUseJSLinker (Named NCG)         = False
    781 807 
     backendUseJSLinker (Named LLVM)        = False
    782 808 
     backendUseJSLinker (Named ViaC)        = False
    783 809 
     backendUseJSLinker (Named JavaScript)  = True
    784 
    -backendUseJSLinker (Named Bytecode) = False
    810 
    +backendUseJSLinker (Named Bytecode)    = False
    785 811 
     backendUseJSLinker (Named NoBackend)   = False
    786 812
    787 813 
     -- | This (defunctionalized) function tells the compiler

  • compiler/GHC/Driver/CodeOutput.hs
    ... ... @@ -4,7 +4,6 @@
    4 4 
     \section{Code output phase}
    5 5 
     -}
    6 6
    7 
    -
    8 7 
     module GHC.Driver.CodeOutput
    9 8 
        ( codeOutput
    10 9 
        , outputForeignStubs
    ... ... @@ -50,7 +49,7 @@ import GHC.Utils.Outputable
    50 49 
     import GHC.Utils.Logger
    51 50 
     import GHC.Utils.Exception ( bracket )
    52 51 
     import GHC.Utils.Ppr (Mode(..))
    53 
    -import GHC.Utils.Panic.Plain ( pgmError )
    52 
    +import GHC.Utils.Panic.Plain ( panic, pgmError )
    54 53
    55 54 
     import GHC.Unit
    56 55 
     import GHC.Unit.Finder      ( mkStubPaths )
    ... ... @@ -124,11 +123,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
    124 123
    125 124 
             ; let dus1 = newTagDUniqSupply CodeGenTag dus0
    126 125 
             ; (stubs, a) <- case backendCodeOutput (backend dflags) of
    127 
    -                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm dus1
    128 
    -                                             final_stream
    129 
    -                 ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps
    130 
    -                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream
    131 
    -                 JSCodeOutput   -> outputJS logger llvm_config dflags filenm final_stream
    126 
    +             Just NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm dus1
    127 
    +                                              final_stream
    128 
    +             Just ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps
    129 
    +             Just LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream
    130 
    +             Just JSCodeOutput   -> outputJS logger llvm_config dflags filenm final_stream
    131 
    +             Nothing             -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
    132 132 
             ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
    133 133 
             ; return (filenm, stubs_exist, foreign_fps, a)
    134 134 
             }

  • compiler/GHC/Driver/Main/Compile.hs
    ... ... @@ -670,7 +670,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
    670 670 
             -- next withTiming after this will be "Assembler" (hard code only).
    671 671 
             withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())
    672 672 
              $ case backendCodeOutput (backend dflags) of
    673 
    -            JSCodeOutput ->
    673 
    +            Just JSCodeOutput ->
    674 674 
                   do
    675 675 
                   let js_config = initStgToJSConfig dflags
    676 676
    ... ... @@ -696,7 +696,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
    696 696 
                   stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename
    697 697 
                   return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos)
    698 698
    699 
    -            _          ->
    699 
    +            Just _          ->
    700 700 
                   do
    701 701 
                   cmms <- {-# SCC "StgToCmm" #-}
    702 702 
                     doCodeGen hsc_env this_mod denv tycons
    ... ... @@ -724,6 +724,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do
    724 724 
                         foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1
    725 725 
                   return  ( output_filename, stub_c_exists, foreign_fps
    726 726 
                           , Just stg_cg_infos, Just cmm_cg_infos)
    727 
    +            Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
    727 728
    728 729
    729 730 
     -- 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
    741 741 
       let home_unit = hsc_home_unit hsc_env
    742 742
    743 743 
       case backendCodeOutput (backend dflags) of
    744 
    -    JSCodeOutput -> do
    744 
    +    Just JSCodeOutput -> do
    745 745 
           empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
    746 746 
           let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
    747 747 
           writeFile empty_stub (showSDoc dflags (pprCode src))
    ... ... @@ -750,7 +750,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
    750 750 
           _ <- runPipeline (hsc_hooks hsc_env) pipeline
    751 751 
           pure ()
    752 752
    753 
    -    _ -> do
    753 
    +    Just _ -> do
    754 754 
           empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
    755 755 
           let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
    756 756 
           writeFile empty_stub (showSDoc dflags (pprCode src))
    ... ... @@ -758,6 +758,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
    758 758 
               pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
    759 759 
           _ <- runPipeline (hsc_hooks hsc_env) pipeline
    760 760 
           pure ()
    761 
    +    Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output"
    761 762
    762 763
    763 764

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -276,7 +276,7 @@ import GHC.Data.FastString
    276 276 
     import GHC.Utils.TmpFs
    277 277 
     import GHC.Utils.Fingerprint
    278 278 
     import GHC.Utils.Outputable
    279 
    -import GHC.Utils.Error (emptyDiagOpts, logInfo)
    279 
    +import GHC.Utils.Error (emptyDiagOpts, logInfo, Validity'(..))
    280 280 
     import GHC.Settings
    281 281 
     import GHC.CmmToAsm.CFG.Weight
    282 282 
     import GHC.Core.Opt.CallerCC
    ... ... @@ -3855,8 +3855,8 @@ makeDynFlagsConsistent dflags
    3855 3855 
        && os == OSMinGW32
    3856 3856 
        && arch == ArchAArch64
    3857 3857 
         = case backendCodeOutput (backend dflags) of
    3858 
    -        LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"
    3859 
    -        NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"
    3858 
    +        Just LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"
    3859 
    +        Just NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"
    3860 3860 
             _ -> (dflags, mempty, mempty)
    3861 3861
    3862 3862 
       -- When we do ghci, force using dyn ways if the target RTS linker
    ... ... @@ -3902,9 +3902,8 @@ makeDynFlagsConsistent dflags
    3902 3902 
             in dflags_c
    3903 3903
    3904 3904 
      | gopt Opt_InfoTableMap dflags
    3905 
    - , LlvmCodeOutput <- backendCodeOutput (backend dflags)
    3906 
    -    = loop (gopt_unset dflags Opt_InfoTableMap)
    3907 
    -           "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
    3905 
    + , NotValid msg <- backendInfoTableMapValidity (backend dflags)
    3906 
    +    = loop (gopt_unset dflags Opt_InfoTableMap) msg
    3908 3907
    3909 3908 
      | otherwise = (dflags, mempty, mempty)
    3910 3909 
         where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")

  • compiler/GHC/Hs/Binds.hs
    ... ... @@ -147,11 +147,12 @@ data AnnPSB
    147 147 
       = AnnPSB {
    148 148 
           ap_pattern :: EpToken "pattern",
    149 149 
           ap_larrow  :: Maybe (EpUniToken "<-" "←"),
    150 
    -      ap_equal   :: Maybe (EpToken "=")
    150 
    +      ap_equal   :: Maybe (EpToken "="),
    151 
    +      ap_where   :: Maybe (EpToken "where")
    151 152 
         } deriving Data
    152 153
    153 154 
     instance NoAnn AnnPSB where
    154 
    -  noAnn = AnnPSB noAnn noAnn noAnn
    155 
    +  noAnn = AnnPSB noAnn noAnn noAnn noAnn
    155 156
    156 157 
     -- ---------------------------------------------------------------------
    157 158

  • compiler/GHC/Hs/Dump.hs
    ... ... @@ -68,7 +68,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
    68 68 
                   `extQ` annotationGrhsAnn
    69 69 
                   `extQ` annotationAnnList
    70 70 
                   `extQ` annotationEpAnnListWhere
    71 
    -              `extQ` annotationAnnListWhere
    71 
    +              `extQ` annotationAnnListUnit
    72 72 
                   `extQ` annotationAnnListCommas
    73 73 
                   `extQ` annotationAnnListEpaLocation
    74 74 
                   `extQ` annotationNoEpAnns
    ... ... @@ -377,9 +377,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
    377 377 
                 annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc
    378 378 
                 annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])")
    379 379
    380 
    -            annotationAnnListWhere :: AnnList (EpToken "where") -> SDoc
    381 
    -            annotationAnnListWhere anns = case ba of
    382 
    -             BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList (EpToken \"where\")")
    380 
    +            annotationAnnListUnit :: AnnList () -> SDoc
    381 
    +            annotationAnnListUnit anns = case ba of
    382 
    +             BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList ()")
    383 383 
                  NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
    384 384 
                                                    $$ vcat (gmapQ showAstData' anns)
    385 385

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -1654,7 +1654,7 @@ type instance XMG GhcRn b = (Origin, -- See Note [Generated code and pat
    1654 1654 
                                          MatchGroupAnn)
    1655 1655 
     type instance XMG         GhcTc b = MatchGroupTc
    1656 1656
    1657 
    -type MatchGroupAnn = AnnList (EpToken "where")
    1657 
    +type MatchGroupAnn = AnnList ()
    1658 1658
    1659 1659 
     data MatchGroupTc
    1660 1660 
       = MatchGroupTc

  • compiler/GHC/Parser.y
    ... ... @@ -1760,19 +1760,19 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
    1760 1760 
              {%      let (name, args) = $2 in
    1761 1761 
                      amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4
    1762 1762 
                                                         ImplicitBidirectional
    1763 
    -                      (AnnPSB (epTok $1) Nothing (Just (epTok $3)))) }
    1763 
    +                      (AnnPSB (epTok $1) Nothing (Just (epTok $3)) Nothing)) }
    1764 1764
    1765 1765 
             | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat
    1766 1766 
              {%    let (name, args) = $2 in
    1767 1767 
                    amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional
    1768 
    -                       (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) }
    1768 
    +                       (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing Nothing)) }
    1769 1769
    1770 1770 
             | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls
    1771 1771 
                 {% do { let (name, args) = $2
    1772 1772 
                       ; mg <- mkPatSynMatchGroup name $5
    1773 1773 
                       ; amsA' (sLL $1 $> . ValD noExtField $
    1774 1774 
                                mkPatSynBind name args $4 (ExplicitBidirectional mg)
    1775 
    -                            (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing))
    1775 
    +                            (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing (Just (sndOf3 $ unLoc $5)) ))
    1776 1776 
                        }}
    1777 1777
    1778 1778 
     pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs) }
    ... ... @@ -1789,11 +1789,13 @@ cvars1 :: { [RecordPatSynField GhcPs] }
    1789 1789 
            | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)
    1790 1790 
                                                 ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}
    1791 1791
    1792 
    -where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) }
    1792 
    +where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) }
    1793 1793 
             : 'where' '{' decls '}'       {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3,
    1794 
    -                                                AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) (epTok $1) [])) }
    1794 
    +                                                epTok $1,
    1795 
    +                                                AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) () [])) }
    1795 1796 
             | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3,
    1796 
    -                                                AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) (epTok $1) [])) }
    1797 
    +                                                epTok $1,
    1798 
    +                                                AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) () [])) }
    1797 1799
    1798 1800 
     pattern_synonym_sig :: { LSig GhcPs }
    1799 1801 
             : 'pattern' con_list '::' sigtype
    ... ... @@ -3535,7 +3537,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
    3535 3537 
     -----------------------------------------------------------------------------
    3536 3538 
     -- Case alternatives
    3537 3539
    3538 
    -altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))) }
    3540 
    +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())) }
    3539 3541 
             : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsA'
    3540 3542 
                                                (sLL $1 $> (reverse (snd $ unLoc $2),
    3541 3543 
                                                (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)
    723 723 
         occ = rdrNameOcc tc
    724 724
    725 725 
     mkPatSynMatchGroup :: LocatedN RdrName
    726 
    -                   -> LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where"))
    726 
    +                   -> LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ())
    727 727 
                        -> P (MatchGroup GhcPs (LHsExpr GhcPs))
    728 
    -mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, ann)) =
    728 
    +mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, _, ann)) =
    729 729 
         do { matches <- mapM fromDecl (fromOL decls)
    730 730 
            ; when (null matches) (wrongNumberErr (locA loc))
    731 731 
            ; return $ mkMatchGroup FromSource ann (L ld matches) }
    ... ... @@ -1772,11 +1772,11 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
    1772 1772 
                   -> PV (LocatedA b)
    1773 1773 
       -- | Disambiguate "case ... of ..."
    1774 1774 
       mkHsCasePV :: SrcSpan -> LHsExpr GhcPs
    1775 
    -             -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))
    1775 
    +             -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())
    1776 1776 
                  -> EpAnnHsCase -> PV (LocatedA b)
    1777 1777 
       -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases"
    1778 1778 
       mkHsLamPV :: SrcSpan -> HsLamVariant
    1779 
    -            -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))
    1779 
    +            -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())
    1780 1780 
                 -> EpAnnLam
    1781 1781 
                 -> PV (LocatedA b)
    1782 1782 
       -- | Function argument representation

  • testsuite/tests/deSugar/should_fail/all.T
    ... ... @@ -6,7 +6,9 @@
    6 6 
     test('DsStrictFail', exit_code(1), compile_and_run, [''])
    7 7 
     test(
    8 8 
         'T21701',
    9 
    -    [omit_ways(llvm_ways)], # -finfo-table-map does not work with -fllvm (#26435)
    9 
    +    [ omit_ways(llvm_ways), # -finfo-table-map does not work with -fllvm (#26435)
    10 
    +      when(js_arch(), skip) # javascript doesn't support -finfo-table-map yet and yields a warning we don't want to handle here
    11 
    +    ],
    10 12 
         compile,
    11 13 
         ['-Wall -finfo-table-map']
    12 14 
     )

  • testsuite/tests/ghc-api/exactprint/T22919.stderr
    ... ... @@ -74,7 +74,7 @@
    74 74 
              (Nothing)
    75 75 
              (ListNone)
    76 76 
              []
    77 
    -         (NoEpTok)
    77 
    +         (())
    78 78 
              []))
    79 79 
            (L
    80 80 
             (EpAnn

  • testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
    ... ... @@ -86,7 +86,7 @@
    86 86 
              (Nothing)
    87 87 
              (ListNone)
    88 88 
              []
    89 
    -         (NoEpTok)
    89 
    +         (())
    90 90 
              []))
    91 91 
            (L
    92 92 
             (EpAnn

  • testsuite/tests/ghci/scripts/all.T
    ... ... @@ -385,6 +385,14 @@ test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script'])
    385 385 
     test('ListTuplePunsPprNoAbbrevTuple', [limit_stdout_lines(14)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script'])
    386 386 
     test('T24459', normal, ghci_script, ['T24459.script'])
    387 387 
     test('T24632', normal, ghci_script, ['T24632.script'])
    388 
    +# bytecode backend doesn't support '-finfo-table-map' (#27039)
    389 
    +test('bytecodeIPE',
    390 
    +     [ extra_hc_opts('-finfo-table-map')
    391 
    +     , extra_files(['bytecodeIPE.hs'])
    392 
    +     , req_rts_linker
    393 
    +     , when(arch('wasm32') or arch('javascript'), skip)
    394 
    +     ],
    395 
    +     ghci_script, ['bytecodeIPE.script'])
    388 396
    389 397 
     # Test package renaming in GHCi session
    390 398 
     test('GhciPackageRename',

  • testsuite/tests/ghci/scripts/bytecodeIPE.hs
    1 
    +module BytecodeIPE where
    2 
    +
    3 
    +import Data.Maybe (isJust)
    4 
    +import GHC.InfoProv (whereFrom)
    5 
    +
    6 
    +marker :: String
    7 
    +marker = id "bytecode-stub-init"
    8 
    +{-# NOINLINE marker #-}
    9 
    +
    10 
    +-- `whereFrom` only succeeds if the module's IPE initializer ran.
    11 
    +probe :: IO Bool
    12 
    +probe = isJust <$> whereFrom marker

  • testsuite/tests/ghci/scripts/bytecodeIPE.script
    1 
    +:load bytecodeIPE.hs
    2 
    +probe

  • testsuite/tests/ghci/scripts/bytecodeIPE.stdout
    1 
    +False

  • testsuite/tests/module/mod185.stderr
    ... ... @@ -99,7 +99,7 @@
    99 99 
              (Nothing)
    100 100 
              (ListNone)
    101 101 
              []
    102 
    -         (NoEpTok)
    102 
    +         (())
    103 103 
              []))
    104 104 
            (L
    105 105 
             (EpAnn

  • testsuite/tests/parser/should_compile/DumpParsedAst.stderr
    ... ... @@ -2232,7 +2232,7 @@
    2232 2232 
              (Nothing)
    2233 2233 
              (ListNone)
    2234 2234 
              []
    2235 
    -         (NoEpTok)
    2235 
    +         (())
    2236 2236 
              []))
    2237 2237 
            (L
    2238 2238 
             (EpAnn

  • testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
    ... ... @@ -94,7 +94,7 @@
    94 94 
              (Nothing)
    95 95 
              (ListNone)
    96 96 
              []
    97 
    -         (NoEpTok)
    97 
    +         (())
    98 98 
              []))
    99 99 
            (L
    100 100 
             (EpAnn
    ... ... @@ -218,7 +218,7 @@
    218 218 
              (Nothing)
    219 219 
              (ListNone)
    220 220 
              []
    221 
    -         (NoEpTok)
    221 
    +         (())
    222 222 
              []))
    223 223 
            (L
    224 224 
             (EpAnn
    ... ... @@ -371,7 +371,7 @@
    371 371 
              (Nothing)
    372 372 
              (ListNone)
    373 373 
              []
    374 
    -         (NoEpTok)
    374 
    +         (())
    375 375 
              []))
    376 376 
            (L
    377 377 
             (EpAnn

  • testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
    ... ... @@ -34,7 +34,7 @@
    34 34 
                  (Nothing)
    35 35 
                  (ListNone)
    36 36 
                  []
    37 
    -             (NoEpTok)
    37 
    +             (())
    38 38 
                  []))
    39 39 
                (L
    40 40 
                 (EpAnn

  • testsuite/tests/parser/should_compile/DumpSemis.stderr
    ... ... @@ -271,7 +271,7 @@
    271 271 
              (Nothing)
    272 272 
              (ListNone)
    273 273 
              []
    274 
    -         (NoEpTok)
    274 
    +         (())
    275 275 
              []))
    276 276 
            (L
    277 277 
             (EpAnn
    ... ... @@ -578,7 +578,7 @@
    578 578 
              (Nothing)
    579 579 
              (ListNone)
    580 580 
              []
    581 
    -         (NoEpTok)
    581 
    +         (())
    582 582 
              []))
    583 583 
            (L
    584 584 
             (EpAnn
    ... ... @@ -840,7 +840,7 @@
    840 840 
              (Nothing)
    841 841 
              (ListNone)
    842 842 
              []
    843 
    -         (NoEpTok)
    843 
    +         (())
    844 844 
              []))
    845 845 
            (L
    846 846 
             (EpAnn
    ... ... @@ -1056,7 +1056,7 @@
    1056 1056 
              (Nothing)
    1057 1057 
              (ListNone)
    1058 1058 
              []
    1059 
    -         (NoEpTok)
    1059 
    +         (())
    1060 1060 
              []))
    1061 1061 
            (L
    1062 1062 
             (EpAnn
    ... ... @@ -1162,7 +1162,7 @@
    1162 1162 
              (Nothing)
    1163 1163 
              (ListNone)
    1164 1164 
              []
    1165 
    -         (NoEpTok)
    1165 
    +         (())
    1166 1166 
              []))
    1167 1167 
            (L
    1168 1168 
             (EpAnn
    ... ... @@ -1270,7 +1270,7 @@
    1270 1270 
              (Nothing)
    1271 1271 
              (ListNone)
    1272 1272 
              []
    1273 
    -         (NoEpTok)
    1273 
    +         (())
    1274 1274 
              []))
    1275 1275 
            (L
    1276 1276 
             (EpAnn
    ... ... @@ -1786,7 +1786,7 @@
    1786 1786 
              (Nothing)
    1787 1787 
              (ListNone)
    1788 1788 
              []
    1789 
    -         (NoEpTok)
    1789 
    +         (())
    1790 1790 
              []))
    1791 1791 
            (L
    1792 1792 
             (EpAnn
    ... ... @@ -1914,7 +1914,7 @@
    1914 1914 
              (Nothing)
    1915 1915 
              (ListNone)
    1916 1916 
              []
    1917 
    -         (NoEpTok)
    1917 
    +         (())
    1918 1918 
              []))
    1919 1919 
            (L
    1920 1920 
             (EpAnn
    ... ... @@ -2040,7 +2040,7 @@
    2040 2040 
                              (Nothing)
    2041 2041 
                              (ListNone)
    2042 2042 
                              []
    2043 
    -                         (NoEpTok)
    2043 
    +                         (())
    2044 2044 
                              []))
    2045 2045 
                            (L
    2046 2046 
                             (EpAnn
    ... ... @@ -2153,7 +2153,7 @@
    2153 2153 
                              (Nothing)
    2154 2154 
                              (ListNone)
    2155 2155 
                              []
    2156 
    -                         (NoEpTok)
    2156 
    +                         (())
    2157 2157 
                              []))
    2158 2158 
                            (L
    2159 2159 
                             (EpAnn
    ... ... @@ -2281,7 +2281,7 @@
    2281 2281 
              (Nothing)
    2282 2282 
              (ListNone)
    2283 2283 
              []
    2284 
    -         (NoEpTok)
    2284 
    +         (())
    2285 2285 
              []))
    2286 2286 
            (L
    2287 2287 
             (EpAnn
    ... ... @@ -2402,7 +2402,7 @@
    2402 2402 
                           (EpaSpan { DumpSemis.hs:38:7 }))
    2403 2403 
                         ,(EpTok
    2404 2404 
                           (EpaSpan { DumpSemis.hs:38:8 }))]
    2405 
    -                    (NoEpTok)
    2405 
    +                    (())
    2406 2406 
                         []))
    2407 2407 
                       (L
    2408 2408 
                        (EpAnn

  • testsuite/tests/parser/should_compile/KindSigs.stderr
    ... ... @@ -1018,7 +1018,7 @@
    1018 1018 
              (Nothing)
    1019 1019 
              (ListNone)
    1020 1020 
              []
    1021 
    -         (NoEpTok)
    1021 
    +         (())
    1022 1022 
              []))
    1023 1023 
            (L
    1024 1024 
             (EpAnn
    ... ... @@ -1753,7 +1753,7 @@
    1753 1753 
              (Nothing)
    1754 1754 
              (ListNone)
    1755 1755 
              []
    1756 
    -         (NoEpTok)
    1756 
    +         (())
    1757 1757 
              []))
    1758 1758 
            (L
    1759 1759 
             (EpAnn

  • testsuite/tests/parser/should_compile/T20718.stderr
    ... ... @@ -108,7 +108,7 @@
    108 108 
              (Nothing)
    109 109 
              (ListNone)
    110 110 
              []
    111 
    -         (NoEpTok)
    111 
    +         (())
    112 112 
              []))
    113 113 
            (L
    114 114 
             (EpAnn

  • testsuite/tests/parser/should_compile/T20846.stderr
    ... ... @@ -99,7 +99,7 @@
    99 99 
              (Nothing)
    100 100 
              (ListNone)
    101 101 
              []
    102 
    -         (NoEpTok)
    102 
    +         (())
    103 103 
              []))
    104 104 
            (L
    105 105 
             (EpAnn

  • testsuite/tests/printer/Test20297.stdout
    ... ... @@ -74,7 +74,7 @@
    74 74 
              (Nothing)
    75 75 
              (ListNone)
    76 76 
              []
    77 
    -         (NoEpTok)
    77 
    +         (())
    78 78 
              []))
    79 79 
            (L
    80 80 
             (EpAnn
    ... ... @@ -207,7 +207,7 @@
    207 207 
              (Nothing)
    208 208 
              (ListNone)
    209 209 
              []
    210 
    -         (NoEpTok)
    210 
    +         (())
    211 211 
              []))
    212 212 
            (L
    213 213 
             (EpAnn
    ... ... @@ -330,7 +330,7 @@
    330 330 
                         (Nothing)
    331 331 
                         (ListNone)
    332 332 
                         []
    333 
    -                    (NoEpTok)
    333 
    +                    (())
    334 334 
                         []))
    335 335 
                       (L
    336 336 
                        (EpAnn
    ... ... @@ -525,7 +525,7 @@
    525 525 
              (Nothing)
    526 526 
              (ListNone)
    527 527 
              []
    528 
    -         (NoEpTok)
    528 
    +         (())
    529 529 
              []))
    530 530 
            (L
    531 531 
             (EpAnn
    ... ... @@ -646,7 +646,7 @@
    646 646 
              (Nothing)
    647 647 
              (ListNone)
    648 648 
              []
    649 
    -         (NoEpTok)
    649 
    +         (())
    650 650 
              []))
    651 651 
            (L
    652 652 
             (EpAnn
    ... ... @@ -763,7 +763,7 @@
    763 763 
                         (Nothing)
    764 764 
                         (ListNone)
    765 765 
                         []
    766 
    -                    (NoEpTok)
    766 
    +                    (())
    767 767 
                         []))
    768 768 
                       (L
    769 769 
                        (EpAnn

  • testsuite/tests/printer/Test24533.stdout
    ... ... @@ -555,7 +555,7 @@
    555 555 
                  (Nothing)
    556 556 
                  (ListNone)
    557 557 
                  []
    558 
    -             (NoEpTok)
    558 
    +             (())
    559 559 
                  []))
    560 560 
                (L
    561 561 
                 (EpAnn
    ... ... @@ -1165,7 +1165,7 @@
    1165 1165 
                  (Nothing)
    1166 1166 
                  (ListNone)
    1167 1167 
                  []
    1168 
    -             (NoEpTok)
    1168 
    +             (())
    1169 1169 
                  []))
    1170 1170 
                (L
    1171 1171 
                 (EpAnn

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -2326,7 +2326,7 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where
    2326 2326 
       getAnnotationEntry _ = NoEntryVal
    2327 2327 
       setAnnotationAnchor a _ _ _ = a
    2328 2328
    2329 
    -  exact (PSB{ psb_ext = AnnPSB ap al ae
    2329 
    +  exact (PSB{ psb_ext = AnnPSB ap al ae aw
    2330 2330 
                 , psb_id = psyn, psb_args = details
    2331 2331 
                 , psb_def = pat
    2332 2332 
                 , psb_dir = dir }) = do
    ... ... @@ -2349,23 +2349,24 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where
    2349 2349 
               ac' <- markEpToken ac
    2350 2350 
               return (psyn', RecCon (ao',ac') vs')
    2351 2351
    2352 
    -    (al', ae', pat', dir') <-
    2352 
    +    (al', ae', pat', dir', aw') <-
    2353 2353 
           case dir of
    2354 2354 
             Unidirectional           -> do
    2355 2355 
               al' <- mapM markEpUniToken al
    2356 2356 
               pat' <- markAnnotated pat
    2357 
    -          return (al', ae, pat', dir)
    2357 
    +          return (al', ae, pat', dir, aw)
    2358 2358 
             ImplicitBidirectional    -> do
    2359 2359 
               ae' <- mapM markEpToken ae
    2360 2360 
               pat' <- markAnnotated pat
    2361 
    -          return (al, ae', pat', dir)
    2361 
    +          return (al, ae', pat', dir, aw)
    2362 2362 
             ExplicitBidirectional mg -> do
    2363 2363 
               al' <- mapM markEpUniToken al
    2364 2364 
               pat' <- markAnnotated pat
    2365 
    +          aw' <- mapM markEpToken aw
    2365 2366 
               mg' <- markAnnotated mg
    2366 
    -          return (al', ae, pat', ExplicitBidirectional mg')
    2367 
    +          return (al', ae, pat', ExplicitBidirectional mg', aw')
    2367 2368
    2368 
    -    return (PSB{ psb_ext = AnnPSB ap' al' ae'
    2369 
    +    return (PSB{ psb_ext = AnnPSB ap' al' ae' aw'
    2369 2370 
                    , psb_id = psyn', psb_args = details'
    2370 2371 
                    , psb_def = pat'
    2371 2372 
                    , psb_dir = dir' })
    ... ... @@ -3249,11 +3250,10 @@ instance (Typeable body,
    3249 3250 
         = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches)
    3250 3251
    3251 3252 
       exact (MG (origin,an) (L l matches)) = do
    3252 
    -    an0 <- markLensFun an lal_rest markEpToken -- 'where', only for PatSynBind
    3253 
    -    (an1,matches') <- markAnnListA' an0 $ \a -> do
    3253 
    +    (an0,matches') <- markAnnListA' an $ \a -> do
    3254 3254 
             m' <- markAnnotated matches
    3255 3255 
             return (a,m')
    3256 
    -    return (MG (origin, an1) (L l matches'))
    3256 
    +    return (MG (origin, an0) (L l matches'))
    3257 3257
    3258 3258 
     -- ---------------------------------------------------------------------
    3259 3259

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help