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

Commits:

23 changed files:

Changes:

  • changelog.d/T27202
    1 1 
     section: ghci
    2 2 
     synopsis: Fix regression to honour module targets in nested directories into GHCi after startup.
    3 
    -issues: #27202
    4 
    -mrs: !15980
    3 
    +issues: #27202 #27640
    4 
    +mrs: !15980 !16591
    5 5
    6 6 
     description: {
    7 7 
         Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup.

  • changelog.d/rethrow-stm
    1 
    +section: ghc-internal
    2 
    +synopsis: Add `rethrowSTM`, an `STM` analog of `rethrowIO`
    3 
    +issues: #26758
    4 
    +mrs: !16501

  • 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
    4 
    -mrs: !16115
    3 
    +issues: #27500 #26423 #27748
    4 
    +mrs: !16115 !16598
    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/Session/Units.hs
    ... ... @@ -145,8 +145,15 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
    145 145 
       checkUnitCycles initial_dflags home_unit_graph
    146 146
    147 147 
       let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph
    148 
    -  unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
    149 
    -  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
    148 
    +  newUnitEnv <-  do
    149 
    +    env <- liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
    150 
    +    -- We need to reuse the 'UnitIndexCache' as we used it above in 'initUnits'.
    151 
    +    -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] why this must be shared.
    152 
    +    pure $ assertUnitEnvInvariant $ env
    153 
    +      { ue_uic = hscUIC hsc_env
    154 
    +      }
    155 
    +
    156 
    +  let final_hsc_env = hsc_env { hsc_unit_env = newUnitEnv }
    150 157
    151 158 
       GHC.setSession final_hsc_env
    152 159

  • compiler/GHC/Parser/PostProcess/Haddock.hs
    ... ... @@ -265,12 +265,14 @@ instance HasHaddock (Located (HsModule GhcPs)) where
    265 265 
         --    ) where
    266 266 
         --
    267 267 
         -- Only do this when the export list exists.
    268 
    -    let (_, close_paren, _) = am_exports mod_anns
    268 
    +    let
    269 
    +      (open_paren, close_paren, _) = am_exports mod_anns
    270 
    +      l_exports = combineSrcSpans (getEpTokenSrcSpan open_paren) (getEpTokenSrcSpan close_paren)
    269 271 
         hsmodExports' <- traverse @Maybe
    270 272 
           (\exports ->
    271 
    -        extendHdkA (getEpTokenSrcSpan close_paren) $ do
    273 
    +        extendHdkA l_exports $ do
    272 274 
               exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports
    273 
    -          registerEpTokenHdkA close_paren  -- ) position, not end-of-last-item
    275 
    +          registerEpTokenHdkA close_paren  -- Do not consume comments after the closing parenthesis
    274 276 
               pure exports')
    275 277 
           (hsmodExports mod)
    276 278

  • ghc/GHCi/UI.hs
    ... ... @@ -763,7 +763,7 @@ installInteractiveHomeUnits dflags = do
    763 763 
         -- However, in the case of multiple home units, initialised via @ghci -unit ... -unit ...@, there
    764 764 
         -- are not @-package-db@ arguments in the base 'DynFlags'...
    765 765 
         -- To fix this, we look at the home units and merge their package dbs stacks.
    766 
    -    -- We assume, that many package db stacks look almost identical, and only differ in view elements.
    766 
    +    -- We assume, that many package db stacks look almost identical, and only differ in few unit databases.
    767 767 
         -- Thus, we try to extract a common package db stack (i.e., longest common prefix), and then concat
    768 768 
         -- the rest of the package db stacks. At last, we add the two result package db stacks.
    769 769 
         -- This should work reliably with cabal and stack, but it is hacky.
    ... ... @@ -864,8 +864,14 @@ installInteractiveHomeUnits dflags = do
    864 864 
           pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
    865 865
    866 866 
         concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag]
    867 
    -    concatPackageDbStacksUsingLongestCommonPrefix stacks =
    867 
    +    concatPackageDbStacksUsingLongestCommonPrefix stacks' =
    868 868 
           let
    869 
    +        -- Package DB stacks are accumulated from the cli right to left.
    870 
    +        -- E.g., @-clear-package-db -global-package-db@ is stored as
    871 
    +        -- @[PackageDB GlobalPkgDb, ClearPackageDBs]@.
    872 
    +        -- Hence, we reverse the stacks, before computing the longest common prefix,
    873 
    +        -- otherwise the prefix won't match at all.
    874 
    +        stacks = map List.reverse stacks'
    869 875 
             -- O (m * n)
    870 876 
             -- m ... Number of PackageDBFlag stacks
    871 877 
             -- n ... Size of the stacks
    ... ... @@ -873,8 +879,21 @@ installInteractiveHomeUnits dflags = do
    873 879 
               map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose
    874 880 
             prefix =
    875 881 
               longestCommonPrefix stacks
    882 
    +
    883 
    +        -- We reverse each individual stack segment to maintain the relative order within in a package
    884 
    +        -- db stack.
    885 
    +        -- There should be no 'ClearPackageDBs' in here, otherwise we are going to overwrite
    886 
    +        -- the longest common prefix stacks.
    887 
    +        --
    888 
    +        -- @nubOrd@ can silently change precedence of package db stack merging.
    889 
    +        -- This is not trivially avoidable right now, since multiple home units could simply
    890 
    +        -- have package db stacks that cannot be unified.
    891 
    +        unmergeableStack =
    892 
    +          nubOrd (concatMap (List.reverse . List.drop (length prefix)) stacks)
    876 893 
           in
    877 
    -        prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks)
    894 
    +        -- We reverse the final common package db stack again to match the expectation of 'packageDBFlags' that they are
    895 
    +        -- stord in reverse order.
    896 
    +        unmergeableStack ++ reverse prefix
    878 897
    879 898 
     reportError :: GhciMonad m => GhciCommandMessage -> m ()
    880 899 
     reportError err = do

  • libraries/base/src/GHC/Conc.hs
    ... ... @@ -79,6 +79,9 @@ module GHC.Conc
    79 79 
             , retry
    80 80 
             , orElse
    81 81 
             , throwSTM
    82 
    +#if __GLASGOW_HASKELL__ >= 1002
    83 
    +        , rethrowSTM
    84 
    +#endif
    82 85 
             , catchSTM
    83 86 
             , TVar(..)
    84 87 
             , newTVar

  • libraries/ghc-internal/src/GHC/Internal/STM.hs
    ... ... @@ -5,6 +5,11 @@
    5 5 
     {-# LANGUAGE RankNTypes #-}
    6 6 
     {-# OPTIONS_HADDOCK not-home #-}
    7 7
    8 
    +-- Make unused imports warnings instead of errors, because there are seemingly
    9 
    +-- unused imports of `throw`, `throwIO`, and `rethrowIO`, which are actually
    10 
    +-- used for documentation hyperlinking.
    11 
    +{-# OPTIONS_GHC -Wwarn=unused-imports #-}
    12 
    +
    8 13 
     module GHC.Internal.STM
    9 14 
             (
    10 15 
               -- * the 'STM' monad
    ... ... @@ -13,6 +18,7 @@ module GHC.Internal.STM
    13 18 
             , retry
    14 19 
             , orElse
    15 20 
             , throwSTM
    21 
    +        , rethrowSTM
    16 22 
             , catchSTM
    17 23 
             , unsafeIOToSTM
    18 24 
               -- * TVars
    ... ... @@ -28,7 +34,9 @@ import qualified GHC.Internal.Stack.Types as Rebindable
    28 34 
     import GHC.Internal.Base
    29 35 
     import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException, addExceptionContext)
    30 36 
     import GHC.Internal.Exception.Context (ExceptionAnnotation)
    31 
    -import GHC.Internal.Exception.Type (WhileHandling(..))
    37 
    +import GHC.Internal.Exception.Type (
    38 
    +    WhileHandling(..), ExceptionWithContext, NoBacktrace (NoBacktrace),
    39 
    +  )
    32 40 
     import GHC.Internal.Maybe (Maybe(..))
    33 41 
     import GHC.Internal.Prim (
    34 42 
         RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
    ... ... @@ -37,6 +45,10 @@ import GHC.Internal.Prim (
    37 45 
     import GHC.Internal.Prim.PtrEq (sameTVar#)
    38 46 
     import GHC.Internal.Stack (HasCallStack, withFrozenCallStack)
    39 47
    48 
    +-- Imports for documentation hyperlinking
    49 
    +import GHC.Internal.Exception (throw)
    50 
    +import GHC.Internal.IO (throwIO, rethrowIO)
    51 
    +
    40 52 
     -- TVars are shared memory locations which support atomic memory
    41 53 
     -- transactions.
    42 54
    ... ... @@ -166,7 +178,7 @@ retry = STM $ \s# -> retry# s#
    166 178 
     orElse :: STM a -> STM a -> STM a
    167 179 
     orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
    168 180
    169 
    --- | A variant of 'throw' that can only be used within the 'STM' monad.
    181 
    +-- | The 'STM' analog of 'throwIO'.
    170 182 
     --
    171 183 
     -- Throwing an exception in @STM@ aborts the transaction and propagates the
    172 184 
     -- exception. If the exception is caught via 'catchSTM', only the changes
    ... ... @@ -176,19 +188,8 @@ orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
    176 188 
     -- If the exception is not caught inside of the 'STM', it is re-thrown by
    177 189 
     -- 'atomically', and the entire 'STM' is rolled back.
    178 190 
     --
    179 
    --- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
    180 
    --- two functions are subtly different:
    181 
    ---
    182 
    --- > throw e    `seq` x  ===> throw e
    183 
    --- > throwSTM e `seq` x  ===> x
    184 
    ---
    185 
    --- The first example will cause the exception @e@ to be raised,
    186 
    --- whereas the second one won\'t.  In fact, 'throwSTM' will only cause
    187 
    --- an exception to be raised when it is used within the 'STM' monad.
    188 
    --- The 'throwSTM' variant should be used in preference to 'throw' to
    189 
    --- raise an exception within the 'STM' monad because it guarantees
    190 
    --- ordering with respect to other 'STM' operations, whereas 'throw'
    191 
    --- does not.
    191 
    +-- Note that 'throwSTM' is preferable to 'throw', for the same reasons that
    192 
    +-- 'throwIO' is preferable to 'throw'.
    192 193 
     throwSTM :: (HasCallStack, Exception e) => e -> STM a
    193 194 
     throwSTM e = do
    194 195 
         -- N.B. Typically use of unsafeIOToSTM is very much frowned upon as this
    ... ... @@ -197,7 +198,11 @@ throwSTM e = do
    197 198 
         se <- unsafeIOToSTM (withFrozenCallStack $ toExceptionWithBacktrace e)
    198 199 
         STM $ raiseIO# se
    199 200
    200 
    --- | Exception handling within STM actions.
    201 
    +-- | The 'STM' analog of 'rethrowIO'.
    202 
    +rethrowSTM :: Exception e => ExceptionWithContext e -> STM a
    203 
    +rethrowSTM e = throwSTM (NoBacktrace e)
    204 
    +
    205 
    +-- | The 'STM' analog of 'catch'.
    201 206 
     --
    202 207 
     -- @'catchSTM' m f@ catches any exception thrown by @m@ using 'throwSTM',
    203 208 
     -- using the function @f@ to handle the exception. If an exception is

  • testsuite/tests/ghci/prog-mhu007/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +PKGCONF_FOO=local-foo.package.conf
    6 
    +PKGCONF_BAR=local-bar.package.conf
    7 
    +LOCAL_GHC_PKG_FOO = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_FOO)
    8 
    +LOCAL_GHC_PKG_BAR = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_BAR)
    9 
    +
    10 
    +# Finds both packages in different unit databases
    11 
    +.PHONY: prog-mhu007
    12 
    +prog-mhu007:
    13 
    +	cd testpkg-foo && \
    14 
    +		'$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \
    15 
    +			-v0 -fno-code -fwrite-interface -hidir dist-testpkg-foo-0.1.0.0 -this-unit-id testpkg-foo-0.1.0.0-XXX  \
    16 
    +			-i. Foo
    17 
    +	cd testpkg-bar && \
    18 
    +		'$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \
    19 
    +			-v0 -fno-code -fwrite-interface -hidir dist-testpkg-bar-0.1.0.0 -this-unit-id testpkg-bar-0.1.0.0-XXX  \
    20 
    +			-i. Bar
    21 
    +
    22 
    +	$(LOCAL_GHC_PKG_FOO) init $(PKGCONF_FOO) 2>/dev/null
    23 
    +	$(LOCAL_GHC_PKG_FOO) register --force testpkg-foo/testpkg-foo.pkg 2>/dev/null
    24 
    +	$(LOCAL_GHC_PKG_FOO) hide testpkg-foo
    25 
    +	$(LOCAL_GHC_PKG_FOO) list
    26 
    +
    27 
    +	$(LOCAL_GHC_PKG_BAR) init $(PKGCONF_BAR) 2>/dev/null
    28 
    +	$(LOCAL_GHC_PKG_BAR) register --force testpkg-bar/testpkg-bar.pkg 2>/dev/null
    29 
    +	$(LOCAL_GHC_PKG_BAR) hide testpkg-bar
    30 
    +	$(LOCAL_GHC_PKG_BAR) list
    31 
    +
    32 
    +	'$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \
    33 
    +		-no-user-package-db -fno-code -unit @unitA -unit @unitB < prog-mhu007.script

  • testsuite/tests/ghci/prog-mhu007/a/A.hs
    1 
    +module A where
    2 
    +
    3 
    +import Bar

  • testsuite/tests/ghci/prog-mhu007/all.T
    1 
    +
    2 
    +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB', 'testpkg-bar/', 'testpkg-foo/'])
    3 
    +
    4 
    +test('prog-mhu007',
    5 
    +     [proj_files,
    6 
    +     cmd_prefix('ghciWayFlags=' + config.ghci_way_flags),
    7 
    +     req_interp],
    8 
    +     makefile_test, ['prog-mhu007'])

  • testsuite/tests/ghci/prog-mhu007/b/B.hs
    1 
    +module B where
    2 
    +
    3 
    +import Foo

  • testsuite/tests/ghci/prog-mhu007/prog-mhu007.script
    1 
    +:m + A B
    2 
    +"Loaded A and B"
    3 
    +import Foo
    4 
    +import Bar
    5 
    +"Loaded dependencies Foo and Bar"

  • testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout
    1 
    +Reading package info from "testpkg-foo/testpkg-foo.pkg" ... done.
    2 
    +local-foo.package.conf
    3 
    +    (testpkg-foo-0.1.0.0)
    4 
    +
    5 
    +Reading package info from "testpkg-bar/testpkg-bar.pkg" ... done.
    6 
    +local-bar.package.conf
    7 
    +    (testpkg-bar-0.1.0.0)
    8 
    +
    9 
    +"Loaded A and B"
    10 
    +"Loaded dependencies Foo and Bar"

  • testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs
    1 
    +module Bar where

  • testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg
    1 
    +name: testpkg-bar
    2 
    +version: 0.1.0.0
    3 
    +id: testpkg-bar-0.1.0.0-XXX
    4 
    +key: testpkg-bar-0.1.0.0-XXX
    5 
    +exposed: True
    6 
    +exposed-modules: Bar
    7 
    +hidden-modules:
    8 
    +import-dirs: ${pkgroot}/testpkg-bar/dist-testpkg-bar-0.1.0.0
    9 
    +library-dirs:
    10 
    +include-dirs:
    11 
    +hs-libraries:

  • testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs
    1 
    +module Foo where

  • testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg
    1 
    +name: testpkg-foo
    2 
    +version: 0.1.0.0
    3 
    +id: testpkg-foo-0.1.0.0-XXX
    4 
    +key: testpkg-foo-0.1.0.0-XXX
    5 
    +exposed: True
    6 
    +exposed-modules: Foo
    7 
    +hidden-modules:
    8 
    +import-dirs: ${pkgroot}/testpkg-foo/dist-testpkg-foo-0.1.0.0
    9 
    +library-dirs:
    10 
    +include-dirs:
    11 
    +hs-libraries:

  • testsuite/tests/ghci/prog-mhu007/unitA
    1 
    +-i
    2 
    +-ia/
    3 
    +A
    4 
    +-this-unit-id a-0.0.0
    5 
    +-this-package-name a
    6 
    +-clear-package-db
    7 
    +-global-package-db
    8 
    +-no-user-package-db
    9 
    +-package-db local-bar.package.conf
    10 
    +-package base
    11 
    +-package-id testpkg-bar-0.1.0.0-XXX

  • testsuite/tests/ghci/prog-mhu007/unitB
    1 
    +-i
    2 
    +-ib/
    3 
    +B
    4 
    +-this-unit-id b-0.0.0
    5 
    +-this-package-name b
    6 
    +-clear-package-db
    7 
    +-global-package-db
    8 
    +-no-user-package-db
    9 
    +-package-db local-foo.package.conf
    10 
    +-package base
    11 
    +-package-id testpkg-foo-0.1.0.0-XXX

  • testsuite/tests/printer/Haddock1.hs
    1 
    +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-}
    2 
    +-- | Haddock comment,
    3 
    +-- coming before the module
    4 
    +module Haddock1 (
    5 
    +
    6 
    +        -- | This is some inline documentation in the export list
    7 
    +        --
    8 
    +        -- > a code block using bird-tracks
    9 
    +        -- > each line must begin with > (which isn't significant unless it
    10 
    +        -- > is at the beginning of the line).
    11 
    +        f
    12 
    +
    13 
    +        {-| nested-style doc comments -}
    14 
    +        , g
    15 
    +
    16 
    +        -- * A section
    17 
    +        -- and without an intervening comma:
    18 
    +        -- ** A subsection
    19 
    +   ) where
    20 
    +
    21 
    +-- | Haddock before imports
    22 
    +import Data.List
    23 
    +
    24 
    +-- | Haddock before decl
    25 
    +f = undefined
    26 
    +g = undefined
    27 
    +
    28 
    +-- | This comment applies to the /following/ declaration
    29 
    +-- and it continues until the next non-comment line
    30 
    +data T a b
    31 
    + = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor
    32 
    + | -- | This comment describes the 'B' constructor
    33 
    +   B (T a b, T Int Float) -- ^ abcd
    34 
    +
    35 
    +-- | An abstract data declaration
    36 
    +data T2 a b = T2 a b

  • testsuite/tests/printer/Makefile
    ... ... @@ -932,3 +932,8 @@ PprModifiers:
    932 932 
     PprQualifiedStrings:
    933 933 
     	$(CHECK_PPR)   $(LIBDIR) PprQualifiedStrings.hs
    934 934 
     	$(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs
    935 
    +
    936 
    +.PHONY: Haddock1
    937 
    +Haddock1:
    938 
    +	# $(CHECK_PPR)   $(LIBDIR) Haddock1.hs
    939 
    +	$(CHECK_EXACT) $(LIBDIR) Haddock1.hs

  • testsuite/tests/printer/all.T
    ... ... @@ -223,3 +223,4 @@ test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLev
    223 223 
     test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults'])
    224 224 
     test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers'])
    225 225 
     test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings'])
    226 
    +test('Haddock1', [ignore_stderr,req_ppr_deps], makefile_test, ['Haddock1'])

    • —
    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/b6bc865eb74325ebe4dd4c82eb1d020a2a5e58e2...07be45d391d4bf91805206ddb19a257dac2c3cee at 1787877337