22 Jul '26
Rodrigo Mesquita pushed new branch wip/romes/27514 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/27514
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Switch to the `assert` from `GHC.Utils.Panic.Plain`
by Wolfgang Jeltsch (＠jeltsch) 22 Jul '26
by Wolfgang Jeltsch (＠jeltsch) 22 Jul '26
22 Jul '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC
Commits:
f2f5df19 by Wolfgang Jeltsch at 2026-07-22T16:13:17+03:00
Switch to the `assert` from `GHC.Utils.Panic.Plain`
- - - - -
1 changed file:
- compiler/GHC/ByteCode/Show.hs
Changes:
=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -7,7 +7,6 @@ module GHC.ByteCode.Show (showByteCode) where
import Prelude ((+), (-), Integral, div)
import Control.Arrow ((>>>))
-import Control.Exception (assert)
import Data.Eq ((==))
import Data.Ord ((>=))
import Data.Bits (FiniteBits, finiteBitSize)
@@ -38,6 +37,7 @@ import GHC.Types.Name.Occurrence (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId (..))
import GHC.Types.SptEntry (SptEntry (..))
import GHC.Types.Error (MessageClass (MCDump))
+import GHC.Utils.Panic.Plain (assert)
import GHC.Utils.Logger (Logger, logMsg)
import GHC.Utils.Binary (BinSrcSpan (..))
import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString, utf8DecodeByteString)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2f5df1911658516bb5480facdbad5f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2f5df1911658516bb5480facdbad5f…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/T27521] ci: Reduce lint job setup costs
by Simon Jakobi (＠sjakobi2) 22 Jul '26
by Simon Jakobi (＠sjakobi2) 22 Jul '26
22 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/T27521 at Glasgow Haskell Compiler / GHC
Commits:
923cb5f5 by Simon Jakobi at 2026-07-22T14:52:00+02:00
ci: Reduce lint job setup costs
Avoid fetching unnecessary history and submodules for lightweight lint
jobs. Run changelog validation without Hadrian.
Trust runner-owned checkouts so Git commands work when the container
user differs from the checkout owner, e.g. in the lint-author job.
Closes #27521.
Assisted-by: gpt-5.6-sol via Codex CLI
- - - - -
1 changed file:
- .gitlab-ci.yml
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -134,6 +134,9 @@ workflow:
stage: tool-lint
tags:
- lint
+ before_script:
+ # The checkout may be owned by the runner rather than the container user.
+ - git config --global --add safe.directory "$CI_PROJECT_DIR"
rules:
- *drafts-can-fail-lint
- when: always
@@ -251,18 +254,21 @@ ghc-linters:
lint-changelog:
stage: tool-lint
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
- extends: .lint-params
+ extends: .lint
variables:
- BUILD_FLAVOUR: default
CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID"
+ GIT_DEPTH: 1
+ GIT_SUBMODULE_STRATEGY: none
+ before_script:
+ - export PATH="/opt/toolchain/bin:$PATH"
+ - git config --global --add safe.directory "$CI_PROJECT_DIR"
script:
# Cancel the job if there is a no-changelog label
- |
[[ ",${CI_MERGE_REQUEST_LABELS}," == *",no-changelog,"* ]] && exit 0
# Check that the MR adds at least one changelog entry
- - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME"
- - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
- - added=$(git diff --name-only --diff-filter=A "$base..$CI_COMMIT_SHA" -- 'changelog.d/' | grep -v '^changelog.d/config$' || true)
+ - git fetch --depth=1 "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_DIFF_BASE_SHA"
+ - added=$(git diff --name-only --diff-filter=A "$CI_MERGE_REQUEST_DIFF_BASE_SHA..$CI_COMMIT_SHA" -- 'changelog.d/' | grep -v '^changelog.d/config$' || true)
- |
if [ -z "$added" ]; then
echo "ERROR: No changelog entry found in changelog.d/"
@@ -271,9 +277,23 @@ lint-changelog:
exit 1
fi
- echo "Found changelog entries:" $added
- # Build changelog-d and validate all entries (checks required fields, section names, MR number)
- - .gitlab/ci.sh configure
- - .gitlab/ci.sh run_hadrian test --test-root-dirs="testsuite/tests/linters" --only=changelog-d
+ # Build changelog-d with the bootstrap compiler and validate all entries
+ # (checks required fields, section names, and the MR number).
+ - |
+ changelog_build_dir="$(mktemp -d)"
+ ghc -Werror \
+ -package base \
+ -package bytestring \
+ -package Cabal-syntax \
+ -package containers \
+ -package directory \
+ -package filepath \
+ -package pretty \
+ -outputdir "$changelog_build_dir" \
+ -o "$changelog_build_dir/changelog-d" \
+ utils/changelog-d/ChangelogD.hs
+ "$changelog_build_dir/changelog-d" \
+ changelog.d/ --validate --expect-mr "$CHANGELOG_EXPECT_MR"
dependencies: []
rules:
- if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/'
@@ -285,6 +305,9 @@ lint-changelog:
lint-linters:
image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
extends: .lint
+ variables:
+ GIT_DEPTH: 1
+ GIT_SUBMODULE_STRATEGY: none
script:
- mypy testsuite/tests/linters/regex-linters/*.py
dependencies: []
@@ -293,6 +316,9 @@ lint-linters:
lint-testsuite:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
extends: .lint
+ variables:
+ GIT_DEPTH: 1
+ GIT_SUBMODULE_STRATEGY: none
script:
- make -Ctestsuite list_broken TEST_HC=$GHC
dependencies: []
@@ -301,6 +327,9 @@ lint-testsuite:
typecheck-testsuite:
image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
extends: .lint
+ variables:
+ GIT_DEPTH: 1
+ GIT_SUBMODULE_STRATEGY: none
script:
- mypy testsuite/driver/runtests.py
dependencies: []
@@ -323,14 +352,13 @@ typecheck-testsuite:
- _build/stageBoot/bin/lint-submodule-refs . $(git rev-list $base..$CI_COMMIT_SHA)
dependencies: []
-# We allow the submodule checker to fail when run on merge requests (to
-# accommodate, e.g., haddock changes not yet upstream) but not on `master` or
-# Marge jobs.
+# Check that commits in an MR were not authored with the identity that CI uses
+# when it needs to create commits itself. This only needs Git history.
lint-author:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV"
- extends: .lint-params
+ extends: .lint
variables:
- BUILD_FLAVOUR: default
+ GIT_SUBMODULE_STRATEGY: none
script:
- git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
- base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/923cb5f55cad42720742b7eccfb23dc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/923cb5f55cad42720742b7eccfb23dc…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/27532] UniqueDFM: alter should preserve insertion order
by Zubin (＠wz1000) 22 Jul '26
by Zubin (＠wz1000) 22 Jul '26
22 Jul '26
Zubin pushed to branch wip/27532 at Glasgow Haskell Compiler / GHC
Commits:
498f5057 by Zubin Duggal at 2026-07-22T18:11:53+05:30
UniqueDFM: alter should preserve insertion order
Before it always inserting new elements at the end.
This is problematic because instances get inserted into the map with
`alterF`, which can change ordering of how instances are printed
with `:info` depending on the order in which we consult interfaces
I expect `alter id k = id` and `alter (fmap f) k = adjust f k`. Moving keys to
the end breaks that (`adjust` already preserves position).
Fixes #27532
- - - - -
28 changed files:
- + changelog.d/27532
- compiler/GHC/Types/Unique/DFM.hs
- testsuite/tests/ghci/T16793/T16793.stdout
- testsuite/tests/ghci/T18060/T18060.stdout
- + testsuite/tests/ghci/T27532/Makefile
- + testsuite/tests/ghci/T27532/T27532.stdout
- + testsuite/tests/ghci/T27532/T27532j4.stdout
- + testsuite/tests/ghci/T27532/a.script
- + testsuite/tests/ghci/T27532/all.T
- + testsuite/tests/ghci/T27532/b.script
- + testsuite/tests/ghci/T27532/genT27532Modules
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T4175.stdout
- testsuite/tests/ghci/scripts/T8469.stdout
- testsuite/tests/ghci/scripts/T8535.stdout
- testsuite/tests/ghci/scripts/T9881.stdout
- testsuite/tests/ghci/scripts/ghci020.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/ghci/should_run/T10145.stdout
- testsuite/tests/ghci/should_run/T18594.stdout
- testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/roles/should_compile/T8958.stderr
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- testsuite/tests/typecheck/should_fail/T5300.stderr
Changes:
=====================================
changelog.d/27532
=====================================
@@ -0,0 +1,9 @@
+section: compiler
+synopsis: Make instance ordering in :info output stable
+description:
+ Updating an existing key in a UniqDFM no longer moves it to the end of the
+ iteration order. Previously the order of instances printed by :info depended
+ on the order in which interfaces were loaded, so it could change after
+ unrelated imports and differ between compiler builds.
+mrs: !16385
+issues: #27532
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -91,6 +91,23 @@ import qualified GHC.Data.Word64Set as W
-- If the client of the map performs operations on the map in deterministic
-- order then `udfmToList` returns them in deterministic order.
--
+-- More precisely, the order is insertion order. A key takes its position
+-- when it is added to the map after being absent. Operations that modify
+-- the value at an existing key (addToUDFM, adjustUDFM, alterUDFM, ...) do
+-- not move it. Deleting a key and adding it back moves it to the end.
+--
+-- In particular the order does not depend on how existing entries were
+-- updated. This makes alterUDFM consistent with addToUDFM and adjustUDFM,
+-- so that for example alterUDFM id k = id.
+--
+-- It also keeps the order stable for maps whose entries are updated many
+-- times. The instance environments are the main example: inserting an
+-- instance updates the entry of its class in a DNameEnv, and when updates
+-- moved keys to the end the order of instances shown by :info depended on
+-- the order in which interfaces happened to be loaded (#27532). Now a
+-- class keeps its place once its first instance is added, so loading
+-- further interfaces cannot change the order.
+--
-- There is an implementation cost: each element is given a serial number
-- as it is added, and `udfmToList` sorts its result by this serial
-- number. So you should only use `UniqDFM` if you need the deterministic
@@ -108,7 +125,8 @@ import qualified GHC.Data.Word64Set as W
--
-- There's more than one way to implement this. The implementation here tags
-- every value with the insertion time that can later be used to sort the
--- values when asked to convert to a list.
+-- values when asked to convert to a list. Updating an existing key keeps
+-- the old tag.
--
-- An alternative would be to have
--
@@ -169,11 +187,13 @@ emptyUDFM = UDFM M.empty 0
unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt
unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1
--- The new binding always goes to the right of existing ones
+-- A new key goes to the right of existing ones
+-- Overwriting an existing key keeps its position in the iteration order
addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
--- The new binding always goes to the right of existing ones
+-- A new key goes to the right of existing ones
+-- Overwriting an existing key keeps its position in the iteration order
addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
addToUDFM_Directly (UDFM m i) u v
= UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
@@ -435,7 +455,8 @@ adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i
-- | The expression (@'alterUDFM' f map k@) alters value x at k, or absence
-- thereof. 'alterUDFM' can be used to insert, delete, or update a value in
-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
--- more efficient.
+-- more efficient. Updating an existing key keeps its position in the
+-- deterministic iteration order.
--
-- 'alterUDFM' is non-strict in @k@.
alterUDFM
@@ -447,16 +468,16 @@ alterUDFM
alterUDFM f (UDFM m i) k =
UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)
where
- alterf Nothing = inject $ f Nothing
- alterf (Just (TaggedVal v _)) = inject $ f (Just v)
- inject Nothing = Nothing
- inject (Just v) = Just $ TaggedVal v i
+ alterf Nothing = inject i $ f Nothing
+ alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v)
+ inject _ Nothing = Nothing
+ inject tag (Just v) = Just $ TaggedVal v tag
-- | The expression (@'upsertUDFM' f map k@) updates the value at @k@ or inserts
-- a new value if @k@ is absent.
--
--- Like 'alterUDFM', updating an existing entry assigns it the current tag, so it
--- becomes the newest element in deterministic iteration order.
+-- Updating an existing entry keeps its original tag, so its position in
+-- deterministic iteration order is unchanged and does not depend on update order.
upsertUDFM
:: Uniquable key
=> (Maybe elt -> elt) -- ^ How to adjust the element
@@ -467,13 +488,14 @@ upsertUDFM f (UDFM m i) k =
UDFM (MS.upsert upsertf (getKey $ getUnique k) m) (i + 1)
where
upsertf Nothing = TaggedVal (f Nothing) i
- upsertf (Just (TaggedVal v _)) = TaggedVal (f (Just v)) i
+ upsertf (Just (TaggedVal v old_i)) = TaggedVal (f (Just v)) old_i
-- | The expression (@'alterUDFM_L' f map k@) alters value @x@ at @k@, or absence
-- thereof and returns the new element at @k@ if there is any.
-- 'alterUDFM_L' can be used to insert, delete, or update a value in
-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
--- more efficient.
+-- more efficient. Updating an existing key keeps its position in the
+-- deterministic iteration order.
--
-- Note, 'alterUDFM_L' is strict in @k@.
alterUDFM_L
@@ -489,10 +511,10 @@ alterUDFM_L f (UDFM m i) k =
(fmap taggedFst mElt, UDFM udfm (i + 1))
where
alterf :: Maybe (TaggedVal elt) -> (Maybe (TaggedVal elt))
- alterf Nothing = inject $ f Nothing
- alterf (Just (TaggedVal v _)) = inject $ f (Just v)
- inject Nothing = Nothing
- inject (Just v) = Just $ TaggedVal v i
+ alterf Nothing = inject i $ f Nothing
+ alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v)
+ inject _ Nothing = Nothing
+ inject tag (Just v) = Just $ TaggedVal v tag
-- | Map a function over every value in a UniqDFM
mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
=====================================
testsuite/tests/ghci/T16793/T16793.stdout
=====================================
@@ -1,9 +1,9 @@
-instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Read Int -- Defined in ‘GHC.Internal.Read’
+instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
=====================================
testsuite/tests/ghci/T18060/T18060.stdout
=====================================
@@ -2,13 +2,13 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
type (~) :: forall k. k -> k -> Constraint
class (a ~ b) => (~) a b
-- Defined in ‘GHC.Internal.Types’
=====================================
testsuite/tests/ghci/T27532/Makefile
=====================================
@@ -0,0 +1,23 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T27532
+T27532:
+ '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < a.script 2>/dev/null | grep '^instance' > direct.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < b.script 2>/dev/null | grep '^instance' > afterimport.txt
+ diff direct.txt afterimport.txt || true
+
+.PHONY: T27532j4
+T27532j4:
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_1.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_2.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_3.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_4.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_5.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_6.txt
+ diff j4_1.txt j4_2.txt || true
+ diff j4_1.txt j4_3.txt || true
+ diff j4_1.txt j4_4.txt || true
+ diff j4_1.txt j4_5.txt || true
+ diff j4_1.txt j4_6.txt || true
=====================================
testsuite/tests/ghci/T27532/T27532.stdout
=====================================
=====================================
testsuite/tests/ghci/T27532/T27532j4.stdout
=====================================
=====================================
testsuite/tests/ghci/T27532/a.script
=====================================
@@ -0,0 +1 @@
+:info ()
=====================================
testsuite/tests/ghci/T27532/all.T
=====================================
@@ -0,0 +1,9 @@
+test('T27532',
+ [extra_files(['a.script', 'b.script'])],
+ makefile_test, ['T27532'])
+
+test('T27532j4',
+ [pre_cmd('./genT27532Modules'),
+ extra_files(['genT27532Modules']),
+ req_ghc_smp],
+ makefile_test, ['T27532j4'])
=====================================
testsuite/tests/ghci/T27532/b.script
=====================================
@@ -0,0 +1,3 @@
+import Data.Ratio
+_ <- return $! compare (1 % 2 :: Rational) (2 % 3)
+:info ()
=====================================
testsuite/tests/ghci/T27532/genT27532Modules
=====================================
@@ -0,0 +1,33 @@
+#!/usr/bin/env bash
+# Generate modules that each import and use a distinct instance-heavy module,
+# so a parallel :load races many interface loads against each other.
+gen() { f=$1; shift; printf '%s\n' "module ${f%.hs} where" "$@" > "$f"; }
+gen M01.hs "import Data.Ratio" "v :: Rational" "v = 1 % 2" "s = show v"
+gen M02.hs "import Data.Complex" "v :: Complex Double" "v = 1" "s = show v"
+gen M03.hs "import Data.Fixed" "v :: Fixed E2" "v = 1" "s = show v"
+gen M04.hs "import Foreign.C.Types" "v :: CInt" "v = 1" "s = show v" "b :: CInt" "b = maxBound"
+gen M05.hs "import System.Posix.Types" "v :: CPid" "v = 1" "s = show v"
+gen M06.hs "import Data.Version" "s = showVersion (makeVersion [1,2])"
+gen M07.hs "import Control.Exception" "s = show DivideByZero" "t = show StackOverflow"
+gen M08.hs "import Data.Dynamic" "s = show (toDyn ())"
+gen M09.hs "import Type.Reflection" "s = show (typeRep :: TypeRep Bool)"
+gen M10.hs "import Data.List.NonEmpty (NonEmpty(..))" "s = show (1 :| ([2,3] :: [Int]))"
+gen M11.hs "import Data.Ord" "s = show (Down (3 :: Int))" "c = compare (Down 1) (Down (2 :: Int))"
+gen M12.hs "import Data.Functor.Identity" "s = show (Identity (1 :: Int))"
+gen M13.hs "import Data.Functor.Const" "s = show (Const (1 :: Int) :: Const Int Bool)"
+gen M14.hs "import Data.Functor.Compose" "s = show (Compose (Just (Just (1 :: Int))))"
+gen M15.hs "import Data.Functor.Product" "s = show (Pair (Just (1 :: Int)) (Just (2 :: Int)))"
+gen M16.hs "import Data.Functor.Sum" "s = show (InL (Just (1 :: Int)) :: Sum Maybe Maybe Int)"
+gen M17.hs "import Data.Monoid" "s = show (Sum (1 :: Int) <> Sum 2)" "a = show (All True)"
+gen M18.hs "import Data.Semigroup" "s = show (Min (1 :: Int) <> Min 2)"
+gen M19.hs "import Text.Printf" "s = printf \"%d\" (1 :: Int) :: String"
+gen M20.hs "import Numeric.Natural" "s = show (5 :: Natural)" "v :: Natural" "v = 2 + 3"
+gen M21.hs "import Foreign.Ptr" "s = show nullPtr"
+gen M22.hs "import System.IO" "s = show stdout" "e = show stderr"
+gen M23.hs "import Data.IORef" "v :: IO (IORef Int)" "v = newIORef 1"
+gen M24.hs "import Data.Bits" "v = xor (1 :: Int) 2" "s = show v"
+for f in M??.hs; do
+ n=${f#M}; n=${n%.hs}
+ m=$(printf 'M%02d' $((10#$n + 24)))
+ sed "s/module M$n/module $m/" "$f" > "$m.hs"
+done
=====================================
testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
=====================================
@@ -1,13 +1,13 @@
type Unit :: *
data Unit = ()
-- Defined in ‘GHC.Internal.Tuple’
+instance Eq Unit -- Defined in ‘GHC.Internal.Classes’
instance Monoid Unit -- Defined in ‘GHC.Internal.Base’
+instance Ord Unit -- Defined in ‘GHC.Internal.Classes’
instance Semigroup Unit -- Defined in ‘GHC.Internal.Base’
-instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’
instance Read Unit -- Defined in ‘GHC.Internal.Read’
+instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’
instance Enum Unit -- Defined in ‘GHC.Internal.Enum’
-instance Eq Unit -- Defined in ‘GHC.Internal.Classes’
-instance Ord Unit -- Defined in ‘GHC.Internal.Classes’
instance Show Unit -- Defined in ‘GHC.Internal.Show’
type Unit# :: GHC.Internal.Types.ZeroBitType
data Unit# = (##)
@@ -15,23 +15,23 @@ data Unit# = (##)
type Solo :: * -> *
data Solo a = MkSolo a
-- Defined in ‘GHC.Internal.Tuple’
-instance Traversable Solo
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance Applicative Solo -- Defined in ‘GHC.Internal.Base’
-instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’
instance Functor Solo -- Defined in ‘GHC.Internal.Base’
instance Monad Solo -- Defined in ‘GHC.Internal.Base’
+instance Monoid a => Monoid (Solo a)
+ -- Defined in ‘GHC.Internal.Base’
+instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’
+instance Semigroup a => Semigroup (Solo a)
+ -- Defined in ‘GHC.Internal.Base’
instance Read a => Read (Solo a) -- Defined in ‘GHC.Internal.Read’
instance Bounded a => Bounded (Solo a)
-- Defined in ‘GHC.Internal.Enum’
instance Enum a => Enum (Solo a) -- Defined in ‘GHC.Internal.Enum’
-instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’
instance Show a => Show (Solo a) -- Defined in ‘GHC.Internal.Show’
-instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’
-instance Monoid a => Monoid (Solo a)
- -- Defined in ‘GHC.Internal.Base’
-instance Semigroup a => Semigroup (Solo a)
- -- Defined in ‘GHC.Internal.Base’
+instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Solo
+ -- Defined in ‘GHC.Internal.Data.Traversable’
() :: Unit
(##) :: Unit#
( ) :: Unit
@@ -39,29 +39,29 @@ instance Semigroup a => Semigroup (Solo a)
type Tuple2 :: * -> * -> *
data Tuple2 a b = (,) a b
-- Defined in ‘GHC.Internal.Tuple’
-instance Traversable (Tuple2 a)
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance Monoid a => Applicative (Tuple2 a)
-- Defined in ‘GHC.Internal.Base’
-instance Foldable (Tuple2 a)
- -- Defined in ‘GHC.Internal.Data.Foldable’
+instance (Eq a, Eq b) => Eq (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Classes’
instance Functor (Tuple2 a) -- Defined in ‘GHC.Internal.Base’
instance Monoid a => Monad (Tuple2 a)
-- Defined in ‘GHC.Internal.Base’
instance (Monoid a, Monoid b) => Monoid (Tuple2 a b)
-- Defined in ‘GHC.Internal.Base’
-instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Base’
-instance (Bounded a, Bounded b) => Bounded (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Enum’
instance (Ord a, Ord b) => Ord (Tuple2 a b)
-- Defined in ‘GHC.Internal.Classes’
+instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Base’
instance (Read a, Read b) => Read (Tuple2 a b)
-- Defined in ‘GHC.Internal.Read’
+instance (Bounded a, Bounded b) => Bounded (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Enum’
instance (Show a, Show b) => Show (Tuple2 a b)
-- Defined in ‘GHC.Internal.Show’
-instance (Eq a, Eq b) => Eq (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Classes’
+instance Foldable (Tuple2 a)
+ -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable (Tuple2 a)
+ -- Defined in ‘GHC.Internal.Data.Traversable’
type Tuple2# :: *
-> *
-> TYPE
=====================================
testsuite/tests/ghci/scripts/T4175.stdout
=====================================
@@ -26,52 +26,52 @@ type Unit :: *
data Unit = ()
-- Defined in ‘GHC.Internal.Tuple’
instance [safe] C () -- Defined at T4175.hs:22:10
+instance Eq () -- Defined in ‘GHC.Internal.Classes’
instance Monoid () -- Defined in ‘GHC.Internal.Base’
+instance Ord () -- Defined in ‘GHC.Internal.Classes’
instance Semigroup () -- Defined in ‘GHC.Internal.Base’
+instance Read () -- Defined in ‘GHC.Internal.Read’
instance Bounded () -- Defined in ‘GHC.Internal.Enum’
instance Enum () -- Defined in ‘GHC.Internal.Enum’
-instance Ord () -- Defined in ‘GHC.Internal.Classes’
-instance Read () -- Defined in ‘GHC.Internal.Read’
instance Show () -- Defined in ‘GHC.Internal.Show’
-instance Eq () -- Defined in ‘GHC.Internal.Classes’
data instance B () = MkB -- Defined at T4175.hs:14:15
type instance D Int () = String -- Defined at T4175.hs:20:10
type instance D () () = Bool -- Defined at T4175.hs:23:10
type Maybe :: * -> *
data Maybe a = Nothing | Just a
-- Defined in ‘GHC.Internal.Maybe’
-instance Traversable Maybe
- -- Defined in ‘GHC.Internal.Data.Traversable’
-instance MonadFail Maybe
- -- Defined in ‘GHC.Internal.Control.Monad.Fail’
instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’
-instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance [safe] Eq a => Eq (Maybe a)
+ -- Defined in ‘GHC.Internal.Maybe’
instance Functor Maybe -- Defined in ‘GHC.Internal.Base’
instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
instance Semigroup a => Monoid (Maybe a)
-- Defined in ‘GHC.Internal.Base’
-instance Semigroup a => Semigroup (Maybe a)
- -- Defined in ‘GHC.Internal.Base’
instance [safe] Ord a => Ord (Maybe a)
-- Defined in ‘GHC.Internal.Maybe’
+instance Semigroup a => Semigroup (Maybe a)
+ -- Defined in ‘GHC.Internal.Base’
instance Read a => Read (Maybe a) -- Defined in ‘GHC.Internal.Read’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Internal.Show’
-instance [safe] Eq a => Eq (Maybe a)
- -- Defined in ‘GHC.Internal.Maybe’
+instance MonadFail Maybe
+ -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Maybe
+ -- Defined in ‘GHC.Internal.Data.Traversable’
type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15
type Int :: *
data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int#
-- Defined in ‘GHC.Internal.Types’
instance [safe] C Int -- Defined at T4175.hs:19:10
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
+instance Read Int -- Defined in ‘GHC.Internal.Read’
instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
-instance Read Int -- Defined in ‘GHC.Internal.Read’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
type instance A Int Int = () -- Defined at T4175.hs:9:15
type instance D Int () = String -- Defined at T4175.hs:20:10
type Z :: * -> Constraint
=====================================
testsuite/tests/ghci/scripts/T8469.stdout
=====================================
@@ -1,12 +1,12 @@
type Int :: *
data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int#
-- Defined in ‘GHC.Internal.Types’
-instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Read Int -- Defined in ‘GHC.Internal.Read’
+instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
=====================================
testsuite/tests/ghci/scripts/T8535.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/scripts/T9881.stdout
=====================================
@@ -4,16 +4,16 @@ data Data.ByteString.Lazy.ByteString
| Data.ByteString.Lazy.Internal.Chunk {-# UNPACK #-} !StrictByteString
Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
+instance Eq Data.ByteString.Lazy.ByteString
+ -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Monoid Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
+instance Ord Data.ByteString.Lazy.ByteString
+ -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Semigroup Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
instance Read Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
-instance Eq Data.ByteString.Lazy.ByteString
- -- Defined in ‘Data.ByteString.Lazy.Internal’
-instance Ord Data.ByteString.Lazy.ByteString
- -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Show Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
@@ -23,15 +23,15 @@ data Data.ByteString.ByteString
GHC.Internal.Word.Word8)
{-# UNPACK #-} !Int
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
+instance Eq Data.ByteString.ByteString
+ -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Monoid Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
+instance Ord Data.ByteString.ByteString
+ -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Semigroup Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Read Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
-instance Eq Data.ByteString.ByteString
- -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
-instance Ord Data.ByteString.ByteString
- -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Show Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
=====================================
testsuite/tests/ghci/scripts/ghci020.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -1,52 +1,52 @@
-instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
-instance Traversable Maybe
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance GHC.Internal.Base.Alternative Maybe
-- Defined in ‘GHC.Internal.Base’
instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’
instance Functor Maybe -- Defined in ‘GHC.Internal.Base’
-instance MonadFail Maybe
- -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.MonadPlus Maybe
-- Defined in ‘GHC.Internal.Base’
-instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
+instance MonadFail Maybe
+ -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Maybe
+ -- Defined in ‘GHC.Internal.Data.Traversable’
+instance [safe] Eq w => Eq (Maybe w)
+ -- Defined in ‘GHC.Internal.Maybe’
instance Semigroup w => Monoid (Maybe w)
-- Defined in ‘GHC.Internal.Base’
-instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’
-instance Semigroup w => Semigroup (Maybe w)
- -- Defined in ‘GHC.Internal.Base’
instance [safe] Ord w => Ord (Maybe w)
-- Defined in ‘GHC.Internal.Maybe’
+instance Semigroup w => Semigroup (Maybe w)
+ -- Defined in ‘GHC.Internal.Base’
+instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’
instance Show w => Show (Maybe w) -- Defined in ‘GHC.Internal.Show’
-instance [safe] Eq w => Eq (Maybe w)
- -- Defined in ‘GHC.Internal.Maybe’
-instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
-instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’
-instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
instance Eq w => Eq [w] -- Defined in ‘GHC.Internal.Classes’
instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
+instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’
instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
+instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
+instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
instance [safe] MyShow w => MyShow [w]
-- Defined at ghci064.hs:8:10
instance Monoid [T] -- Defined in ‘GHC.Internal.Base’
instance Semigroup [T] -- Defined in ‘GHC.Internal.Base’
instance [safe] MyShow [T] -- Defined at ghci064.hs:16:10
instance [safe] MyShow [T] -- Defined at ghci064.hs:8:10
-instance GHC.Internal.Foreign.Storable.Storable Bool
- -- Defined in ‘GHC.Internal.Foreign.Storable’
-instance GHC.Internal.Bits.Bits Bool
- -- Defined in ‘GHC.Internal.Bits’
+instance Eq Bool -- Defined in ‘GHC.Internal.Classes’
+instance Ord Bool -- Defined in ‘GHC.Internal.Classes’
+instance Read Bool -- Defined in ‘GHC.Internal.Read’
instance Bounded Bool -- Defined in ‘GHC.Internal.Enum’
instance Enum Bool -- Defined in ‘GHC.Internal.Enum’
+instance Show Bool -- Defined in ‘GHC.Internal.Show’
+instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’
+instance GHC.Internal.Bits.Bits Bool
+ -- Defined in ‘GHC.Internal.Bits’
instance GHC.Internal.Bits.FiniteBits Bool
-- Defined in ‘GHC.Internal.Bits’
-instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’
-instance Ord Bool -- Defined in ‘GHC.Internal.Classes’
-instance Read Bool -- Defined in ‘GHC.Internal.Read’
-instance Show Bool -- Defined in ‘GHC.Internal.Show’
-instance Eq Bool -- Defined in ‘GHC.Internal.Classes’
-instance Traversable ((,) Int)
- -- Defined in ‘GHC.Internal.Data.Traversable’
+instance GHC.Internal.Foreign.Storable.Storable Bool
+ -- Defined in ‘GHC.Internal.Foreign.Storable’
+instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’
instance Foldable ((,) Int)
-- Defined in ‘GHC.Internal.Data.Foldable’
-instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’
+instance Traversable ((,) Int)
+ -- Defined in ‘GHC.Internal.Data.Traversable’
=====================================
testsuite/tests/ghci/should_run/T10145.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/should_run/T18594.stdout
=====================================
@@ -2,13 +2,13 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
type Constraint :: *
type Constraint = CONSTRAINT LiftedRep
-- Defined in ‘GHC.Internal.Types’
=====================================
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
=====================================
@@ -21,7 +21,7 @@ TYPE SIGNATURES
(>>) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
(>>=) ::
forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
- (^) :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
+ (^) :: forall {a} {b}. (Num a, Integral b) => a -> b -> a
(^^) :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
abs :: forall {a}. Num a => a -> a
acos :: forall {a}. Floating a => a -> a
@@ -236,4 +236,4 @@ TYPE SIGNATURES
(a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
(||) :: Bool -> Bool -> Bool
Dependent modules: []
-Dependent packages: [(normal, base-4.21.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
=====================================
testsuite/tests/roles/should_compile/Roles14.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE CONSTRUCTORS
class C2{1} :: * -> Constraint
roles representational
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles12.$tcC2 [InlPrag=[~]]
@@ -15,14 +15,14 @@ Roles12.$tc'C:C2 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
7087988437584478859#Word64 11477953550142401435#Word64
Roles12.$trModule (GHC.Internal.Types.TrNameS "'C:C2"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep [])
Roles12.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/Roles3.stderr
=====================================
@@ -16,7 +16,7 @@ TYPE CONSTRUCTORS
roles nominal
type synonym Syn2{1} :: * -> *
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles3.$tcC4 [InlPrag=[~]]
@@ -43,15 +43,6 @@ Roles3.$tc'C:C1 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
4508088879886988796#Word64 13962145553903222779#Word64
Roles3.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- GHC.Internal.Types.$tc~
- ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep [])))
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Roles3.$tcC2 ((:) $krep ((:) $krep []))
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -64,6 +55,15 @@ $krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ GHC.Internal.Types.$tc~
+ ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep [])))
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Roles3.$tcC2 ((:) $krep ((:) $krep []))
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
Roles3.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/Roles4.stderr
=====================================
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
class C3{1} :: * -> Constraint
type synonym Syn1{1} :: * -> *
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles4.$tcC3 [InlPrag=[~]]
@@ -25,10 +25,6 @@ Roles4.$tc'C:C1 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
3870707671502302648#Word64 10631907186261837450#Word64
Roles4.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep [])
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -40,6 +36,10 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Types.$tcList ((:) $krep [])
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep [])
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep [])
Roles4.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/T8958.stderr
=====================================
@@ -18,7 +18,7 @@ CLASS INSTANCES
instance [incoherent] Representational a
-- Defined at T8958.hs:11:10
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
T8958.$tcMap [InlPrag=[~]]
@@ -50,10 +50,10 @@ T8958.$tc'C:Nominal [InlPrag=[~]]
T8958.$trModule (GHC.Internal.Types.TrNameS "'C:Nominal"#) 1# $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
-$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Tuple.$tcTuple2
=====================================
testsuite/tests/typecheck/should_compile/T18406b.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
class C{2} :: * -> * -> Constraint
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Bug.$tcC [InlPrag=[~]]
@@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]]
= GHC.Internal.Types.TyCon
302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule
(GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Internal.Types.KindRep
- $krep
- ((:) @GHC.Internal.Types.KindRep
- $krep [] @GHC.Internal.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -31,6 +24,13 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Internal.Types.KindRep
+ $krep
+ ((:) @GHC.Internal.Types.KindRep
+ $krep [] @GHC.Internal.Types.KindRep))
Bug.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/typecheck/should_compile/T18529.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
class C{2} :: * -> * -> Constraint
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Bug.$tcC [InlPrag=[~]]
@@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]]
= GHC.Internal.Types.TyCon
302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule
(GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Internal.Types.KindRep
- $krep
- ((:) @GHC.Internal.Types.KindRep
- $krep [] @GHC.Internal.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -35,6 +28,13 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Tuple.$tcUnit [] @GHC.Internal.Types.KindRep
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Internal.Types.KindRep
+ $krep
+ ((:) @GHC.Internal.Types.KindRep
+ $krep [] @GHC.Internal.Types.KindRep))
Bug.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/typecheck/should_fail/T5300.stderr
=====================================
@@ -1,4 +1,3 @@
-
T5300.hs:12:7: error: [GHC-39999]
• Could not deduce ‘C1 a b c0’
from the context: (Monad m, C1 a b c)
@@ -14,16 +13,17 @@ T5300.hs:12:7: error: [GHC-39999]
f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a
T5300.hs:15:7: error: [GHC-39999]
- • Could not deduce ‘C1 a1 b1 c10’
+ • Could not deduce ‘C2 a2 b2 c20’
from the context: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2)
bound by the type signature for:
f2 :: forall (m :: * -> *) a1 b1 c1 a2 b2 c2.
(Monad m, C1 a1 b1 c1, C2 a2 b2 c2) =>
a1 -> StateT (T b2) m a2
at T5300.hs:15:7-69
- The type variable ‘c10’ is ambiguous
+ The type variable ‘c20’ is ambiguous
• In the ambiguity check for ‘f2’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
In the type signature:
f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) =>
a1 -> StateT (T b2) m a2
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/498f505726801671d93d49125d2dbce…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/498f505726801671d93d49125d2dbce…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/27532] UniqueDFM: alter should preserve insertion order
by Zubin (＠wz1000) 22 Jul '26
by Zubin (＠wz1000) 22 Jul '26
22 Jul '26
Zubin pushed to branch wip/27532 at Glasgow Haskell Compiler / GHC
Commits:
ca869395 by Zubin Duggal at 2026-07-22T18:03:58+05:30
UniqueDFM: alter should preserve insertion order
Before it always inserting new elements at the end.
This is problematic because instances get inserted into the map with
`alterF`, which can change ordering of how instances are printed
with `:info` depending on the order in which we consult interfaces
I expect `alter id k = id` and `alter (fmap f) k = adjust f k`. Moving keys to
the end breaks that (`adjust` already preserves position).
Fixes #27532
- - - - -
27 changed files:
- compiler/GHC/Types/Unique/DFM.hs
- testsuite/tests/ghci/T16793/T16793.stdout
- testsuite/tests/ghci/T18060/T18060.stdout
- + testsuite/tests/ghci/T27532/Makefile
- + testsuite/tests/ghci/T27532/T27532.stdout
- + testsuite/tests/ghci/T27532/T27532j4.stdout
- + testsuite/tests/ghci/T27532/a.script
- + testsuite/tests/ghci/T27532/all.T
- + testsuite/tests/ghci/T27532/b.script
- + testsuite/tests/ghci/T27532/genT27532Modules
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T4175.stdout
- testsuite/tests/ghci/scripts/T8469.stdout
- testsuite/tests/ghci/scripts/T8535.stdout
- testsuite/tests/ghci/scripts/T9881.stdout
- testsuite/tests/ghci/scripts/ghci020.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/ghci/should_run/T10145.stdout
- testsuite/tests/ghci/should_run/T18594.stdout
- testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/roles/should_compile/T8958.stderr
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- testsuite/tests/typecheck/should_fail/T5300.stderr
Changes:
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -91,6 +91,23 @@ import qualified GHC.Data.Word64Set as W
-- If the client of the map performs operations on the map in deterministic
-- order then `udfmToList` returns them in deterministic order.
--
+-- More precisely, the order is insertion order. A key takes its position
+-- when it is added to the map after being absent. Operations that modify
+-- the value at an existing key (addToUDFM, adjustUDFM, alterUDFM, ...) do
+-- not move it. Deleting a key and adding it back moves it to the end.
+--
+-- In particular the order does not depend on how existing entries were
+-- updated. This makes alterUDFM consistent with addToUDFM and adjustUDFM,
+-- so that for example alterUDFM id k = id.
+--
+-- It also keeps the order stable for maps whose entries are updated many
+-- times. The instance environments are the main example: inserting an
+-- instance updates the entry of its class in a DNameEnv, and when updates
+-- moved keys to the end the order of instances shown by :info depended on
+-- the order in which interfaces happened to be loaded (#27532). Now a
+-- class keeps its place once its first instance is added, so loading
+-- further interfaces cannot change the order.
+--
-- There is an implementation cost: each element is given a serial number
-- as it is added, and `udfmToList` sorts its result by this serial
-- number. So you should only use `UniqDFM` if you need the deterministic
@@ -108,7 +125,8 @@ import qualified GHC.Data.Word64Set as W
--
-- There's more than one way to implement this. The implementation here tags
-- every value with the insertion time that can later be used to sort the
--- values when asked to convert to a list.
+-- values when asked to convert to a list. Updating an existing key keeps
+-- the old tag.
--
-- An alternative would be to have
--
@@ -169,11 +187,13 @@ emptyUDFM = UDFM M.empty 0
unitUDFM :: Uniquable key => key -> elt -> UniqDFM key elt
unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1
--- The new binding always goes to the right of existing ones
+-- A new key goes to the right of existing ones
+-- Overwriting an existing key keeps its position in the iteration order
addToUDFM :: Uniquable key => UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM m k v = addToUDFM_Directly m (getUnique k) v
--- The new binding always goes to the right of existing ones
+-- A new key goes to the right of existing ones
+-- Overwriting an existing key keeps its position in the iteration order
addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt
addToUDFM_Directly (UDFM m i) u v
= UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)
@@ -435,7 +455,8 @@ adjustUDFM_Directly f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey k) m) i
-- | The expression (@'alterUDFM' f map k@) alters value x at k, or absence
-- thereof. 'alterUDFM' can be used to insert, delete, or update a value in
-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
--- more efficient.
+-- more efficient. Updating an existing key keeps its position in the
+-- deterministic iteration order.
--
-- 'alterUDFM' is non-strict in @k@.
alterUDFM
@@ -447,16 +468,16 @@ alterUDFM
alterUDFM f (UDFM m i) k =
UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1)
where
- alterf Nothing = inject $ f Nothing
- alterf (Just (TaggedVal v _)) = inject $ f (Just v)
- inject Nothing = Nothing
- inject (Just v) = Just $ TaggedVal v i
+ alterf Nothing = inject i $ f Nothing
+ alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v)
+ inject _ Nothing = Nothing
+ inject tag (Just v) = Just $ TaggedVal v tag
-- | The expression (@'upsertUDFM' f map k@) updates the value at @k@ or inserts
-- a new value if @k@ is absent.
--
--- Like 'alterUDFM', updating an existing entry assigns it the current tag, so it
--- becomes the newest element in deterministic iteration order.
+-- Updating an existing entry keeps its original tag, so its position in
+-- deterministic iteration order is unchanged and does not depend on update order.
upsertUDFM
:: Uniquable key
=> (Maybe elt -> elt) -- ^ How to adjust the element
@@ -467,13 +488,14 @@ upsertUDFM f (UDFM m i) k =
UDFM (MS.upsert upsertf (getKey $ getUnique k) m) (i + 1)
where
upsertf Nothing = TaggedVal (f Nothing) i
- upsertf (Just (TaggedVal v _)) = TaggedVal (f (Just v)) i
+ upsertf (Just (TaggedVal v old_i)) = TaggedVal (f (Just v)) old_i
-- | The expression (@'alterUDFM_L' f map k@) alters value @x@ at @k@, or absence
-- thereof and returns the new element at @k@ if there is any.
-- 'alterUDFM_L' can be used to insert, delete, or update a value in
-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are
--- more efficient.
+-- more efficient. Updating an existing key keeps its position in the
+-- deterministic iteration order.
--
-- Note, 'alterUDFM_L' is strict in @k@.
alterUDFM_L
@@ -489,10 +511,10 @@ alterUDFM_L f (UDFM m i) k =
(fmap taggedFst mElt, UDFM udfm (i + 1))
where
alterf :: Maybe (TaggedVal elt) -> (Maybe (TaggedVal elt))
- alterf Nothing = inject $ f Nothing
- alterf (Just (TaggedVal v _)) = inject $ f (Just v)
- inject Nothing = Nothing
- inject (Just v) = Just $ TaggedVal v i
+ alterf Nothing = inject i $ f Nothing
+ alterf (Just (TaggedVal v old_i)) = inject old_i $ f (Just v)
+ inject _ Nothing = Nothing
+ inject tag (Just v) = Just $ TaggedVal v tag
-- | Map a function over every value in a UniqDFM
mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
=====================================
testsuite/tests/ghci/T16793/T16793.stdout
=====================================
@@ -1,9 +1,9 @@
-instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Read Int -- Defined in ‘GHC.Internal.Read’
+instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
=====================================
testsuite/tests/ghci/T18060/T18060.stdout
=====================================
@@ -2,13 +2,13 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
type (~) :: forall k. k -> k -> Constraint
class (a ~ b) => (~) a b
-- Defined in ‘GHC.Internal.Types’
=====================================
testsuite/tests/ghci/T27532/Makefile
=====================================
@@ -0,0 +1,23 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T27532
+T27532:
+ '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < a.script 2>/dev/null | grep '^instance' > direct.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 < b.script 2>/dev/null | grep '^instance' > afterimport.txt
+ diff direct.txt afterimport.txt || true
+
+.PHONY: T27532j4
+T27532j4:
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_1.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_2.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_3.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_4.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_5.txt
+ printf ':info ()\n' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -ignore-dot-ghci -v0 -j4 -w M*.hs 2>/dev/null | grep '^instance' > j4_6.txt
+ diff j4_1.txt j4_2.txt || true
+ diff j4_1.txt j4_3.txt || true
+ diff j4_1.txt j4_4.txt || true
+ diff j4_1.txt j4_5.txt || true
+ diff j4_1.txt j4_6.txt || true
=====================================
testsuite/tests/ghci/T27532/T27532.stdout
=====================================
=====================================
testsuite/tests/ghci/T27532/T27532j4.stdout
=====================================
=====================================
testsuite/tests/ghci/T27532/a.script
=====================================
@@ -0,0 +1 @@
+:info ()
=====================================
testsuite/tests/ghci/T27532/all.T
=====================================
@@ -0,0 +1,9 @@
+test('T27532',
+ [extra_files(['a.script', 'b.script'])],
+ makefile_test, ['T27532'])
+
+test('T27532j4',
+ [pre_cmd('./genT27532Modules'),
+ extra_files(['genT27532Modules']),
+ req_ghc_smp],
+ makefile_test, ['T27532j4'])
=====================================
testsuite/tests/ghci/T27532/b.script
=====================================
@@ -0,0 +1,3 @@
+import Data.Ratio
+_ <- return $! compare (1 % 2 :: Rational) (2 % 3)
+:info ()
=====================================
testsuite/tests/ghci/T27532/genT27532Modules
=====================================
@@ -0,0 +1,33 @@
+#!/usr/bin/env bash
+# Generate modules that each import and use a distinct instance-heavy module,
+# so a parallel :load races many interface loads against each other.
+gen() { f=$1; shift; printf '%s\n' "module ${f%.hs} where" "$@" > "$f"; }
+gen M01.hs "import Data.Ratio" "v :: Rational" "v = 1 % 2" "s = show v"
+gen M02.hs "import Data.Complex" "v :: Complex Double" "v = 1" "s = show v"
+gen M03.hs "import Data.Fixed" "v :: Fixed E2" "v = 1" "s = show v"
+gen M04.hs "import Foreign.C.Types" "v :: CInt" "v = 1" "s = show v" "b :: CInt" "b = maxBound"
+gen M05.hs "import System.Posix.Types" "v :: CPid" "v = 1" "s = show v"
+gen M06.hs "import Data.Version" "s = showVersion (makeVersion [1,2])"
+gen M07.hs "import Control.Exception" "s = show DivideByZero" "t = show StackOverflow"
+gen M08.hs "import Data.Dynamic" "s = show (toDyn ())"
+gen M09.hs "import Type.Reflection" "s = show (typeRep :: TypeRep Bool)"
+gen M10.hs "import Data.List.NonEmpty (NonEmpty(..))" "s = show (1 :| ([2,3] :: [Int]))"
+gen M11.hs "import Data.Ord" "s = show (Down (3 :: Int))" "c = compare (Down 1) (Down (2 :: Int))"
+gen M12.hs "import Data.Functor.Identity" "s = show (Identity (1 :: Int))"
+gen M13.hs "import Data.Functor.Const" "s = show (Const (1 :: Int) :: Const Int Bool)"
+gen M14.hs "import Data.Functor.Compose" "s = show (Compose (Just (Just (1 :: Int))))"
+gen M15.hs "import Data.Functor.Product" "s = show (Pair (Just (1 :: Int)) (Just (2 :: Int)))"
+gen M16.hs "import Data.Functor.Sum" "s = show (InL (Just (1 :: Int)) :: Sum Maybe Maybe Int)"
+gen M17.hs "import Data.Monoid" "s = show (Sum (1 :: Int) <> Sum 2)" "a = show (All True)"
+gen M18.hs "import Data.Semigroup" "s = show (Min (1 :: Int) <> Min 2)"
+gen M19.hs "import Text.Printf" "s = printf \"%d\" (1 :: Int) :: String"
+gen M20.hs "import Numeric.Natural" "s = show (5 :: Natural)" "v :: Natural" "v = 2 + 3"
+gen M21.hs "import Foreign.Ptr" "s = show nullPtr"
+gen M22.hs "import System.IO" "s = show stdout" "e = show stderr"
+gen M23.hs "import Data.IORef" "v :: IO (IORef Int)" "v = newIORef 1"
+gen M24.hs "import Data.Bits" "v = xor (1 :: Int) 2" "s = show v"
+for f in M??.hs; do
+ n=${f#M}; n=${n%.hs}
+ m=$(printf 'M%02d' $((10#$n + 24)))
+ sed "s/module M$n/module $m/" "$f" > "$m.hs"
+done
=====================================
testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
=====================================
@@ -1,13 +1,13 @@
type Unit :: *
data Unit = ()
-- Defined in ‘GHC.Internal.Tuple’
+instance Eq Unit -- Defined in ‘GHC.Internal.Classes’
instance Monoid Unit -- Defined in ‘GHC.Internal.Base’
+instance Ord Unit -- Defined in ‘GHC.Internal.Classes’
instance Semigroup Unit -- Defined in ‘GHC.Internal.Base’
-instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’
instance Read Unit -- Defined in ‘GHC.Internal.Read’
+instance Bounded Unit -- Defined in ‘GHC.Internal.Enum’
instance Enum Unit -- Defined in ‘GHC.Internal.Enum’
-instance Eq Unit -- Defined in ‘GHC.Internal.Classes’
-instance Ord Unit -- Defined in ‘GHC.Internal.Classes’
instance Show Unit -- Defined in ‘GHC.Internal.Show’
type Unit# :: GHC.Internal.Types.ZeroBitType
data Unit# = (##)
@@ -15,23 +15,23 @@ data Unit# = (##)
type Solo :: * -> *
data Solo a = MkSolo a
-- Defined in ‘GHC.Internal.Tuple’
-instance Traversable Solo
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance Applicative Solo -- Defined in ‘GHC.Internal.Base’
-instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’
instance Functor Solo -- Defined in ‘GHC.Internal.Base’
instance Monad Solo -- Defined in ‘GHC.Internal.Base’
+instance Monoid a => Monoid (Solo a)
+ -- Defined in ‘GHC.Internal.Base’
+instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’
+instance Semigroup a => Semigroup (Solo a)
+ -- Defined in ‘GHC.Internal.Base’
instance Read a => Read (Solo a) -- Defined in ‘GHC.Internal.Read’
instance Bounded a => Bounded (Solo a)
-- Defined in ‘GHC.Internal.Enum’
instance Enum a => Enum (Solo a) -- Defined in ‘GHC.Internal.Enum’
-instance Ord a => Ord (Solo a) -- Defined in ‘GHC.Internal.Classes’
instance Show a => Show (Solo a) -- Defined in ‘GHC.Internal.Show’
-instance Eq a => Eq (Solo a) -- Defined in ‘GHC.Internal.Classes’
-instance Monoid a => Monoid (Solo a)
- -- Defined in ‘GHC.Internal.Base’
-instance Semigroup a => Semigroup (Solo a)
- -- Defined in ‘GHC.Internal.Base’
+instance Foldable Solo -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Solo
+ -- Defined in ‘GHC.Internal.Data.Traversable’
() :: Unit
(##) :: Unit#
( ) :: Unit
@@ -39,29 +39,29 @@ instance Semigroup a => Semigroup (Solo a)
type Tuple2 :: * -> * -> *
data Tuple2 a b = (,) a b
-- Defined in ‘GHC.Internal.Tuple’
-instance Traversable (Tuple2 a)
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance Monoid a => Applicative (Tuple2 a)
-- Defined in ‘GHC.Internal.Base’
-instance Foldable (Tuple2 a)
- -- Defined in ‘GHC.Internal.Data.Foldable’
+instance (Eq a, Eq b) => Eq (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Classes’
instance Functor (Tuple2 a) -- Defined in ‘GHC.Internal.Base’
instance Monoid a => Monad (Tuple2 a)
-- Defined in ‘GHC.Internal.Base’
instance (Monoid a, Monoid b) => Monoid (Tuple2 a b)
-- Defined in ‘GHC.Internal.Base’
-instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Base’
-instance (Bounded a, Bounded b) => Bounded (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Enum’
instance (Ord a, Ord b) => Ord (Tuple2 a b)
-- Defined in ‘GHC.Internal.Classes’
+instance (Semigroup a, Semigroup b) => Semigroup (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Base’
instance (Read a, Read b) => Read (Tuple2 a b)
-- Defined in ‘GHC.Internal.Read’
+instance (Bounded a, Bounded b) => Bounded (Tuple2 a b)
+ -- Defined in ‘GHC.Internal.Enum’
instance (Show a, Show b) => Show (Tuple2 a b)
-- Defined in ‘GHC.Internal.Show’
-instance (Eq a, Eq b) => Eq (Tuple2 a b)
- -- Defined in ‘GHC.Internal.Classes’
+instance Foldable (Tuple2 a)
+ -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable (Tuple2 a)
+ -- Defined in ‘GHC.Internal.Data.Traversable’
type Tuple2# :: *
-> *
-> TYPE
=====================================
testsuite/tests/ghci/scripts/T4175.stdout
=====================================
@@ -26,52 +26,52 @@ type Unit :: *
data Unit = ()
-- Defined in ‘GHC.Internal.Tuple’
instance [safe] C () -- Defined at T4175.hs:22:10
+instance Eq () -- Defined in ‘GHC.Internal.Classes’
instance Monoid () -- Defined in ‘GHC.Internal.Base’
+instance Ord () -- Defined in ‘GHC.Internal.Classes’
instance Semigroup () -- Defined in ‘GHC.Internal.Base’
+instance Read () -- Defined in ‘GHC.Internal.Read’
instance Bounded () -- Defined in ‘GHC.Internal.Enum’
instance Enum () -- Defined in ‘GHC.Internal.Enum’
-instance Ord () -- Defined in ‘GHC.Internal.Classes’
-instance Read () -- Defined in ‘GHC.Internal.Read’
instance Show () -- Defined in ‘GHC.Internal.Show’
-instance Eq () -- Defined in ‘GHC.Internal.Classes’
data instance B () = MkB -- Defined at T4175.hs:14:15
type instance D Int () = String -- Defined at T4175.hs:20:10
type instance D () () = Bool -- Defined at T4175.hs:23:10
type Maybe :: * -> *
data Maybe a = Nothing | Just a
-- Defined in ‘GHC.Internal.Maybe’
-instance Traversable Maybe
- -- Defined in ‘GHC.Internal.Data.Traversable’
-instance MonadFail Maybe
- -- Defined in ‘GHC.Internal.Control.Monad.Fail’
instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’
-instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance [safe] Eq a => Eq (Maybe a)
+ -- Defined in ‘GHC.Internal.Maybe’
instance Functor Maybe -- Defined in ‘GHC.Internal.Base’
instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
instance Semigroup a => Monoid (Maybe a)
-- Defined in ‘GHC.Internal.Base’
-instance Semigroup a => Semigroup (Maybe a)
- -- Defined in ‘GHC.Internal.Base’
instance [safe] Ord a => Ord (Maybe a)
-- Defined in ‘GHC.Internal.Maybe’
+instance Semigroup a => Semigroup (Maybe a)
+ -- Defined in ‘GHC.Internal.Base’
instance Read a => Read (Maybe a) -- Defined in ‘GHC.Internal.Read’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Internal.Show’
-instance [safe] Eq a => Eq (Maybe a)
- -- Defined in ‘GHC.Internal.Maybe’
+instance MonadFail Maybe
+ -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Maybe
+ -- Defined in ‘GHC.Internal.Data.Traversable’
type instance A (Maybe a) a = a -- Defined at T4175.hs:10:15
type Int :: *
data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int#
-- Defined in ‘GHC.Internal.Types’
instance [safe] C Int -- Defined at T4175.hs:19:10
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
+instance Read Int -- Defined in ‘GHC.Internal.Read’
instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
-instance Read Int -- Defined in ‘GHC.Internal.Read’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
type instance A Int Int = () -- Defined at T4175.hs:9:15
type instance D Int () = String -- Defined at T4175.hs:20:10
type Z :: * -> Constraint
=====================================
testsuite/tests/ghci/scripts/T8469.stdout
=====================================
@@ -1,12 +1,12 @@
type Int :: *
data Int = GHC.Internal.Types.I# GHC.Internal.Prim.Int#
-- Defined in ‘GHC.Internal.Types’
-instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
+instance Eq Int -- Defined in ‘GHC.Internal.Classes’
+instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Read Int -- Defined in ‘GHC.Internal.Read’
+instance Bounded Int -- Defined in ‘GHC.Internal.Enum’
instance Enum Int -- Defined in ‘GHC.Internal.Enum’
-instance Eq Int -- Defined in ‘GHC.Internal.Classes’
-instance Integral Int -- Defined in ‘GHC.Internal.Real’
instance Num Int -- Defined in ‘GHC.Internal.Num’
-instance Ord Int -- Defined in ‘GHC.Internal.Classes’
instance Real Int -- Defined in ‘GHC.Internal.Real’
instance Show Int -- Defined in ‘GHC.Internal.Show’
+instance Integral Int -- Defined in ‘GHC.Internal.Real’
=====================================
testsuite/tests/ghci/scripts/T8535.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/scripts/T9881.stdout
=====================================
@@ -4,16 +4,16 @@ data Data.ByteString.Lazy.ByteString
| Data.ByteString.Lazy.Internal.Chunk {-# UNPACK #-} !StrictByteString
Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
+instance Eq Data.ByteString.Lazy.ByteString
+ -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Monoid Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
+instance Ord Data.ByteString.Lazy.ByteString
+ -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Semigroup Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
instance Read Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
-instance Eq Data.ByteString.Lazy.ByteString
- -- Defined in ‘Data.ByteString.Lazy.Internal’
-instance Ord Data.ByteString.Lazy.ByteString
- -- Defined in ‘Data.ByteString.Lazy.Internal’
instance Show Data.ByteString.Lazy.ByteString
-- Defined in ‘Data.ByteString.Lazy.Internal’
@@ -23,15 +23,15 @@ data Data.ByteString.ByteString
GHC.Internal.Word.Word8)
{-# UNPACK #-} !Int
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
+instance Eq Data.ByteString.ByteString
+ -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Monoid Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
+instance Ord Data.ByteString.ByteString
+ -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Semigroup Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Read Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
-instance Eq Data.ByteString.ByteString
- -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
-instance Ord Data.ByteString.ByteString
- -- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
instance Show Data.ByteString.ByteString
-- Defined in ‘bytestring-0.12.2.0:Data.ByteString.Internal.Type’
=====================================
testsuite/tests/ghci/scripts/ghci020.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -1,52 +1,52 @@
-instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
-instance Traversable Maybe
- -- Defined in ‘GHC.Internal.Data.Traversable’
instance GHC.Internal.Base.Alternative Maybe
-- Defined in ‘GHC.Internal.Base’
instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’
instance Functor Maybe -- Defined in ‘GHC.Internal.Base’
-instance MonadFail Maybe
- -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.MonadPlus Maybe
-- Defined in ‘GHC.Internal.Base’
-instance Monad Maybe -- Defined in ‘GHC.Internal.Base’
+instance MonadFail Maybe
+ -- Defined in ‘GHC.Internal.Control.Monad.Fail’
+instance Foldable Maybe -- Defined in ‘GHC.Internal.Data.Foldable’
+instance Traversable Maybe
+ -- Defined in ‘GHC.Internal.Data.Traversable’
+instance [safe] Eq w => Eq (Maybe w)
+ -- Defined in ‘GHC.Internal.Maybe’
instance Semigroup w => Monoid (Maybe w)
-- Defined in ‘GHC.Internal.Base’
-instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’
-instance Semigroup w => Semigroup (Maybe w)
- -- Defined in ‘GHC.Internal.Base’
instance [safe] Ord w => Ord (Maybe w)
-- Defined in ‘GHC.Internal.Maybe’
+instance Semigroup w => Semigroup (Maybe w)
+ -- Defined in ‘GHC.Internal.Base’
+instance Read w => Read (Maybe w) -- Defined in ‘GHC.Internal.Read’
instance Show w => Show (Maybe w) -- Defined in ‘GHC.Internal.Show’
-instance [safe] Eq w => Eq (Maybe w)
- -- Defined in ‘GHC.Internal.Maybe’
-instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
-instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’
-instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
instance Eq w => Eq [w] -- Defined in ‘GHC.Internal.Classes’
instance Monoid [w] -- Defined in ‘GHC.Internal.Base’
+instance Ord w => Ord [w] -- Defined in ‘GHC.Internal.Classes’
instance Semigroup [w] -- Defined in ‘GHC.Internal.Base’
+instance Read w => Read [w] -- Defined in ‘GHC.Internal.Read’
+instance Show w => Show [w] -- Defined in ‘GHC.Internal.Show’
instance [safe] MyShow w => MyShow [w]
-- Defined at ghci064.hs:8:10
instance Monoid [T] -- Defined in ‘GHC.Internal.Base’
instance Semigroup [T] -- Defined in ‘GHC.Internal.Base’
instance [safe] MyShow [T] -- Defined at ghci064.hs:16:10
instance [safe] MyShow [T] -- Defined at ghci064.hs:8:10
-instance GHC.Internal.Foreign.Storable.Storable Bool
- -- Defined in ‘GHC.Internal.Foreign.Storable’
-instance GHC.Internal.Bits.Bits Bool
- -- Defined in ‘GHC.Internal.Bits’
+instance Eq Bool -- Defined in ‘GHC.Internal.Classes’
+instance Ord Bool -- Defined in ‘GHC.Internal.Classes’
+instance Read Bool -- Defined in ‘GHC.Internal.Read’
instance Bounded Bool -- Defined in ‘GHC.Internal.Enum’
instance Enum Bool -- Defined in ‘GHC.Internal.Enum’
+instance Show Bool -- Defined in ‘GHC.Internal.Show’
+instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’
+instance GHC.Internal.Bits.Bits Bool
+ -- Defined in ‘GHC.Internal.Bits’
instance GHC.Internal.Bits.FiniteBits Bool
-- Defined in ‘GHC.Internal.Bits’
-instance GHC.Internal.Ix.Ix Bool -- Defined in ‘GHC.Internal.Ix’
-instance Ord Bool -- Defined in ‘GHC.Internal.Classes’
-instance Read Bool -- Defined in ‘GHC.Internal.Read’
-instance Show Bool -- Defined in ‘GHC.Internal.Show’
-instance Eq Bool -- Defined in ‘GHC.Internal.Classes’
-instance Traversable ((,) Int)
- -- Defined in ‘GHC.Internal.Data.Traversable’
+instance GHC.Internal.Foreign.Storable.Storable Bool
+ -- Defined in ‘GHC.Internal.Foreign.Storable’
+instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’
instance Foldable ((,) Int)
-- Defined in ‘GHC.Internal.Data.Foldable’
-instance Functor ((,) Int) -- Defined in ‘GHC.Internal.Base’
+instance Traversable ((,) Int)
+ -- Defined in ‘GHC.Internal.Data.Traversable’
=====================================
testsuite/tests/ghci/should_run/T10145.stdout
=====================================
@@ -2,10 +2,10 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/ghci/should_run/T18594.stdout
=====================================
@@ -2,13 +2,13 @@ type (->) :: * -> * -> *
type (->) = FUN Many
-- Defined in ‘GHC.Internal.Types’
infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
instance Monoid b => Monoid (a -> b)
-- Defined in ‘GHC.Internal.Base’
instance Semigroup b => Semigroup (a -> b)
-- Defined in ‘GHC.Internal.Base’
-instance Applicative ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Functor ((->) r) -- Defined in ‘GHC.Internal.Base’
-instance Monad ((->) r) -- Defined in ‘GHC.Internal.Base’
type Constraint :: *
type Constraint = CONSTRAINT LiftedRep
-- Defined in ‘GHC.Internal.Types’
=====================================
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
=====================================
@@ -21,7 +21,7 @@ TYPE SIGNATURES
(>>) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
(>>=) ::
forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
- (^) :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
+ (^) :: forall {a} {b}. (Num a, Integral b) => a -> b -> a
(^^) :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
abs :: forall {a}. Num a => a -> a
acos :: forall {a}. Floating a => a -> a
@@ -236,4 +236,4 @@ TYPE SIGNATURES
(a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
(||) :: Bool -> Bool -> Bool
Dependent modules: []
-Dependent packages: [(normal, base-4.21.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
=====================================
testsuite/tests/roles/should_compile/Roles14.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE CONSTRUCTORS
class C2{1} :: * -> Constraint
roles representational
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles12.$tcC2 [InlPrag=[~]]
@@ -15,14 +15,14 @@ Roles12.$tc'C:C2 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
7087988437584478859#Word64 11477953550142401435#Word64
Roles12.$trModule (GHC.Internal.Types.TrNameS "'C:C2"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles12.$tcC2 ((:) $krep [])
Roles12.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/Roles3.stderr
=====================================
@@ -16,7 +16,7 @@ TYPE CONSTRUCTORS
roles nominal
type synonym Syn2{1} :: * -> *
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles3.$tcC4 [InlPrag=[~]]
@@ -43,15 +43,6 @@ Roles3.$tc'C:C1 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
4508088879886988796#Word64 13962145553903222779#Word64
Roles3.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- GHC.Internal.Types.$tc~
- ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep [])))
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Roles3.$tcC2 ((:) $krep ((:) $krep []))
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -64,6 +55,15 @@ $krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ GHC.Internal.Types.$tc~
+ ((:) GHC.Internal.Types.krep$* ((:) $krep ((:) $krep [])))
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Roles3.$tcC2 ((:) $krep ((:) $krep []))
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles3.$tcC1 ((:) $krep [])
Roles3.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/Roles4.stderr
=====================================
@@ -6,7 +6,7 @@ TYPE CONSTRUCTORS
class C3{1} :: * -> Constraint
type synonym Syn1{1} :: * -> *
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Roles4.$tcC3 [InlPrag=[~]]
@@ -25,10 +25,6 @@ Roles4.$tc'C:C1 [InlPrag=[~]]
= GHC.Internal.Types.TyCon
3870707671502302648#Word64 10631907186261837450#Word64
Roles4.$trModule (GHC.Internal.Types.TrNameS "'C:C1"#) 1# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep [])
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep [])
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -40,6 +36,10 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Types.$tcList ((:) $krep [])
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC3 ((:) $krep [])
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp Roles4.$tcC1 ((:) $krep [])
Roles4.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/roles/should_compile/T8958.stderr
=====================================
@@ -18,7 +18,7 @@ CLASS INSTANCES
instance [incoherent] Representational a
-- Defined at T8958.hs:11:10
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
T8958.$tcMap [InlPrag=[~]]
@@ -50,10 +50,10 @@ T8958.$tc'C:Nominal [InlPrag=[~]]
T8958.$trModule (GHC.Internal.Types.TrNameS "'C:Nominal"#) 1# $krep
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
-$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Tuple.$tcTuple2
=====================================
testsuite/tests/typecheck/should_compile/T18406b.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
class C{2} :: * -> * -> Constraint
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Bug.$tcC [InlPrag=[~]]
@@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]]
= GHC.Internal.Types.TyCon
302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule
(GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Internal.Types.KindRep
- $krep
- ((:) @GHC.Internal.Types.KindRep
- $krep [] @GHC.Internal.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -31,6 +24,13 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepFun
GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Internal.Types.KindRep
+ $krep
+ ((:) @GHC.Internal.Types.KindRep
+ $krep [] @GHC.Internal.Types.KindRep))
Bug.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/typecheck/should_compile/T18529.stderr
=====================================
@@ -4,7 +4,7 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
class C{2} :: * -> * -> Constraint
Dependent modules: []
-Dependent packages: [(normal, base-4.22.0.0)]
+Dependent packages: [(normal, base-4.23.0.0)]
==================== Typechecker ====================
Bug.$tcC [InlPrag=[~]]
@@ -15,13 +15,6 @@ Bug.$tc'C:C [InlPrag=[~]]
= GHC.Internal.Types.TyCon
302756782745842909#Word64 14248103394115774781#Word64 Bug.$trModule
(GHC.Internal.Types.TrNameS "'C:C"#) 2# $krep
-$krep [InlPrag=[~]]
- = GHC.Internal.Types.KindRepTyConApp
- Bug.$tcC
- ((:) @GHC.Internal.Types.KindRep
- $krep
- ((:) @GHC.Internal.Types.KindRep
- $krep [] @GHC.Internal.Types.KindRep))
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 0
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepVar 1
$krep [InlPrag=[~]] = GHC.Internal.Types.KindRepFun $krep $krep
@@ -35,6 +28,13 @@ $krep [InlPrag=[~]]
$krep [InlPrag=[~]]
= GHC.Internal.Types.KindRepTyConApp
GHC.Internal.Tuple.$tcUnit [] @GHC.Internal.Types.KindRep
+$krep [InlPrag=[~]]
+ = GHC.Internal.Types.KindRepTyConApp
+ Bug.$tcC
+ ((:) @GHC.Internal.Types.KindRep
+ $krep
+ ((:) @GHC.Internal.Types.KindRep
+ $krep [] @GHC.Internal.Types.KindRep))
Bug.$trModule [InlPrag=[~]]
= GHC.Internal.Types.Module
(GHC.Internal.Types.TrNameS "main"#)
=====================================
testsuite/tests/typecheck/should_fail/T5300.stderr
=====================================
@@ -1,4 +1,3 @@
-
T5300.hs:12:7: error: [GHC-39999]
• Could not deduce ‘C1 a b c0’
from the context: (Monad m, C1 a b c)
@@ -14,16 +13,17 @@ T5300.hs:12:7: error: [GHC-39999]
f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a
T5300.hs:15:7: error: [GHC-39999]
- • Could not deduce ‘C1 a1 b1 c10’
+ • Could not deduce ‘C2 a2 b2 c20’
from the context: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2)
bound by the type signature for:
f2 :: forall (m :: * -> *) a1 b1 c1 a2 b2 c2.
(Monad m, C1 a1 b1 c1, C2 a2 b2 c2) =>
a1 -> StateT (T b2) m a2
at T5300.hs:15:7-69
- The type variable ‘c10’ is ambiguous
+ The type variable ‘c20’ is ambiguous
• In the ambiguity check for ‘f2’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
In the type signature:
f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) =>
a1 -> StateT (T b2) m a2
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca86939588c4ddd10b56c7be42ed076…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca86939588c4ddd10b56c7be42ed076…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
22 Jul '26
Simon Jakobi pushed new branch wip/sjakobi/T27521 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27521
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/external-unit-db-cache] Introduce UnitIndex for global external unit caching
by Hannes Siebenhandl (＠fendor) 22 Jul '26
by Hannes Siebenhandl (＠fendor) 22 Jul '26
22 Jul '26
Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC
Commits:
c9d5e531 by fendor at 2026-07-22T14:07:38+02:00
Introduce UnitIndex for global external unit caching
`UnitInfo`s have been observed to cause a lot of memory usage in #27500.
Especially with multiple home units, as the same (external) units are
processed from scratch, even though most of the time we end up with
exactly the same `UnitInfo`.
We introduce a `UnitEnv` global cache that allows us to store external
unit information that is used across all `HomeUnitEnv`s.
The most important change in this commit is the introduction of the `UnitIndex`.
It stores a global mapping of `UnitId` -> `UnitInfo`, and `initUnits`
always uses the cached `UnitInfo` entry to populate each
`HomeUnitEnv`'s `UnitState`.
This allows us to ensure the following property:
> Each `UnitInfo` should be alive exactly once in GHC.
In addition, the `ExternalUnitDatabaseCache` may also hold a reference
to each on-disk representation of `UnitInfo`.
This means, we impose an hard upper bound on the number of `UnitInfo`s
alive in the GHC session:
> The number of alive `UnitInfo`s closure objects must be the
> sum of all loaded unit database times two.
We add performance regression tests that make sure the number of live
`UnitInfo` cannot exceed this threshold.
Closes #27500
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
MultiComponentModulesRecomp100
mhu-perf
-------------------------
These metrics increases are especially notable, as we are not even
sharing anything big but merely the global package database with 50
entries.
It shows how careful sharing of `UnitInfo` can improve memory usage.
We expect this to be much more notable when the whole cabal package
database is shared across multiple home units.
---
Technical details
To share the `UnitInfo`s correctly, it is important that we extract
the `WireMap` into the `UnitIndex`. At the moment of writing, `WireMap`
must be globally the same for all `HomeUnitEnv`s.
This is important, as we could otherwise not cache the "fully-resolved"
`UnitInfo`.
We consider a `UnitInfo` fully-resolved, if wired-in units have been
updated, the `UnitInfo` has been validated and variables in the unit
config, such as `${pkgroot}` have been resolved.
Updating the wired-in units requires the `WireMap` to be globally the
same.
- - - - -
35 changed files:
- + changelog.d/unit-index
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main/Interactive.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/External/Database.hs
- + compiler/GHC/Unit/External/Index.hs
- + compiler/GHC/Unit/External/ModuleOrigin.hs
- + compiler/GHC/Unit/External/Providers.hs
- + compiler/GHC/Unit/External/Query.hs
- + compiler/GHC/Unit/External/Substitution.hs
- + compiler/GHC/Unit/External/Validate.hs
- + compiler/GHC/Unit/External/Visibility.hs
- + compiler/GHC/Unit/External/Wired.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- hadrian/src/Rules/Generate.hs
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/driver/TUnitInfo/Foo.hs
- + testsuite/tests/driver/TUnitInfo/Makefile
- + testsuite/tests/driver/TUnitInfo/all.T
- + testsuite/tests/driver/TUnitInfo/genMhu.sh
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.stdout
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space.stdout
- utils/haddock/haddock-api/src/Haddock.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9d5e5318b4c9c1a2652b27fb079f4a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9d5e5318b4c9c1a2652b27fb079f4a…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/T27534] testsuite: Make T17088 an effective reproducer
by Simon Jakobi (＠sjakobi2) 22 Jul '26
by Simon Jakobi (＠sjakobi2) 22 Jul '26
22 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/T27534 at Glasgow Haskell Compiler / GHC
Commits:
45299507 by Simon Jakobi at 2026-07-22T13:25:09+02:00
testsuite: Make T17088 an effective reproducer
Initialize each byte array so that the test does not depend on
allocator contents. Run the test only with the compacting collector and
restore the compiler and RTS settings that trigger #17088.
Disable STG lambda lifting because it removes the closure shape needed
to reproduce the original pointer-tagging failure.
Closes #27534.
Assisted-by: gpt-5.6-sol via Codex CLI
- - - - -
2 changed files:
- testsuite/tests/rts/T17088.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
testsuite/tests/rts/T17088.hs
=====================================
@@ -2,6 +2,9 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Lambda lifting removes the closure shape needed to reproduce #17088.
+{-# OPTIONS_GHC -fno-stg-lift-lams #-}
+
module Main (main) where
import Data.Word
@@ -27,7 +30,9 @@ instance Show Bytes where
bytesAllocRet :: Int -> IO Bytes
bytesAllocRet (I# sz) =
IO $ \s -> case newAlignedPinnedByteArray# sz 8# s of
- (# s', mba #) -> (# s', Bytes mba #)
+ (# s', mba #) ->
+ case writeWord8Array# mba 0# (wordToWord8# 0##) s' of
+ s'' -> (# s'', Bytes mba #)
------------------------------------------------------------------------
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -540,8 +540,11 @@ test('RestartEventLogging',
compile_and_run, ['RestartEventLogging_c.c'])
test('T17088',
- [extra_ways(['compacting_gc']), extra_run_opts('+RTS -A256k -RTS')],
- compile_and_run, ['-rtsopts -O2'])
+ [ only_ways(['compacting_gc'])
+ , extra_ways(['compacting_gc'])
+ , extra_run_opts('+RTS -A128k -RTS')
+ ],
+ compile_and_run, ['-rtsopts -O1'])
test('T15427', js_broken(22374), compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45299507219dc7bc69db7c0b25563d4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45299507219dc7bc69db7c0b25563d4…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/sjakobi/T27534] testsuite: Make T17088 an effective reproducer
by Simon Jakobi (＠sjakobi2) 22 Jul '26
by Simon Jakobi (＠sjakobi2) 22 Jul '26
22 Jul '26
Simon Jakobi pushed to branch wip/sjakobi/T27534 at Glasgow Haskell Compiler / GHC
Commits:
688b520f by Simon Jakobi at 2026-07-22T13:21:21+02:00
testsuite: Make T17088 an effective reproducer
Initialize each byte array so that the test does not depend on
allocator contents. Run the test only with the compacting collector and
restore the compiler and RTS settings that trigger #17088.
Disable STG lambda lifting because it removes the closure shape needed
to reproduce the original pointer-tagging failure.
Assisted-by: gpt-5.6-sol via Codex CLI
- - - - -
2 changed files:
- testsuite/tests/rts/T17088.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
testsuite/tests/rts/T17088.hs
=====================================
@@ -2,6 +2,9 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Lambda lifting removes the closure shape needed to reproduce #17088.
+{-# OPTIONS_GHC -fno-stg-lift-lams #-}
+
module Main (main) where
import Data.Word
@@ -27,7 +30,9 @@ instance Show Bytes where
bytesAllocRet :: Int -> IO Bytes
bytesAllocRet (I# sz) =
IO $ \s -> case newAlignedPinnedByteArray# sz 8# s of
- (# s', mba #) -> (# s', Bytes mba #)
+ (# s', mba #) ->
+ case writeWord8Array# mba 0# (wordToWord8# 0##) s' of
+ s'' -> (# s'', Bytes mba #)
------------------------------------------------------------------------
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -540,8 +540,11 @@ test('RestartEventLogging',
compile_and_run, ['RestartEventLogging_c.c'])
test('T17088',
- [extra_ways(['compacting_gc']), extra_run_opts('+RTS -A256k -RTS')],
- compile_and_run, ['-rtsopts -O2'])
+ [ only_ways(['compacting_gc'])
+ , extra_ways(['compacting_gc'])
+ , extra_run_opts('+RTS -A128k -RTS')
+ ],
+ compile_and_run, ['-rtsopts -O1'])
test('T15427', js_broken(22374), compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/688b520f88f6f739431d7ba173124db…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/688b520f88f6f739431d7ba173124db…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/external-unit-db-cache] Add test for multiple home units to show that the number of UnitInfo's doesn't increase
by Hannes Siebenhandl (＠fendor) 22 Jul '26
by Hannes Siebenhandl (＠fendor) 22 Jul '26
22 Jul '26
Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC
Commits:
85ec1752 by fendor at 2026-07-22T13:18:01+02:00
Add test for multiple home units to show that the number of UnitInfo's doesn't increase
- - - - -
16 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/External/Database.hs
- compiler/GHC/Unit/External/Index.hs
- compiler/GHC/Unit/External/ModuleOrigin.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- testsuite/tests/driver/TUnitInfo/Makefile
- testsuite/tests/driver/TUnitInfo/all.T
- + testsuite/tests/driver/TUnitInfo/genMhu.sh
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.stdout
- testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
logger <- getLogger
hsc_env <- getSession
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -778,7 +778,6 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_current_unit = ue_currentUnit old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
, ue_eps = ue_eps old_unit_env
- , ue_eud = ue_eud old_unit_env
, ue_uic = ue_uic old_unit_env
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
@@ -837,7 +836,6 @@ setProgramHUG_ invalidate_needed new_hug0 = do
, ue_current_unit = ue_currentUnit unit_env0
, ue_eps = ue_eps unit_env0
, ue_module_graph = ue_module_graph unit_env0
- , ue_eud = ue_eud unit_env0
, ue_uic = ue_uic unit_env0
}
modifySession $ \h ->
@@ -886,7 +884,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph unit_env)
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure HomeUnitEnv
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Types.Error (mkUnknownDiagnostic)
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
-import GHC.Unit.External.Database (cacheExternalUnitDatabase)
+import GHC.Unit.External.Index (cacheExternalUnitDatabase)
-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
@@ -442,8 +442,8 @@ addInMemoryDatabase dflags u = do
{ unitDatabasePath = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags (ppr (unitId u)) ++ ")"
, unitDatabaseUnits = [u]
}
- let eud = hscEUDC hsc_env
- liftIO $ cacheExternalUnitDatabase eud newdb
+ let uic = hscUIC hsc_env
+ liftIO $ cacheExternalUnitDatabase uic newdb
-- added at the end because ordering matters
pure dflags
{ packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
@@ -456,11 +456,10 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
- let eud = hscEUDC hsc_env
dflags1 <- addInMemoryDatabase dflags0 u
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env)
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
@@ -477,7 +476,6 @@ addUnit u = do
(HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
- , ue_eud = ue_eud old_unit_env
, ue_uic = ue_uic old_unit_env
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -14,7 +14,6 @@ module GHC.Driver.Env
, hsc_HUG
, hsc_all_home_unit_ids
, hscUnitIndex
- , hscUIC
, hscUpdateLoggerFlags
, hscUpdateHUG
, hscInsertHPT
@@ -27,7 +26,7 @@ module GHC.Driver.Env
, runInteractiveHsc
, hscEPS
, hscEUD
- , hscEUDC
+ , hscUIC
, hscInterp
, prepareAnnotations
, discardIC
@@ -228,10 +227,7 @@ hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
hscEUD :: HscEnv -> IO (ExternalUnitDatabases UnitId)
-hscEUD = readExternalUnitDatabases . hscEUDC
-
-hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId
-hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env)
+hscEUD = readExternalUnitDatabases . hscUIC
hscUnitIndex :: HscEnv -> IO UnitIndex
hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env)
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
emptyHpt <- liftIO $ emptyHomePackageTable
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -178,19 +178,21 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
- , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId)
- -- ^ Global cache of already read package databases
-
, ue_uic :: {-# UNPACK #-} !UnitIndexCache
- -- ^ Index of already processed 'UnitInfo's.
- -- Shares state over all 'UnitState' in the 'HomeUnitGraph'.
+ -- ^ Global index of already processed external units.
+ -- Shares state over all 'UnitState's in the 'HomeUnitGraph'.
+ --
+ -- Allows sharing of 'UnitInfo's, ensuring each individual 'UnitInfo'
+ -- is retained a constant number of times.
+ --
+ -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
}
ueEPS :: UnitEnv -> IO ExternalPackageState
ueEPS = eucEPS . ue_eps
ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId)
-ueEUD = readExternalUnitDatabases . ue_eud
+ueEUD = readExternalUnitDatabases . ue_uic
ueUI :: UnitEnv -> IO UnitIndex
ueUI = readUnitIndex . ue_uic
@@ -199,7 +201,6 @@ ueUI = readUnitIndex . ue_uic
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
- eud <- initExternalUnitDatabaseCache
uic <- initUnitIndexCache
return $ UnitEnv
{ ue_eps = eps
@@ -208,7 +209,6 @@ initUnitEnv cur_unit hug namever platform = do
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
- , ue_eud = eud
, ue_uic = uic
}
=====================================
compiler/GHC/Unit/External/Database.hs
=====================================
@@ -1,18 +1,11 @@
module GHC.Unit.External.Database (
- -- * Mutable cache for 'ExternalUnitDatabases'
- ExternalUnitDatabaseCache (..),
- initExternalUnitDatabaseCache,
- readExternalUnitDatabases,
- readExternalUnitDatabase,
- cacheExternalUnitDatabase,
- clearExternalUnitDatabaseCache,
-- * 'ExternalUnitDatabases'
ExternalUnitDatabases,
emptyExternalUnitDatabases,
insertExternalUnitDatabases,
deleteExternalUnitDatabases,
lookupExternalUnitDatabases,
- -- * 'UnitDatabase'
+ -- * 'UnitDatabase' and how to merge them.
UnitDatabase (..),
mergeDatabases,
UnitPrecedenceMap,
@@ -20,8 +13,6 @@ module GHC.Unit.External.Database (
compareByPreference,
-- * Reading packages from disk.
UnitDbConfig (..),
- readOrGetUnitDatabase,
- readUnitDatabases,
readUnitDatabase,
getUnitDbRefs,
resolveUnitDatabase,
@@ -48,8 +39,6 @@ import GHC.Utils.Panic
import Control.Monad
import Data.Char
-import Data.IORef
-import Data.IORef qualified as IORef
import Data.List (sortBy)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
@@ -60,40 +49,6 @@ import System.Directory
import System.Environment (getEnv)
import System.FilePath as FilePath
--- ----------------------------------------------------------------------------
--- ExternalUnitDatabaseCache
--- ----------------------------------------------------------------------------
-
--- | Mutable wrapper around 'ExternalUnitDatabases'.
-newtype ExternalUnitDatabaseCache unit = ExternalUnitDatabaseCache
- { eudc_databases :: IORef (ExternalUnitDatabases unit)
- }
-
-initExternalUnitDatabaseCache :: IO (ExternalUnitDatabaseCache unit)
-initExternalUnitDatabaseCache =
- ExternalUnitDatabaseCache <$> IORef.newIORef emptyExternalUnitDatabases
-
-readExternalUnitDatabases :: ExternalUnitDatabaseCache unit -> IO (ExternalUnitDatabases unit)
-readExternalUnitDatabases eudc =
- IORef.readIORef (eudc_databases eudc)
-
-modifyExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> (ExternalUnitDatabases unit -> ExternalUnitDatabases unit) -> IO ()
-modifyExternalUnitDatabaseCache eudc f =
- IORef.modifyIORef' (eudc_databases eudc) f
-
-readExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> OsPath -> IO (Maybe (UnitDatabase unit))
-readExternalUnitDatabase eudc path = do
- dbs <- readExternalUnitDatabases eudc
- pure $ lookupExternalUnitDatabases path dbs
-
-cacheExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> UnitDatabase unit -> IO ()
-cacheExternalUnitDatabase eudc db =
- modifyExternalUnitDatabaseCache eudc (insertExternalUnitDatabases db)
-
-clearExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> IO ()
-clearExternalUnitDatabaseCache eudc =
- modifyExternalUnitDatabaseCache eudc (const emptyExternalUnitDatabases)
-
-- ----------------------------------------------------------------------------
-- ExternalUnitDatabases
-- ----------------------------------------------------------------------------
@@ -230,12 +185,6 @@ data UnitDbConfig = UnitDbConfig
, unitDbConfigGHCDir :: FilePath
}
-readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId]
-readUnitDatabases logger db_cache cfg = do
- conf_refs <- getUnitDbRefs cfg
- confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
- mapM (readOrGetUnitDatabase logger db_cache cfg) confs
-
getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
getUnitDbRefs cfg = do
let system_conf_refs = [UserPkgDb, GlobalPkgDb]
@@ -285,17 +234,6 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
--- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
-readOrGetUnitDatabase :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
-readOrGetUnitDatabase logger db_cache cfg conf_file =
- readExternalUnitDatabase db_cache conf_file >>= \ case
- Nothing -> do
- new_db <- readUnitDatabase logger cfg conf_file
- cacheExternalUnitDatabase db_cache new_db
- pure new_db
- Just db ->
- pure db
-
-- | Read the 'UnitDatabase' at the given location.
readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase logger cfg conf_file = do
=====================================
compiler/GHC/Unit/External/Index.hs
=====================================
@@ -1,3 +1,45 @@
+-- | The 'UnitIndex' is a 'UnitEnv' wide data structure that shares
+-- external unit information across the 'UnitState' of all home units
+-- (e.g., 'HomeUnitEnv') in a particular 'UnitEnv'.
+--
+-- It caches already read unit databases, all processed 'UnitInfo's and
+-- the 'WireMap'.
+--
+-- This module is meant to be imported as @Index@.
+--
+-- A short overview of how the different types here related to 'UnitState', 'UnitEnv'
+-- and the 'HomeUnitEnv'.
+--
+-- ┌─────────┐
+-- │ UnitEnv │
+-- └────┬────┘
+-- ├───────────────────────┐
+-- │ │
+-- ┌────▼──────┐ ┌─────▼─────┐
+-- │HomeUnitEnv│ │ UnitIndex ├────────────────┐
+-- └────┬──────┘ └───────────┘ │
+-- │ │
+-- │ Reads cached unit DBs │
+-- ┌────▼──────┐ ┌─────────────────────┐ │
+-- │ UnitState ├──────────>ExternalUnitDatabases◄──────┤
+-- └────┬──┬───┘ └─────────────────────┘ │
+-- │ └───────────────────────┐ │
+-- │ Writes new UnitInfos │ │
+-- │ during initialisation │ │
+-- ┌────▼────────┐ ┌────────v──────────┐ │
+-- │ UnitInfoMap │ │ GlobalUnitInfoMap ◄────────┘
+-- └────┬────────┘ └────────^──────────┘
+-- │ │
+-- └──────────────────────────┘
+-- UnitInfoMap references
+-- GlobalUnitInfoMap values
+-- (All UnitInfos are shared)
+--
+-- Open arrow @A ───> B@: A uses B.
+-- Closed arrow @A ◄─── B@: A is a field of B.
+--
+-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more technical discussion
+-- about sharing 'UnitInfo's.
module GHC.Unit.External.Index (
-- * The 'UnitIndexCache'.
-- A mutable wrapper around 'UnitIndex'
@@ -6,12 +48,16 @@ module GHC.Unit.External.Index (
readUnitIndex,
modifyUnitIndexCache,
clearUnitIndexCache,
+ cacheExternalUnitDatabase,
+ readExternalUnitDatabases,
+ readExternalUnitDatabase,
-- * 'UnitIndex'
UnitIndex,
emptyUnitIndex,
wiringMap,
unwiringMap,
globalUnits,
+ externalUnitDatabases,
setWireMap,
wireMapExists,
addUnitInfoMap,
@@ -32,10 +78,14 @@ module GHC.Unit.External.Index (
updateWiredInUnits,
updateWiredInUnitsInUnitInfo,
updateWiredInUnitIdInModule,
+ -- * Reading external unit databases into the 'UnitIndexCache'
+ readOrGetUnitDatabase,
+ readUnitDatabases,
) where
import GHC.Prelude
+import GHC.Data.OsPath
import GHC.Data.ShortText qualified as ST
import GHC.Types.Unique.Map
import GHC.Unit.Database
@@ -46,17 +96,36 @@ import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Utils.Logger
+import Control.Monad (liftM)
import Data.Either
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
+import Data.Maybe (catMaybes)
-- ----------------------------------------------------------------------------
-- UnitIndex
-- ----------------------------------------------------------------------------
-- | Mutable version of 'UnitIndex'.
+--
+-- The 'UnitIndexCache' ensures that all calls to 'initUnits' will
+-- share the 'UnitInfo' if it is possible.
+--
+-- To share the 'UnitInfo', the 'UnitInfo' needs to be fully-resolved, i.e., its wired-in
+-- dependencies and modules need to be replaced with the 'UnitId' of the wired-in unit.
+-- Thus, the 'UnitIndexCache' caches both the global 'WireMap' and the 'UnitInfoMap'.
+--
+-- The 'WireMap' is globally valid, as other parts of the compiler rely on the fact
+-- that only one instance of wired-in units is used.
+--
+-- Memory Invariant: The 'UnitIndexCache' is the root object for retaining fully-resolved
+-- 'UnitInfo'. 'UnitState' is expected to reference only 'UnitInfo's from the 'UnitIndexCache'.
+-- There is exactly one fully-resolved 'UnitInfo' alive for each external unit per unit database.
+--
+-- A second instance may or may not be stored in the 'externalUnitDatabases', which represent the
+-- in-memory cache of the on-disk unit databases.
newtype UnitIndexCache = UnitIndexCache
{ uic_index :: IORef UnitIndex
}
@@ -66,21 +135,41 @@ initUnitIndexCache =
UnitIndexCache <$> IORef.newIORef emptyUnitIndex
readUnitIndex :: UnitIndexCache -> IO UnitIndex
-readUnitIndex eudc =
- IORef.readIORef (uic_index eudc)
+readUnitIndex uic =
+ IORef.readIORef (uic_index uic)
modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
-modifyUnitIndexCache eudc f =
- IORef.modifyIORef' (uic_index eudc) f
+modifyUnitIndexCache uic f =
+ IORef.modifyIORef' (uic_index uic) f
clearUnitIndexCache :: UnitIndexCache -> IO ()
-clearUnitIndexCache eudc =
- modifyUnitIndexCache eudc (const emptyUnitIndex)
+clearUnitIndexCache uic =
+ modifyUnitIndexCache uic (const emptyUnitIndex)
+
+cacheExternalUnitDatabase :: UnitIndexCache -> UnitDatabase UnitId -> IO ()
+cacheExternalUnitDatabase uic db =
+ modifyUnitIndexCache uic
+ (\ ui ->
+ ui
+ { ui_externalUnitDatabases = insertExternalUnitDatabases db (ui_externalUnitDatabases ui)
+ }
+ )
+
+readExternalUnitDatabases :: UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
+readExternalUnitDatabases uic =
+ externalUnitDatabases <$> readUnitIndex uic
+
+readExternalUnitDatabase :: UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
+readExternalUnitDatabase uic path = do
+ dbs <- readExternalUnitDatabases uic
+ pure $ lookupExternalUnitDatabases path dbs
-- | Global index for external units that can be shared across multiple 'HomeUnitEnv's.
--
-- Allows sharing of the 'WireMap' and 'UnitInfo's that are stored in the 'UnitState'
-- of each 'HomeUnitEnv'.
+--
+-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details about memory usage.
data UnitIndex = UnitIndex
{ ui_wireMap :: !WireMap
-- ^ A mapping from database unit keys to wired in unit ids.
@@ -95,10 +184,13 @@ data UnitIndex = UnitIndex
, ui_unitInfoMap :: !GlobalUnitInfoMap
-- ^ A global map for all fully-resolved 'UnitInfo's.
--
- -- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
- -- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
- -- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
- -- variables such as @${pkgroot}@ in paths.
+ -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more details
+ -- what we use this for and what a fully-resolved 'UnitInfo' is.
+ , ui_externalUnitDatabases :: !(ExternalUnitDatabases UnitId)
+ -- ^ Cache the already processed unit databases in-memory.
+ --
+ -- These 'GenericUnitInfo's have their paths resolved, e.g., no @${pkgroot}@ is
+ -- present any more.
}
-- | Get the 'WireMap'.
@@ -115,7 +207,18 @@ wiringMap = ui_wireMap
unwiringMap :: UnitIndex -> UnwireMap
unwiringMap = ui_unwireMap
+-- | Access the already processed unit databases.
+externalUnitDatabases :: UnitIndex -> ExternalUnitDatabases UnitId
+externalUnitDatabases = ui_externalUnitDatabases
+
-- | Access the global map of fully-resolved 'UnitInfo's.
+--
+-- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
+-- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
+-- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
+-- variables such as @${pkgroot}@ in paths.
+--
+-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for why this is helpful.
globalUnits :: UnitIndex -> GlobalUnitInfoMap
globalUnits = ui_unitInfoMap
@@ -124,6 +227,7 @@ emptyUnitIndex = UnitIndex
{ ui_wireMap = emptyWireMap
, ui_unwireMap = emptyUnwireMap
, ui_unitInfoMap = emptyGlobalUnitInfoMap
+ , ui_externalUnitDatabases = emptyExternalUnitDatabases
}
-- | Set the 'WireMap' of 'UnitIndex'.
@@ -167,7 +271,8 @@ type UnitAbiHash = ST.ShortText
--
-- However, a user can choose a conflicting 'UnitId', causing a conflict after all.
-- We use the 'UnitAbiHash' for disambiguation. If both 'UnitId' and 'UnitAbiHash' are
--- identical in separate unit databases, we can assume they are the same unit.
+-- identical in separate unit databases, we can assume they are the same unit, according
+-- to the documentation of GHC.
newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo))
-- | Lookup the 'UnitInfo' in the 'GlobalUnitInfoMap'.
@@ -238,7 +343,10 @@ updateWiredInUnitIndex wired_map pkgs unit_index = do
ui <- readUnitIndex unit_index
let
all_pkgs = updateWiredInUnits wired_map (ui_unitInfoMap ui) pkgs
- (new_pkgs, _pkgs_set) = partitionEithers all_pkgs
+ (new_pkgs', _pkgs_set) = partitionEithers all_pkgs
+ -- Make sure we force the 'UnitInfo' here.
+ -- Otherwise, we will retain a reference to the old 'UnitInfo'
+ new_pkgs <- traverse evaluateUnitInfoLists new_pkgs'
modifyUnitIndexCache unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
pure (map (either id id) all_pkgs)
@@ -310,3 +418,23 @@ upd_wired_in :: WireMap -> UnitId -> UnitId
upd_wired_in wiredInMap key
| Just key' <- lookupWireMap key wiredInMap = key'
| otherwise = key
+
+-- -----------------------------------------------------------------------------
+-- Reading the unit database(s) into the 'UnitIndexCache'
+
+readUnitDatabases :: Logger -> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
+readUnitDatabases logger db_cache cfg = do
+ conf_refs <- getUnitDbRefs cfg
+ confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
+ mapM (readOrGetUnitDatabase logger db_cache cfg) confs
+
+-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
+readOrGetUnitDatabase :: Logger -> UnitIndexCache -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
+readOrGetUnitDatabase logger db_cache cfg conf_file =
+ readExternalUnitDatabase db_cache conf_file >>= \ case
+ Nothing -> do
+ new_db <- readUnitDatabase logger cfg conf_file
+ cacheExternalUnitDatabase db_cache new_db
+ pure new_db
+ Just db ->
+ pure db
=====================================
compiler/GHC/Unit/External/ModuleOrigin.hs
=====================================
@@ -7,12 +7,12 @@ module GHC.Unit.External.ModuleOrigin (
originEmpty,
) where
+import Data.Semigroup qualified as Semigroup
import GHC.Prelude
import GHC.Unit.External.Validate
import GHC.Unit.Info
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import qualified Data.Semigroup as Semigroup
-- | Given a module name, there may be multiple ways it came into scope,
-- possibly simultaneously. This data type tracks all the possible ways
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -6,7 +6,6 @@ module GHC.Unit.State (
module GHC.Unit.Info,
-- * Reading the package config, and processing cmdline args
UnitState(..),
- TrustOverlay(..),
UnitDatabase (..),
UnitErr (..),
emptyUnitState,
@@ -16,6 +15,13 @@ module GHC.Unit.State (
getUnitDbRefs,
resolveUnitDatabase,
listUnitInfo,
+ -- * Overlays over the unit set
+ TrustOverlay,
+ IsTrusted(..),
+ lookupTrustOverlay,
+ distrustUnits,
+ trustUnits,
+ emptyTrustOverlay,
-- * Querying the package config
lookupUnit,
lookupUnit',
@@ -252,12 +258,19 @@ data IsTrusted
| Distrusted
deriving ( Eq, Ord )
+-- | The 'TrustOverlay' stores user overwrites of the on-disk 'unitIsTrusted' status.
+--
+-- The user can overwrite this value via flags such as @-distrust-all-packages@.
+-- We do not modify the 'UnitInfo' directory, but rather store this user selection
+-- in the 'TrustOverlay'.
+--
+-- This allows us to share the 'UnitInfo' completely and saves us memory.
newtype TrustOverlay = TrustOverlay
{ trustOverlay :: UniqMap UnitId IsTrusted
}
lookupTrustOverlay :: TrustOverlay -> UnitId -> Maybe IsTrusted
-lookupTrustOverlay (TrustOverlay to) = lookupUniqMap to
+lookupTrustOverlay to = lookupUniqMap (trustOverlay to)
distrustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
distrustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addToUniqMap acc uid Distrusted) to elements
@@ -268,6 +281,57 @@ trustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addT
emptyTrustOverlay :: TrustOverlay
emptyTrustOverlay = TrustOverlay emptyUniqMap
+{-
+Note [Sharing 'UnitInfo's across the 'UnitEnv']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'UnitState' and 'UnitIndex' are closely related.
+
+The 'UnitState' stores all information about the external units referenced by
+a single 'HomeUnitEnv'.
+As a reminder, the 'HomeUnitEnv' stores all information specific to a single home unit,
+such as the 'HomePackageTable', 'DynFlags' and the 'UnitState'.
+The 'UnitState' retains the 'unitInfoMap', an in-memory representation of
+the unit databases that a 'HomeUnitEnv' depends on.
+Multiple home units can depend on the same unit database, and reference the same
+'UnitInfo's across the GHC session.
+We share all 'UnitInfo's across multiple 'HomeUnitEnv's, saving a lot of
+duplication of the same 'UnitInfo'.
+This what the 'UnitIndex' takes care of.
+
+The 'UnitIndex' stores all fully-resolved 'UnitInfo's that can be referenced
+by the 'UnitState'.'unitInfoMap'.
+We consider a 'UnitInfo' as fully-resolved, if its dependencies were updated to reference the
+wired-in units (e.g., 'wiringMap') and the wired-in units are updated as well.
+See Note [Wired-in units] for more details on wired-in units.
+Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
+variables such as @${pkgroot}@ in paths.
+
+As such, we can consider the 'UnitIndex' to be global data that is referenced by
+the 'UnitState' for better sharing of 'UnitInfo's.
+
+In fact, using the 'UnitIndex', we can impose a hard upper bound on the number
+of live 'UnitInfo's in a GHC session:
+
+> For each on-disk 'GenericUnitInfo', there are at most two objects alive.
+
+One instance is stored in 'ExternalUnitDatabases' where variables are resolved,
+but the wired-in units haven't been resolved.
+
+The second instance is the fully-resolved 'UnitInfo' stored in the 'UnitIndex'.
+
+See the module documentation for 'GHC.Unit.External.Index' for an overview
+of how the types relate to each other.
+-}
+
+-- | The 'UnitState' contains a plethora of information local to a single 'HomeUnitEnv'.
+--
+-- It stores module visibilities, unit trust for @SafeHaskell@, available units for error messages,
+-- explicit unit dependencies and knows how to instantiate backpack signature and holes
+-- on demand.
+--
+-- A 'HomeUnitEnv' should rarely/never have to look into the 'UnitIndex', all external
+-- unit related information is stored in the 'UnitState'.
+--
data UnitState = UnitState {
-- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted
-- so that only valid units are here. 'UnitInfo' reflects
@@ -276,6 +340,7 @@ data UnitState = UnitState {
-- may have the 'exposed' flag be 'False'.)
--
-- All values are shared with 'UnitIndex'.'globalUnits'.
+ -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
unitInfoMap :: UnitInfoMap,
-- | Set of units that we trust.
@@ -283,7 +348,10 @@ data UnitState = UnitState {
-- Local overlay of 'UnitInfo'.
-- This avoids modifying the 'UnitInfo' directly, potentially saving
-- a lot of duplication.
- trustedUnits :: TrustOverlay,
+ --
+ -- We keep this in WHNF as it is relatively cheap but could easily retain
+ -- references to bigger structures.
+ trustedUnits :: !TrustOverlay,
-- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
-- package name (e.g. different instantiations), then we return one of them...
@@ -333,8 +401,6 @@ emptyUnitState = UnitState {
unitInfoMap = emptyUniqMap,
trustedUnits = emptyTrustOverlay,
packageNameMap = emptyUFM,
- -- wireMap = emptyUniqMap,
- -- unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
homeUnitDepends = Set.empty,
@@ -439,14 +505,16 @@ isUnitInfoTrusted ue u =
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' and 'packageDBFlags' fields of the 'DynFlags', and it will
-- update the 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> UnitIndexCache -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags unit_index cached_dbs home_units = do
+--
+-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for implementation details.
+initUnits :: Logger -> DynFlags -> UnitIndexCache -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags unit_index home_units = do
let forceUnitInfoMap state = unitInfoMap state `seq` ()
unit_state <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger unit_index cached_dbs (initUnitConfig dflags home_units)
+ $ mkUnitState logger unit_index (initUnitConfig dflags home_units)
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -638,10 +706,9 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs
mkUnitState
:: Logger
-> UnitIndexCache
- -> ExternalUnitDatabaseCache UnitId
-> UnitConfig
-> IO UnitState
-mkUnitState logger unit_index db_cache cfg = do
+mkUnitState logger unit_index cfg = do
{-
Plan.
@@ -695,7 +762,7 @@ mkUnitState logger unit_index db_cache cfg = do
we build a mapping saying what every in scope module name points to.
-}
- dbs <- readUnitDatabases logger db_cache (initUnitDbConfig cfg)
+ dbs <- readUnitDatabases logger unit_index (initUnitDbConfig cfg)
-- distrust all units if the flag is set
let distrustUnitsOfDb overlay db = foldl' (\ acc ui -> distrustUnits [unitId ui] acc) overlay (unitDatabaseUnits db)
@@ -713,7 +780,7 @@ mkUnitState logger unit_index db_cache cfg = do
debugTraceMsg logger 2 $
text "package flags" <+> ppr other_flags
- let !home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
+ let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
(pkg_map1, prec_map) <- mergeDatabases logger dbs
@@ -727,7 +794,7 @@ mkUnitState logger unit_index db_cache cfg = do
-- Compute trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
- !trustUnitsOverlay <- mayThrowUnitErr
+ trustUnitsOverlay <- mayThrowUnitErr
$ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
distrustedUnitsOverlay (reverse (unitConfigFlagsTrusted cfg))
let pkgs1 = nonDetEltsUniqMap pkg_map2
@@ -769,12 +836,12 @@ mkUnitState logger unit_index db_cache cfg = do
-- Note: we NEVER expose indefinite packages by
-- default, because it's almost assuredly not
-- what you want (no mix-in linking has occurred).
- let !x = fsPackageName p in if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
then addToUniqMap vm (mkUnit p)
UnitVisibility {
uv_expose_all = True,
uv_renamings = [],
- uv_package_name = First (Just x),
+ uv_package_name = First (Just $ fsPackageName p),
uv_requirements = emptyUniqMap,
uv_explicit = Nothing
}
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -857,7 +857,7 @@ installInteractiveHomeUnits dflags = do
env <- GHC.getSession
let unit_index = hscUIC env
(unit_state,home_unit,_mconstants) <-
- liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units
+ liftIO $ initUnits logger dflags unit_index all_home_units
hpt <- liftIO emptyHomePackageTable
pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
=====================================
testsuite/tests/driver/TUnitInfo/Makefile
=====================================
@@ -2,17 +2,38 @@ TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
-.PHONY: generic-unit-info-space_Prep
-generic-unit-info-space_Prep:
+.PHONY: generic-unit-info-space-single_Prep
+generic-unit-info-space-single_Prep:
-.PHONY: generic-unit-info-space
-generic-unit-info-space:
+.PHONY: generic-unit-info-space-single
+generic-unit-info-space-single:
"$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \
-package ghc -package base -package ghc-internal -threaded
./generic-unit-info-space$(exeext) \
"`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \
"`'$(GHC_PKG)' --no-user-package-db list --simple-output | wc -w`" \
+ -clear-package-db -global-package-db -no-user-package-db \
+ +RTS -hT --no-automatic-heap-samples -RTS
+
+# Generate 50 trivial home units. The number of 'UnitInfo's must not increase
+# linearly in the number of home units
+HOME_UNITS_01 := 50
+UNITS := $(foreach p,$(shell seq 0 $$(( $(HOME_UNITS_01) - 1 ))),-unit @unitp$(p))
+.PHONY: generic-unit-info-space-mhu_Prep
+generic-unit-info-space-mhu_Prep:
+ ./genMhu.sh $(HOME_UNITS_01)
+
+
+.PHONY: generic-unit-info-space-mhu
+generic-unit-info-space-mhu:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \
+ -package ghc -package base -package ghc-internal -threaded
+
+ ./generic-unit-info-space$(exeext) \
+ "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \
+ "`'$(GHC_PKG)' --global list --simple-output | wc -w`" \
+ $(UNITS) \
+RTS -hT --no-automatic-heap-samples -RTS
=====================================
testsuite/tests/driver/TUnitInfo/all.T
=====================================
@@ -1,7 +1,15 @@
# A test for checking the number of live GenericUnitInfo objects
-test('generic-unit-info-space'
- , [ extra_files(['Foo.hs'])
- , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space_Prep')
+test('generic-unit-info-space-single'
+ , [ extra_files(['Foo.hs', 'generic-unit-info-space.hs'])
+ , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-single_Prep')
]
, makefile_test
- , ['generic-unit-info-space'])
+ , ['generic-unit-info-space-single'])
+
+# A test for checking the number of live GenericUnitInfo objects
+test('generic-unit-info-space-mhu'
+ , [ extra_files(['genMhu.sh', 'generic-unit-info-space.hs'])
+ , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-mhu_Prep')
+ ]
+ , makefile_test
+ , ['generic-unit-info-space-mhu'])
=====================================
testsuite/tests/driver/TUnitInfo/genMhu.sh
=====================================
@@ -0,0 +1,26 @@
+#! /usr/bin/env bash
+
+set -euo pipefail
+
+HOME_UNITS=${1:-50}
+
+unit_dir() { echo "p$1"; }
+unit_fname(){ echo "unitp$1"; }
+mod_name() { echo "Mod$1"; }
+
+mk_unit_file() {
+ local p=$1
+ echo "-clear-package-db -global-package-db -no-user-package-db -working-dir $(unit_dir "$p") -this-unit-id $(unit_dir "$p") $(mod_name "$p") ${deps[*]}" \
+ > "$(unit_fname "$p")"
+}
+
+mk_top_mod() {
+ local p=$1
+ echo "module $(mod_name "$p") where" > "$(unit_dir "$p")/$(mod_name "$p").hs"
+}
+
+for ((p = 0; p < HOME_UNITS; p++)); do
+ mkdir "$(unit_dir "$p")"
+ mk_unit_file "$p"
+ mk_top_mod "$p"
+done
=====================================
testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
=====================================
@@ -0,0 +1,2 @@
+### Heap Census
+There are exactly two GenericUnitInfo closures alive per on-disk package
=====================================
testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.stdout
=====================================
@@ -0,0 +1,2 @@
+### Heap Census
+There are exactly two GenericUnitInfo closures alive per on-disk package
=====================================
testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
=====================================
@@ -6,6 +6,7 @@ import GHC.Data.FastString (mkFastStringByteString)
import qualified GHC.Data.ShortText as ST
import GHC.Driver.Monad
import GHC.Driver.Env.Types
+import GHC.Driver.Session.Units
import GHC.Internal.Heap.Closures (closureSize, asBox)
import GHC.Platform
import GHC.Profiling
@@ -14,6 +15,7 @@ import GHC.Unit.Types (stringToUnitId)
import Control.Monad (guard, when)
import Data.Version (makeVersion)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Maybe as Maybe
import qualified Data.List as List
import System.Environment
@@ -24,19 +26,32 @@ main :: IO ()
main = do
libdir:numberOfGlobalPkgsStr:restArgs <- getArgs
runGhc (Just libdir) $ do
- initGhcM (read numberOfGlobalPkgsStr) $ ["-clear-package-db", "-global-package-db", "-no-user-package-db"] ++ restArgs
-
+ initGhcM (read numberOfGlobalPkgsStr) restArgs
initGhcM :: Int -> [String] -> Ghc ()
initGhcM numOfPkgs xs = do
session <- getSession
df1 <- getSessionDynFlags
- let cmdOpts = ["-fforce-recomp"] ++ xs
+ let (units, args) = extractUnits xs
+ let cmdOpts = ["-fforce-recomp"] ++ args
+
(df2, leftovers, _) <- parseDynamicFlags (hsc_logger session) df1 (map noLoc cmdOpts)
setSessionDynFlags df2
- ts <- mapM (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers
- setTargets ts
- _ <- load LoadAllTargets
+
+ targets <- case NE.nonEmpty units of
+ Nothing ->
+ traverse (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers
+ Just mhu -> do
+ ts <- initMulti mhu (\ _ _ _ _ -> pure ())
+ traverse (\(n, mu, mp) -> guessTarget n mu mp) ts
+
+ setTargets targets
+ success <- load LoadAllTargets
+
+ liftIO $ when (failed success) $ do
+ putStrLn "Failed to load targets"
+ Exit.exitFailure
+
liftIO $ do
requestHeapCensus
performGC
@@ -64,15 +79,17 @@ initGhcM numOfPkgs xs = do
-- The output should be:
--
-- @
- -- 2 * number of packages in global unit db * 8 * word_size * sizeof(struct GenericUnitInfo)
+ -- 2 * number of packages in global unit db * word_size * sizeof(struct GenericUnitInfo)
-- @
--
- -- This test simply assures, that in a single home unit case, we don't leak 'UnitInfo's
+ -- This test simply assures, that when we load a session, we don't leak 'UnitInfo's
--
- -- If this number changes for any reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak.
- when (num /= expectedSizeInBytes) $ do
+ -- If this number changes without a good reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak.
+ -- We say less than the expected size is accepted, because in the multiple-home-units case, we don't force the second
+ -- UnitInfo closure enough after initial processing.
+ when (num > expectedSizeInBytes) $ do
putStrLn "Space leak detected by generic-unit-info-space test:"
- putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when == (" ++ show expectedNumberOfUnitInfos ++ ") are expected"
+ putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when <= (" ++ show expectedNumberOfUnitInfos ++ ") are expected"
readFile hpFile >>= putStrLn
Exit.exitFailure
return ()
@@ -135,3 +152,11 @@ minimalUnitInfo = GenericUnitInfo
, unitIsExposed = True
, unitIsTrusted = False
}
+
+extractUnits :: [String] -> ([String], [String])
+extractUnits = go [] []
+ where
+ -- TODO: we should likely use the 'processCmdLineP' instead
+ go units rest ("-unit" : x : xs) = go (x : units) rest xs
+ go units rest (x : xs) = go units (x : rest) xs
+ go units rest [] = (reverse units, reverse rest)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85ec1752a307b199cfecc40e63fe2e0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85ec1752a307b199cfecc40e63fe2e0…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0