Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-27 at Glasgow Haskell Compiler / GHC

Commits:

13 changed files:

Changes:

  • changelog.d/hadrian-persist-flavour
    1 
    +section: packaging
    2 
    +synopsis: Hadrian now persists the flavour name in the build root. When
    3 
    +  rebuilding, the previously used flavour is automatically restored, removing
    4 
    +  the need to re-specify it on every invocation and avoiding accidental build
    5 
    +  root invalidation.
    6 
    +issues: #20650
    7 
    +mrs: !7017

  • changelog.d/unit-index
    1 1 
     section: compiler
    2 2 
     synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units
    3 
    -issues: #27500 #26423 #27748 #27834
    4 
    -mrs: !16115 !16598 !16743
    3 
    +issues: #27500 #26423 #27748 #27834 #27835
    4 
    +mrs: !16115 !16598 !16743 !16748
    5 5
    6 6 
     description: {
    7 7 
         The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s.

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do
    441 441 
               }
    442 442 
         let uic = hscUIC hsc_env
    443 443 
         liftIO $ cacheExternalUnitDatabase uic newdb
    444 
    -    -- added at the end because ordering matters
    444 
    +    -- Ordering matters here! We prepend the new unit database, because 'packageDBFlags'
    445 
    +    -- works like a stack, where what's on top takes precedence over what's below (same as right-to-left when given at the CLI).
    446 
    +    -- The new db needs highest precedence to overwrite any other in-memory units that potentially occur in the dbs below it.
    445 447 
         pure dflags
    446 
    -          { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
    448 
    +          { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags
    447 449 
               }
    448 450
    449 451 
     -- | Register a new virtual unit database containing a single unit

  • compiler/GHC/Parser.y
    ... ... @@ -1797,10 +1797,10 @@ cvars1 :: { [RecordPatSynField GhcPs] }
    1797 1797 
     where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) }
    1798 1798 
             : 'where' '{' decls '}'       {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3,
    1799 1799 
                                                     epTok $1,
    1800 
    -                                                AnnList (AnnListLayout (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) }
    1800 
    +                                                AnnList AnnListBraces (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) }
    1801 1801 
             | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3,
    1802 1802 
                                                     epTok $1,
    1803 
    -                                                AnnList (AnnListLayout (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) }
    1803 
    +                                                AnnList (AnnListLayout (glR $3)) ListNone (sndOf3 $ unLoc $3))) }
    1804 1804
    1805 1805 
     pattern_synonym_sig :: { LSig GhcPs }
    1806 1806 
             : 'pattern' con_list '::' sigtype
    ... ... @@ -1936,7 +1936,7 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) }
    1936 1936 
             | {- empty -}                   { noLoc (noAnn, [],nilOL) }
    1937 1937
    1938 1938 
     decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }
    1939 
    -        : '{'            decls '}'     { sLL $1 $> (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2)
    1939 
    +        : '{'            decls '}'     { sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2)
    1940 1940 
                                                        ,sL1 $2 $ thdOf3 $ unLoc $2) }
    1941 1941 
             |     vocurly    decls close   { sL1 $2    (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2)
    1942 1942 
                                                        ,sL1 $2 $ thdOf3 $ unLoc $2) }
    ... ... @@ -1952,7 +1952,7 @@ binds :: { Located (HsLocalBinds GhcPs) }
    1952 1952 
                                       ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList la p s) cs, noEpTok) val_binds)} }
    1953 1953
    1954 1954 
             | '{'            dbinds '}'     {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc
    1955 
    -                                             $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (AnnListLayout$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) }
    1955 
    +                                             $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) }
    1956 1956
    1957 1957 
             |     vocurly    dbinds close   {% acs (gl $2) (\loc cs -> (L loc
    1958 1958 
                                                  $ HsIPBinds (EpAnn (glR $1) (AnnList (AnnListLayout $ glR $2) ListNone []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) }
    ... ... @@ -3543,12 +3543,12 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
    3543 3543 
     altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) }
    3544 3544 
             : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsA'
    3545 3545 
                                                (sLL $1 $> (reverse (snd $ unLoc $2),
    3546 
    -                                           (AnnList (AnnListLayout $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) }
    3546 
    +                                           (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) }
    3547 3547 
             | vocurly    alts(PATS)  close { $2 >>= \ $2 -> amsA'
    3548 3548 
                                                (L (getLoc $2) (reverse (snd $ unLoc $2),
    3549 3549 
                                                (AnnList (AnnListLayout $ glR $2) ListNone (fst $ unLoc $2)))) }
    3550 
    -        | '{'              '}'   { amsA' (sLL $1 $> ([], (AnnList AnnListNoLayout (ListBraces (epTok $1) (epTok $2)) []))) }
    3551 
    -        | vocurly          close { return $ noLocA ([], noAnn) }
    3550 
    +        | '{'              '}'   { amsA' (sLL $1 $> ([], (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $2)) []))) }
    3551 
    +        | vocurly          close { return $ noLocA ([], AnnList (AnnListLayout $ glR $1) ListNone []) }
    3552 3552
    3553 3553 
     alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) }
    3554 3554 
             : alts1(PATS)              { $1 >>= \ $1 -> return $
    ... ... @@ -3657,7 +3657,7 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) }
    3657 3657
    3658 3658 
     stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
    3659 3659 
             : '{'           stmts '}'       { $2 >>= \ $2 ->
    3660 
    -                                          amsA' (sLL $1 $> (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2)
    3660 
    +                                          amsA' (sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2)
    3661 3661 
                                                                , sL1 $2 $ reverse $ snd $ unLoc $2))}
    3662 3662 
             |     vocurly   stmts close     { $2 >>= \ $2 ->
    3663 3663 
                                               amsA' (L (stmtsLoc $2) (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2)

  • distrib/configure.ac.in
    ... ... @@ -103,7 +103,7 @@ AC_ARG_ENABLE(distro-toolchain,
    103 103 
     AC_SUBST([EnableDistroToolchain])
    104 104
    105 105 
     if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then
    106 
    -  FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/])
    106 
    +  FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$topdir/../mingw/])
    107 107 
     fi
    108 108
    109 109

  • hadrian/doc/flavours.md
    ... ... @@ -3,7 +3,14 @@
    3 3 
     Hadrian supports a few predefined _build flavours_, i.e. collections of build
    4 4 
     settings that fully define a GHC build (see `src/Flavour.hs`). Users can add their
    5 5 
     own build flavours if need be, as described
    6 
    -[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#build-flavour).
    6 
    +[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#build-flavour) or modify existing flavours using the flavour transformers notion seem below.
    7 
    +
    8 
    +The flavour to be used for a build root can be specified on the command-line
    9 
    +via the `--flavour` flag. Moreover, this flavour name is saved in the build
    10 
    +root; future invocations of Hadrian without a `--flavour` flag will default to
    11 
    +the last-used flavour.
    12 
    +
    13 
    +See `Note [Persisting the flavour]` in `hadrian/src/Settings.hs`
    7 14
    8 15 
     ## Arguments
    9 16

  • hadrian/src/Rules.hs
    ... ... @@ -129,6 +129,7 @@ packageRules = do
    129 129
    130 130 
     buildRules :: Rules ()
    131 131 
     buildRules = do
    132 
    +    Settings.flavourFileRules
    132 133 
         Rules.BinaryDist.bindistRules
    133 134 
         Rules.Generate.copyRules
    134 135 
         Rules.Generate.generateRules

  • hadrian/src/Settings.hs
    1 
    +{-# LANGUAGE TupleSections #-}
    2 
    +{-# LANGUAGE TypeFamilies  #-}
    3 
    +
    1 4 
     module Settings (
    2 5 
         getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
    3 6 
         findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath,
    4 7 
         isLibrary, stagePackages, getBignumBackend, completeSetting,
    5 8 
         queryBuildTarget, queryHostTarget,
    6 9 
         queryBuild, queryHost,
    7 
    -    queryArch, queryOS, queryVendor
    10 
    +    queryArch, queryOS, queryVendor,
    11 
    +    flavourFileRules
    8 12 
         ) where
    9 13
    10 14 
     import CommandLine
    ... ... @@ -58,6 +62,56 @@ hadrianFlavours =
    58 62 
         , ghcInGhciFlavour, validateFlavour, slowValidateFlavour
    59 63 
         ]
    60 64
    65 
    +{-
    66 
    +Note [Persisting the flavour]
    67 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    68 
    +Passing the flavour on the command-line means the user must consistently pass
    69 
    +the same --flavour flag to all Hadrian invocations on a particular build root.
    70 
    +Forgetting even once can result in a full rebuild of the tree.
    71 
    +
    72 
    +To avoid this we persist the flavour name in the build root itself
    73 
    +(specifically, in `<build root>/flavour`). We refer to this file when looking
    74 
    +up the active flavour, defaulting to it if the user does not specify a flavour
    75 
    +name explicitly.
    76 
    +-}
    77 
    +
    78 
    +-- | Oracle query type for the active flavour name.
    79 
    +-- See Note [Persisting the flavour].
    80 
    +newtype FlavourName = FlavourName ()
    81 
    +    deriving (Binary, Eq, Hashable, NFData, Show)
    82 
    +type instance RuleResult FlavourName = String
    83 
    +
    84 
    +flavourFileRules :: Rules ()
    85 
    +flavourFileRules = do
    86 
    +    root <- buildRootRules
    87 
    +
    88 
    +    -- Cache the flavour name lookup for the whole Shake run.
    89 
    +    -- alwaysRerun ensures the oracle re-executes on every new invocation so
    90 
    +    -- that a changed --flavour flag is never ignored due to a stale cross-run
    91 
    +    -- cache entry (CLI args are not tracked as Shake dependencies).
    92 
    +    -- See Note [Persisting the flavour].
    93 
    +    void $ addOracleCache $ \(FlavourName _) -> do
    94 
    +        alwaysRerun
    95 
    +        let flavourFile = root -/- "flavour"
    96 
    +        cmdFlavour >>= \case
    97 
    +          Just nm -> do
    98 
    +            putBuild $ "Flavour: " ++ nm
    99 
    +            liftIO $ writeFile flavourFile nm
    100 
    +            return nm
    101 
    +          Nothing -> do
    102 
    +            exists <- doesFileExist flavourFile
    103 
    +            if exists
    104 
    +              then do nm <- liftIO $ readFile flavourFile
    105 
    +                      putBuild $ "Flavour: " ++ nm ++ " (cached from last build, override by passing --flavour=... explicitly)"
    106 
    +                      return nm
    107 
    +              else return userDefaultFlavour
    108 
    +
    109 
    +-- | Lookup the requested flavour name, referring to the persistent flavour
    110 
    +-- file saved from the previous Hadrian execution if not specified.
    111 
    +-- The result is cached for the whole Shake run via the 'FlavourName' oracle.
    112 
    +getFlavourName :: Action String
    113 
    +getFlavourName = askOracle (FlavourName ())
    114 
    +
    61 115 
     -- | This action looks up a flavour with the name given on the
    62 116 
     --   command line with @--flavour@, defaulting to 'userDefaultFlavour'
    63 117 
     --   when no explicit @--flavour@ is passed. It then applies any
    ... ... @@ -66,7 +120,7 @@ hadrianFlavours =
    66 120 
     --   syntax. See Note [Hadrian settings] at the bottom of this file.
    67 121 
     flavour :: Action Flavour
    68 122 
     flavour = do
    69 
    -    flavourName <- fromMaybe userDefaultFlavour <$> cmdFlavour
    123 
    +    flavourName <- getFlavourName
    70 124 
         when ("quickest" `isPrefixOf` flavourName) $
    71 125 
           fail $ "The `quickest` flavour has been deprecated. Use `quick` instead.\n"
    72 126 
               ++ "Skip building dynamic libraries with `quick+no_dynamic_libs`\n"

  • m4/subst_tooldir.m4
    ... ... @@ -41,5 +41,5 @@ dnl ghc-toolchain.
    41 41 
     # See Note [How we configure the bundled windows toolchain]
    42 42 
     AC_DEFUN([SUBST_TOOLDIR],
    43 43 
     [
    44 
    -    sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g'
    44 
    +    sed -i.bkp 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' $1
    45 45 
     ])

  • testsuite/tests/backpack/should_compile/T27835.bkp
    1 
    +unit p where
    2 
    +  module P where
    3 
    +    p :: Int
    4 
    +    p = 42
    5 
    +
    6 
    +unit q where
    7 
    +  dependency p
    8 
    +  module Q where
    9 
    +    import P
    10 
    +    q :: Int
    11 
    +    q = p + 1

  • testsuite/tests/backpack/should_compile/T27835.stderr
    1 
    +[1 of 2] Processing p
    2 
    +  Instantiating p
    3 
    +  [1 of 1] Compiling P                ( p/P.hs, T27835.out/p/P.o )
    4 
    +[2 of 2] Processing q
    5 
    +  Instantiating q
    6 
    +  [1 of 1] Including p
    7 
    +  [1 of 1] Compiling Q                ( q/Q.hs, T27835.out/q/Q.o )

  • testsuite/tests/backpack/should_compile/all.T
    ... ... @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, [''])
    61 61 
     test('T13323', normal, backpack_compile, [''])
    62 62 
     test('T20396', normal, backpack_compile, [''])
    63 63 
     test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace'])
    64 
    +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db'])

  • testsuite/tests/parser/should_compile/DumpSemis.stderr
    ... ... @@ -364,8 +364,7 @@
    364 364 
                            ((,)
    365 365 
                             (Right
    366 366 
                              (AnnList
    367 
    -                          (AnnListLayout
    368 
    -                           (EpaSpan { DumpSemis.hs:11:8-13 }))
    367 
    +                          (AnnListBraces)
    369 368 
                               (ListBraces
    370 369 
                                (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
    371 370 
                                (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
    ... ... @@ -627,8 +626,7 @@
    627 626 
                      ((,)
    628 627 
                       (Right
    629 628 
                        (AnnList
    630 
    -                    (AnnListLayout
    631 
    -                     (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))
    629 
    +                    (AnnListBraces)
    632 630 
                         (ListBraces
    633 631 
                          (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
    634 632 
                          (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
    ... ... @@ -880,8 +878,7 @@
    880 878 
                      ((,)
    881 879 
                       (Right
    882 880 
                        (AnnList
    883 
    -                    (AnnListLayout
    884 
    -                     (EpaSpan { DumpSemis.hs:22:12-28 }))
    881 
    +                    (AnnListBraces)
    885 882 
                         (ListBraces
    886 883 
                          (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
    887 884 
                          (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
    ... ... @@ -1936,8 +1933,7 @@
    1936 1933 
                        (EpAnn
    1937 1934 
                         (EpaSpan { DumpSemis.hs:34:13-31 })
    1938 1935 
                         (AnnList
    1939 
    -                     (AnnListLayout
    1940 
    -                      (EpaSpan { DumpSemis.hs:34:18-30 }))
    1936 
    +                     (AnnListBraces)
    1941 1937 
                          (ListBraces
    1942 1938 
                           (EpTok (EpaSpan { DumpSemis.hs:34:13 }))
    1943 1939 
                           (EpTok (EpaSpan { DumpSemis.hs:34:31 })))
    ... ... @@ -2333,8 +2329,7 @@
    2333 2329 
                       ((,)
    2334 2330 
                        (FromSource)
    2335 2331 
                        (AnnList
    2336 
    -                    (AnnListLayout
    2337 
    -                     (EpaSpan { DumpSemis.hs:(38,6)-(43,13) }))
    2332 
    +                    (AnnListBraces)
    2338 2333 
                         (ListBraces
    2339 2334 
                          (EpTok (EpaSpan { DumpSemis.hs:38:4 }))
    2340 2335 
                          (EpTok (EpaSpan { DumpSemis.hs:44:4 })))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/fbf72978dae224dce5a366cf0f1f7482e3f12ea7...ec341aeb482eefc0e1a68ac8a22ddd28456efc79 at 1791310732