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

Commits:

16 changed files:

Changes:

  • .gitlab-ci.yml
    ... ... @@ -255,6 +255,9 @@ lint-changelog:
    255 255 
         BUILD_FLAVOUR: default
    256 256 
         CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID"
    257 257 
       script:
    258 
    +    # Cancel the job if there is a no-changelog label
    259 
    +    - |
    260 
    +      [[ ",${CI_MERGE_REQUEST_LABELS}," == *",no-changelog,"* ]] && exit 0
    258 261 
         # Check that the MR adds at least one changelog entry
    259 262 
         - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME"
    260 263 
         - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
    ... ... @@ -274,8 +277,6 @@ lint-changelog:
    274 277 
       rules:
    275 278 
         - if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/'
    276 279 
           when: never
    277 
    -    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/'
    278 
    -      when: never
    279 280 
         - if: $CI_MERGE_REQUEST_ID
    280 281 
         - *drafts-can-fail-lint
    281 282

  • changelog.d/tool-messages-27370
    1 
    +section: compiler
    2 
    +synopsis: Mark messages from external tools as errors or warnings depending on
    3 
    +  the tool's exit code. Previously, output printed to stderr by tools was
    4 
    +  unconditionally reported as errors.
    5 
    +issues: #27370
    6 
    +mrs: !16170

  • compiler/GHC/SysTools/Process.hs
    ... ... @@ -26,8 +26,9 @@ import GHC.Utils.Logger
    26 26 
     import GHC.Utils.TmpFs
    27 27 
     import GHC.Utils.CliOption
    28 28
    29 
    -import GHC.Driver.Errors (reportError)
    29 
    +import GHC.Driver.Errors (reportDiagnostic)
    30 30
    31 
    +import GHC.Types.Error ( DiagnosticReason(..) )
    31 32 
     import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
    32 33 
     import GHC.Data.FastString
    33 34
    ... ... @@ -271,9 +272,10 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
    271 272 
               getLocaleEncoding >>= hSetEncoding readEnd
    272 273 
               hSetNewlineMode readEnd nativeNewlineMode
    273 274 
               hSetBuffering readEnd LineBuffering
    274 
    -          messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd
    275 
    -          mapM_ processBuildMessage messages
    276 
    -          waitForProcess hProcess
    275 
    +          messages <- parseBuildMessages . filter_fn . lines <$> hGetContents' readEnd
    276 
    +          code <- waitForProcess hProcess
    277 
    +          mapM_ (processBuildMessage code) messages
    278 
    +          return code
    277 279 
             hClose hStdIn
    278 280 
             case r of
    279 281 
               Left (SomeException e) -> do
    ... ... @@ -282,13 +284,16 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
    282 284 
               Right s -> do
    283 285 
                 return s
    284 286 
       where
    285 
    -    processBuildMessage :: BuildMessage -> IO ()
    286 
    -    processBuildMessage msg = do
    287 
    +    processBuildMessage :: ExitCode -> BuildMessage -> IO ()
    288 
    +    processBuildMessage code msg = do
    287 289 
           case msg of
    288 290 
             BuildMsg msg -> do
    289 291 
               logInfo logger $ withPprStyle defaultUserStyle msg
    290 292 
             BuildError loc msg -> do
    291 
    -          reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg
    293 
    +          let reason = case code of
    294 
    +                ExitSuccess   -> WarningWithoutFlag
    295 
    +                ExitFailure{} -> ErrorWithoutFlag
    296 
    +          reportDiagnostic logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) reason msg
    292 297
    293 298 
     parseBuildMessages :: [String] -> [BuildMessage]
    294 299 
     parseBuildMessages str = loop str Nothing

  • compiler/GHC/Tc/Solver/Equality.hs
    ... ... @@ -2980,15 +2980,30 @@ But it's not so simple:
    2980 2980 
        we kick out g1. Now we have two constraints
    2981 2981 
            [W] g1        : F a ~ a Int  (arising from (F a ~ a Int))
    2982 2982 
            [W] g2{rw:g1} : F a ~ a Int  (arising from (F alpha ~ F a))
    2983 
    -   If we end up with g2 in the inert set (not g1) we'll get a very confusing
    2984 
    -   error message that we can solve (F a ~ a Int)
    2985 
    -       arising from F a ~ F a
    2983 
    +   If we solve `g1` from `g2` we end up with
    2984 
    +     g1 := g2
    2985 
    +     [W] g2{} : F a ~ a Int  (arising from (F alpha ~ F a))
    2986 
    +   and hence (since alpha := a) we report that we can't solve (F a ~ a Int)
    2987 
    +   arising from (F a ~ F a), which is extremely confusing. Moreover, it seems
    2988 
    +   wrong to "solve" `g1` using `g2` when `g2` has itself been rewritten by `g1`!
    2986 2989
    2987 2990 
        TL;DR: Better to hang on to `g1` (with no rewriters), in preference
    2988 2991 
        to `g2` (which has a rewriter).
    2989 2992
    2990 2993 
        See (WRW11) in Note [Wanteds rewrite Wanteds: rewriter-sets]
    2991 2994 
        in GHC.Tc.Types.Constraint.
    2995 
    +
    2996 
    +   Note that the decision to prefer a constraint without rewriters over one that
    2997 
    +   has rewriters can also have a /huge/ effect on performance. For instance, it
    2998 
    +   avoids an **exponential** blow-up in the size of coercions produced when
    2999 
    +   typechecking in T26426. In that program, we have coercions of the form:
    3000 
    +
    3001 
    +     co_i :: TaggedTypes as `Append` TaggedTypes '[ty]
    3002 
    +          ~# TaggedTypes (as `Append` '[ty])
    3003 
    +
    3004 
    +   and each 'co_{i+1}' contains the previous 'co_i' twice. Without preferring
    3005 
    +   Wanteds with no rewriters, we essentially end up inlining 'co_i' into 'co_{i+1}',
    3006 
    +   which results in exponentially-sized proof terms, growing like O(2^i).
    2992 3007 
     -}
    2993 3008
    2994 3009 
     tryInertEqs :: EqCt -> SolverStage ()

  • compiler/GHC/Tc/Solver/FunDeps.hs
    ... ... @@ -1198,6 +1198,56 @@ Key point: equations that are not relevant do not need to be considered for fund
    1198 1198 
       and [W] I alpha ~ Int |> g2
    1199 1199 
       Here we definiteily want to take advantage of injectivity.
    1200 1200
    1201 
    +(CF6) This machinery can also have a significant positive effect on the size of
    1202 
    +  proof terms. For example (simplification of T26426):
    1203 
    +
    1204 
    +      type family (++) a b where { '[] ++ ys = ys; (x:xs) ++ ys = x : (xs ++ ys) }
    1205 
    +      type family MapId a where { MapId '[] = '[]; MapId (x:xs) = x : MapId xs }
    1206 
    +
    1207 
    +      app :: (MapId xs ++ MapId ys ~ MapId (xs ++ ys)) => Proxy xs -> Proxy ys -> Proxy (xs ++ ys)
    1208 
    +
    1209 
    +      test :: Proxy [ty_1, ..., ty_n]
    1210 
    +      test =   Proxy @'[ty_1]
    1211 
    +         `app` Proxy @'[ty_2]
    1212 
    +         ...
    1213 
    +         `app` Proxy @'[ty_n]
    1214 
    +
    1215 
    +  Every `app` call gives rise to a Wanted of the form:
    1216 
    +
    1217 
    +    [W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i])
    1218 
    +
    1219 
    +  while the overall result type gives us a Wanted of the form
    1220 
    +
    1221 
    +    [W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n]
    1222 
    +
    1223 
    +  By using (CFFA) on this result Wanted, we deduce that we must have
    1224 
    +
    1225 
    +    acc_n ~ [ty_1, ..., ty_{n-1}]
    1226 
    +
    1227 
    +  which is a flat list. Repeating the process, (CFFA) allows us to deduce that
    1228 
    +
    1229 
    +    acc_i ~ [ty_1, ..., ty_{i-1}]
    1230 
    +
    1231 
    +  for all i. This allows the other Wanteds to be solved directly, giving rise to
    1232 
    +  proof terms with the typical triangular O(n^2) shape
    1233 
    +
    1234 
    +    co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1})
    1235 
    +         ; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i]))
    1236 
    +
    1237 
    +  However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left
    1238 
    +  as the nested application:
    1239 
    +
    1240 
    +    acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}])
    1241 
    +
    1242 
    +  This means that 'MapId acc_i' is stuck until we reduce the above, which takes
    1243 
    +  O(i^2) type family reduction steps, instead of O(i). The same applies to
    1244 
    +  the other proof term involving 'MapId (acc_i ++ '[ty_i])'.
    1245 
    +  Consequently, without (CFFA) the overall coercion size blows up to O(n^3).
    1246 
    +
    1247 
    +  The takeaway is that (CFFA) allows us to push in the (flat) result type,
    1248 
    +  instead of relying on recursively built sub-proof terms, which brings down
    1249 
    +  coercion sizes (in certain situations) from O(n^3) to O(n^2).
    1250 
    +
    1201 1251 
     Note [Cache-caused loops]
    1202 1252 
     ~~~~~~~~~~~~~~~~~~~~~~~~~
    1203 1253 
     It is very dangerous to cache a rewritten wanted family equation as 'solved' in

  • libraries/process
    1 
    -Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4
    1 
    +Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4

  • testsuite/driver/testlib.py
    ... ... @@ -3066,11 +3066,15 @@ def normalise_errmsg(s: str) -> str:
    3066 3066 
         # Old emcc warns when we export HEAP8 but new one requires it (see #26290)
    3067 3067 
         s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','')
    3068 3068
    3069 
    -    # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols,
    3070 
    -    # however, these are completely benign stubs.
    3071 
    -    # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116
    3072 3069 
         if opsys('darwin'):
    3070 
    +        # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols,
    3071 
    +        # however, these are completely benign stubs.
    3072 
    +        # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116
    3073 3073 
             s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l))
    3074 
    +        # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with
    3075 
    +        # making a single weak symbol undefined as this is dependent on other linker flags
    3076 
    +        # See also https://github.com/haskell/process/pull/377
    3077 
    +        s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup')
    3074 3078
    3075 3079 
         return s
    3076 3080

  • testsuite/tests/driver/T27370/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +T27370:
    6 
    +	chmod +x ./T27370.pp
    7 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -c T27370.hs

  • testsuite/tests/driver/T27370/T27370.hs
    1 
    +{-# OPTIONS_GHC -F -pgmF ./T27370.pp #-}
    2 
    +module T27370 where

  • testsuite/tests/driver/T27370/T27370.pp
    1 
    +#!/bin/sh
    2 
    +cp "$2" "$3"
    3 
    +echo "$1:2:8: a located warning from an external tool"
    4 
    +echo "  with a continuation line"
    5 
    +echo "an unlocated line from an external tool"

  • testsuite/tests/driver/T27370/T27370.stderr
    1 
    +T27370.hs:2:8: warning:
    2 
    +     a located warning from an external tool
    3 
    +      with a continuation line
    4 
    +
    5 
    +an unlocated line from an external tool

  • testsuite/tests/driver/T27370/all.T
    1 
    +test('T27370',
    2 
    +     [extra_files(['T27370.hs', 'T27370.pp']),
    3 
    +      when(opsys('mingw32'), skip)],
    4 
    +     makefile_test, ['T27370'])

  • testsuite/tests/perf/compiler/T26426.hs
    1 
    +{-# LANGUAGE DataKinds #-}
    2 
    +{-# LANGUAGE TypeFamilies #-}
    3 
    +module T26426 (
    4 
    +  someTypes
    5 
    +) where
    6 
    +
    7 
    +import Data.Kind (Type)
    8 
    +import GHC.TypeLits (Symbol)
    9 
    +
    10 
    +type family Append (left :: [k]) (right :: [k]) :: [k] where
    11 
    +  Append '[] right = right
    12 
    +  Append (a : rest) right = a : Append rest right
    13 
    +
    14 
    +type family TaggedTypes (tags :: [(Symbol, Type)]) :: [Type] where
    15 
    +  TaggedTypes '[] = '[]
    16 
    +  TaggedTypes ('(_, typ) : rest) = typ : TaggedTypes rest
    17 
    +
    18 
    +data Types (types :: [(Symbol, Type)]) = Types
    19 
    +
    20 
    +mkTypes :: forall sym val. val -> Types '[ '(sym, val) ]
    21 
    +mkTypes _ = Types
    22 
    +
    23 
    +appendTypes ::
    24 
    +  -- This constraint is the one that causes the issue. If the next line is commented
    25 
    +  -- out, then this module compiles quickly
    26 
    +  Append (TaggedTypes left) (TaggedTypes right) ~ TaggedTypes (Append left right) =>
    27 
    +  Types left -> Types right -> Types (Append left right)
    28 
    +appendTypes _ _ = Types
    29 
    +
    30 
    +someTypes ::
    31 
    +  Types
    32 
    +    [ '("01", Int)
    33 
    +    , '("02", Int)
    34 
    +    , '("03", Int)
    35 
    +    , '("04", Int)
    36 
    +    , '("05", Int)
    37 
    +    , '("06", Int)
    38 
    +    , '("07", Int)
    39 
    +    , '("08", Int)
    40 
    +    , '("09", Int)
    41 
    +    , '("10", Int)
    42 
    +    , '("11", Int)
    43 
    +    , '("12", Int)
    44 
    +    , '("13", Int)
    45 
    +    , '("14", Int)
    46 
    +    , '("15", Int)
    47 
    +    , '("16", Int)
    48 
    +    ]
    49 
    +
    50 
    +someTypes =
    51 
    +  mkTypes @"01"  1 `appendTypes`
    52 
    +  mkTypes @"02"  2 `appendTypes`
    53 
    +  mkTypes @"03"  3 `appendTypes`
    54 
    +  mkTypes @"04"  4 `appendTypes`
    55 
    +  mkTypes @"05"  5 `appendTypes`
    56 
    +  mkTypes @"06"  6 `appendTypes`
    57 
    +  mkTypes @"07"  7 `appendTypes`
    58 
    +  mkTypes @"08"  8 `appendTypes`
    59 
    +  mkTypes @"09"  9 `appendTypes`
    60 
    +  mkTypes @"10" 10 `appendTypes`
    61 
    +  mkTypes @"11" 11 `appendTypes`
    62 
    +  mkTypes @"12" 12 `appendTypes`
    63 
    +  mkTypes @"13" 13 `appendTypes`
    64 
    +  mkTypes @"14" 14 `appendTypes`
    65 
    +  mkTypes @"15" 15 `appendTypes`
    66 
    +  mkTypes @"16" 16

  • testsuite/tests/perf/compiler/all.T
    ... ... @@ -87,6 +87,13 @@ test('T783',
    87 87 
           ],
    88 88 
           compile,[''])
    89 89
    90 
    +test ('T26426'
    91 
    +     , [ only_ways(['normal'])
    92 
    +       , collect_compiler_stats('bytes allocated',4) ]
    93 
    +     , compile
    94 
    +     , ['']
    95 
    +     )
    96 
    +
    90 97 
     test('T5321Fun',
    91 98 
          [ only_ways(['normal']),  # no optimisation for this one
    92 99 
            collect_compiler_runtime(2),

  • utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
    ... ... @@ -148,12 +148,14 @@ findProgram description userSpec candidates
    148 148 
                     Just prefix -> map (prefix++) candidates
    149 149 
                     Nothing     -> []
    150 150 
               candidates' = prefixedCandidates ++ candidates
    151 
    -          err =
    152 
    -            [ "Failed to find " ++ description ++ "."
    153 
    -            , "Looked for one of " ++ show candidates' ++ " in the system search path."
    154 
    -            ]
    155 
    -      path <- oneOf' err (map findExecutableErr candidates')
    156 
    -      return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
    151 
    +      pathMay <- findM doesExecutableExist candidates'
    152 
    +      case pathMay of
    153 
    +        Nothing -> throwEs
    154 
    +          [ "Failed to find " ++ description ++ "."
    155 
    +          , "Looked for one of " ++ show candidates' ++ " in the system search path."
    156 
    +          ]
    157 
    +        Just path ->
    158 
    +          return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
    157 159
    158 160 
     -- Note that @configure.ac@ checks these llvm version constants (using @sed@) to
    159 161 
     -- ensure they are the same as the @$LlvmMinVersion@ and @$LlvmMaxVersion@
    ... ... @@ -222,21 +224,18 @@ maybeFindProgramFromProgOpts :: String -> ProgOpt -> Maybe (M Program)
    222 224 
     maybeFindProgramFromProgOpts description userSpec = case poPath userSpec of
    223 225 
       Nothing -> Nothing
    224 226 
       Just path -> Just $ do
    225 
    -    let err =
    226 
    -          [ "Failed to find " ++ description ++ "."
    227 
    -          , "Looked for user-specified program '" ++ path ++ "' in the system search path."
    228 
    -          ]
    229 
    -    path' <- findExecutableErr path <|> throwEs err
    230 
    -    return Program { prgPath = path', prgFlags = fromMaybe [] (poFlags userSpec) }
    231 
    -
    232 
    -findExecutableErr :: String -> M FilePath
    233 
    -findExecutableErr name = do
    234 
    -    r <- liftIO $ findExecutable name
    235 
    -    case r of
    236 
    -      Nothing -> throwE $ name ++ " not found in search path"
    237 
    -      -- Use the given `prgPath` or candidate name rather than the
    238 
    -      -- absolute path returned by `findExecutable`.
    239 
    -      Just _x -> return name
    227 
    +    exists <- doesExecutableExist path
    228 
    +    unless exists $ throwEs
    229 
    +      [ "Failed to find " ++ description ++ "."
    230 
    +      , "Looked for user-specified program '" ++ path ++ "' in the system search path."
    231 
    +      ]
    232 
    +    return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
    233 
    +
    234 
    +doesExecutableExist
    235 
    +  :: String -- ^ executable name
    236 
    +  -> M Bool
    237 
    +doesExecutableExist name = isJust <$> liftIO (findExecutable name)
    238 
    +
    240 239
    241 240 
     -------------------- Compiling utilities --------------------
    242 241

  • utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
    ... ... @@ -9,6 +9,7 @@ module GHC.Toolchain.Utils
    9 9 
         , oneOf'
    10 10 
         , isSuccess
    11 11 
         , lastLine
    12 
    +    , findM
    12 13 
         ) where
    13 14
    14 15 
     import Control.Exception
    ... ... @@ -69,3 +70,10 @@ isSuccess = \case
    69 70
    70 71 
     lastLine :: String -> String
    71 72 
     lastLine = maybe "" snd . unsnoc . lines
    73 
    +
    74 
    +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
    75 
    +findM f = \case
    76 
    +  [] -> return Nothing
    77 
    +  a:as -> do
    78 
    +    found <- f a
    79 
    +    if found then return (Just a) else findM f as

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