Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e23c99b9 by Cheng Shao at 2025-09-18T00:17:24-04:00 compiler/ghci: replace the LoadDLL message with LoadDLLs As a part of #25407, this commit changes the LoadDLL message to LoadDLLs, which takes a list of DLL paths to load and returns the list of remote pointer handles. The wasm dyld is refactored to take advantage of LoadDLLs and harvest background parallelism. On other platforms, LoadDLLs is based on a fallback codepath that does sequential loading. The driver is not actually emitting singular LoadDLLs message with multiple DLLs yet, this is left in subsequent commits. Co-authored-by: Codex - - - - - cfb6bba1 by Cheng Shao at 2025-09-18T00:17:24-04:00 driver: separate downsweep/upsweep phase in loadPackages' This commit refactors GHC.Linker.Loader.loadPackages' to be separated into downsweep/upsweep phases: - The downsweep phase performs dependency analysis and generates a list of topologically sorted packages to load - The upsweep phase sequentially loads these packages by calling loadPackage This is a necessary refactoring to make it possible to make loading of DLLs concurrent. - - - - - b3464604 by Cheng Shao at 2025-09-18T00:17:24-04:00 driver: emit single LoadDLLs message to load multiple DLLs This commit refactors the driver so that it emits a single LoadDLLs message to load multiple DLLs in GHC.Linker.Loader.loadPackages'. Closes #25407. ------------------------- Metric Increase: TcPlugin_RewritePerf ------------------------- - - - - - 36ca8b5e by sheaf at 2025-09-18T00:17:39-04:00 Enable TcM plugins in initTc This commit ensures that we run typechecker plugins and defaulting plugins whenever we call initTc. In particular, this ensures that the pattern-match checker, which calls 'initTcDsForSolver' which calls 'initTc', runs with typechecker plugins enabled. This matters for situations like: merge :: Vec n a -> Vec n a -> Vec (2 * n) a merge Nil Nil = Nil merge (a <: as) (b <: bs) = a :< (b <: merge as bs) in which we need the typechecker plugin to run in order to tell us that the Givens would be inconsistent in the additional equation merge (_ <: _) Nil and thus that the equation is not needed. Fixes #26395 - - - - - 8919e7f9 by Cheng Shao at 2025-09-18T00:17:40-04:00 rel-eng: update fedora image to 42 This patch is a part of #25876 and updates fedora image to 42. - - - - - 22 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Monad.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/rts/linker/T2615.hs - + testsuite/tests/tcplugins/T26395.hs - + testsuite/tests/tcplugins/T26395.stderr - + testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/all.T - utils/jsffi/dyld.mjs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -2,7 +2,7 @@ variables: GIT_SSL_NO_VERIFY: "1" # Commit of ghc/ci-images repository from which to pull Docker images - DOCKER_REV: be4ac2cd18f38e63b263e2a27c76a7c279385796 + DOCKER_REV: a97d5c67d803c6b3811c6cccdf33dc8e9d7eafe3 # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. @@ -433,14 +433,14 @@ hadrian-ghc-in-ghci: hadrian-multi: stage: testing needs: - - job: x86_64-linux-fedora33-release + - job: x86_64-linux-fedora42-release optional: true - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release optional: true - - job: release-x86_64-linux-fedora33-release + - job: release-x86_64-linux-fedora42-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" before_script: # workaround for docker permissions - sudo chown ghc:ghc -R . @@ -460,7 +460,7 @@ hadrian-multi: - ls - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora33-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -522,17 +522,17 @@ test-cabal-reinstall-x86_64-linux-deb10: abi-test-nightly: stage: full-build needs: - - job: nightly-x86_64-linux-fedora33-release-hackage - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release-hackage + - job: nightly-x86_64-linux-fedora42-release tags: - x86_64-linux - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" dependencies: null before_script: - mkdir -p normal - mkdir -p hackage - - tar -xf ghc-x86_64-linux-fedora33-release.tar.xz -C normal/ - - tar -xf ghc-x86_64-linux-fedora33-release-hackage_docs.tar.xz -C hackage/ + - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C normal/ + - tar -xf ghc-x86_64-linux-fedora42-release-hackage_docs.tar.xz -C hackage/ script: - .gitlab/ci.sh compare_interfaces_of "normal/ghc-*" "hackage/ghc-*" artifacts: @@ -609,9 +609,9 @@ doc-tarball: hackage-doc-tarball: stage: packaging needs: - - job: nightly-x86_64-linux-fedora33-release-hackage + - job: nightly-x86_64-linux-fedora42-release-hackage optional: true - - job: release-x86_64-linux-fedora33-release-hackage + - job: release-x86_64-linux-fedora42-release-hackage optional: true - job: source-tarball tags: @@ -628,7 +628,7 @@ hackage-doc-tarball: - hackage_docs before_script: - tar -xf ghc-*[0-9]-src.tar.xz - - tar -xf ghc-x86_64-linux-fedora33-release.tar.xz -C ghc*/ + - tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C ghc*/ script: - cd ghc*/ - mv .gitlab/rel_eng/upload_ghc_libs.py . @@ -754,7 +754,7 @@ test-bootstrap: # Triggering jobs in the ghc/head.hackage project requires that we have a job # token for that repository. Furthermore the head.hackage CI job must have # access to an unprivileged access token with the ability to query the ghc/ghc -# project such that it can find the job ID of the fedora33 job for the current +# project such that it can find the job ID of the fedora42 job for the current # pipeline. # # hackage-lint: Can be triggered on any MR, normal validate pipeline or nightly build. @@ -841,7 +841,7 @@ nightly-hackage-lint: nightly-hackage-perf: needs: - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release optional: true artifacts: false - job: nightly-aarch64-linux-deb12-validate @@ -860,7 +860,7 @@ nightly-hackage-perf: release-hackage-lint: needs: - - job: release-x86_64-linux-fedora33-release + - job: release-x86_64-linux-fedora42-release optional: true artifacts: false - job: release-aarch64-linux-deb12-release+no_split_sections @@ -946,13 +946,13 @@ perf-nofib: allow_failure: true stage: testing needs: - - job: x86_64-linux-fedora33-release + - job: x86_64-linux-fedora42-release optional: true - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release optional: true - - job: release-x86_64-linux-fedora33-release + - job: release-x86_64-linux-fedora42-release optional: true - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" rules: - when: never - *full-ci @@ -965,7 +965,7 @@ perf-nofib: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ../ghc-x86_64-linux-fedora33-release.tar.xz -C tmp + tar -xf ../ghc-x86_64-linux-fedora42-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -989,21 +989,21 @@ perf-nofib: perf: stage: testing needs: - - job: x86_64-linux-fedora33-release + - job: x86_64-linux-fedora42-release optional: true - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release optional: true - - job: release-x86_64-linux-fedora33-release + - job: release-x86_64-linux-fedora42-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" tags: - x86_64-linux-perf script: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora33-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -1027,14 +1027,14 @@ perf: abi-test: stage: testing needs: - - job: x86_64-linux-fedora33-release + - job: x86_64-linux-fedora42-release optional: true - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release optional: true - - job: release-x86_64-linux-fedora33-release + - job: release-x86_64-linux-fedora42-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" rules: - if: $CI_MERGE_REQUEST_ID - if: '$CI_COMMIT_BRANCH == "master"' @@ -1045,7 +1045,7 @@ abi-test: - root=$(pwd)/ghc - | mkdir tmp - tar -xf ghc-x86_64-linux-fedora33-release.tar.xz -C tmp + tar -xf ghc-x86_64-linux-fedora42-release.tar.xz -C tmp pushd tmp/ghc-*/ ./configure --prefix=$root make install @@ -1200,7 +1200,7 @@ ghcup-metadata-nightly: extends: .ghcup-metadata # Explicit needs for validate pipeline because we only need certain bindists needs: - - job: nightly-x86_64-linux-fedora33-release + - job: nightly-x86_64-linux-fedora42-release artifacts: false - job: nightly-x86_64-linux-ubuntu24_04-validate artifacts: false @@ -1251,7 +1251,7 @@ ghcup-metadata-nightly: # Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV" dependencies: null tags: - x86_64-linux ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -82,7 +82,7 @@ The generated names for the jobs is important as there are a few downstream cons of the jobs artifacts. Therefore some care should be taken if changing the generated names of jobs to update these other places. -1. Fedora33 jobs are required by head.hackage +1. fedora42 jobs are required by head.hackage 2. The fetch-gitlab release utility pulls release artifacts from the 3. The ghc-head-from script downloads release artifacts based on a pipeline change. 4. Some subsequent CI jobs have explicit dependencies (for example docs-tarball, perf, perf-nofib) @@ -118,8 +118,7 @@ data LinuxDistro | Debian11Js | Debian10 | Debian9 - | Fedora33 - | Fedora38 + | Fedora42 | Ubuntu2404LoongArch64 | Ubuntu2404 | Ubuntu2204 @@ -319,8 +318,7 @@ distroName Debian12Riscv = "deb12-riscv" distroName Debian12Wine = "deb12-wine" distroName Debian10 = "deb10" distroName Debian9 = "deb9" -distroName Fedora33 = "fedora33" -distroName Fedora38 = "fedora38" +distroName Fedora42 = "fedora42" distroName Ubuntu2404LoongArch64 = "ubuntu24_04-loongarch" distroName Ubuntu1804 = "ubuntu18_04" distroName Ubuntu2004 = "ubuntu20_04" @@ -501,14 +499,6 @@ alpineVariables arch = mconcat $ distroVariables :: Arch -> LinuxDistro -> Variables distroVariables arch Alpine312 = alpineVariables arch distroVariables arch Alpine322 = alpineVariables arch -distroVariables _ Fedora33 = mconcat - -- LLC/OPT do not work for some reason in our fedora images - -- These tests fail with this error: T11649 T5681 T7571 T8131b - -- +/opt/llvm/bin/opt: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/opt) - -- +/opt/llvm/bin/llc: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/llc) - [ "LLC" =: "/bin/false" - , "OPT" =: "/bin/false" - ] distroVariables _ _ = mempty ----------------------------------------------------------------------------- @@ -1207,13 +1197,13 @@ rhel_x86 = fedora_x86 :: [JobGroup Job] fedora_x86 = - [ -- Fedora33 job is always built with perf so there's one job in the normal + [ -- Fedora42 job is always built with perf so there's one job in the normal -- validate pipeline which is built with perf. - fastCI (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig) + fastCI (standardBuildsWithConfig Amd64 (Linux Fedora42) releaseConfig) -- This job is only for generating head.hackage docs - , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig)) - , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) dwarf) - , disableValidate (standardBuilds Amd64 (Linux Fedora38)) + , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora42) releaseConfig)) + , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora42) dwarf) + , disableValidate (standardBuilds Amd64 (Linux Fedora42)) ] where hackage_doc_job = rename (<> "-hackage") . modifyJobs (addVariable "HADRIAN_ARGS" "--haddock-for-hackage") @@ -1375,7 +1365,7 @@ platform_mapping = Map.map go combined_result , "x86_64-linux-deb11-validate" , "x86_64-linux-deb12-validate" , "x86_64-linux-deb10-validate+debug_info" - , "x86_64-linux-fedora33-release" + , "x86_64-linux-fedora42-release" , "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate" , "x86_64-windows-validate" , "aarch64-linux-deb12-validate" @@ -1390,13 +1380,13 @@ platform_mapping = Map.map go combined_result , "nightly-aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate" , "nightly-x86_64-linux-alpine3_12-validate+fully_static" , "nightly-x86_64-linux-deb10-validate" - , "nightly-x86_64-linux-fedora33-release" + , "nightly-x86_64-linux-fedora42-release" , "nightly-x86_64-windows-validate" , "release-x86_64-linux-alpine3_12-release+fully_static+no_split_sections" , "release-x86_64-linux-deb10-release" , "release-x86_64-linux-deb11-release" , "release-x86_64-linux-deb12-release" - , "release-x86_64-linux-fedora33-release" + , "release-x86_64-linux-fedora42-release" , "release-x86_64-windows-release" ] ===================================== .gitlab/jobs.yaml ===================================== @@ -2942,7 +2942,7 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora33-release": { + "nightly-x86_64-linux-fedora42-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -2953,7 +2953,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -2963,14 +2963,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -2996,18 +2996,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release", + "TEST_ENV": "x86_64-linux-fedora42-release", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora33-release-hackage": { + "nightly-x86_64-linux-fedora42-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3018,7 +3016,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3028,14 +3026,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3061,19 +3059,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release", + "TEST_ENV": "x86_64-linux-fedora42-release", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora33-validate+debug_info": { + "nightly-x86_64-linux-fedora42-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3084,7 +3080,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-validate+debug_info.tar.xz", + "ghc-x86_64-linux-fedora42-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3094,14 +3090,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3127,18 +3123,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-validate+debug_info", - "BUILD_FLAVOUR": "validate+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate", + "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-validate+debug_info", + "TEST_ENV": "x86_64-linux-fedora42-validate", "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-fedora38-validate": { + "nightly-x86_64-linux-fedora42-validate+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -3149,7 +3143,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-fedora38-validate.tar.xz", + "ghc-x86_64-linux-fedora42-validate+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -3159,14 +3153,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora38-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora38:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -3192,12 +3186,12 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora38-validate", - "BUILD_FLAVOUR": "validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate+debug_info", + "BUILD_FLAVOUR": "validate+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora38-validate", + "TEST_ENV": "x86_64-linux-fedora42-validate+debug_info", "XZ_OPT": "-9" } }, @@ -4814,7 +4808,7 @@ "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora33-release": { + "release-x86_64-linux-fedora42-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4825,7 +4819,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4835,14 +4829,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -4868,19 +4862,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release", + "TEST_ENV": "x86_64-linux-fedora42-release", "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora33-release+debug_info": { + "release-x86_64-linux-fedora42-release+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4891,7 +4883,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora33-release+debug_info.tar.xz", + "ghc-x86_64-linux-fedora42-release+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4901,14 +4893,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -4934,19 +4926,17 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release+debug_info", "BUILD_FLAVOUR": "release+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release+debug_info", + "TEST_ENV": "x86_64-linux-fedora42-release+debug_info", "XZ_OPT": "-9" } }, - "release-x86_64-linux-fedora33-release-hackage": { + "release-x86_64-linux-fedora42-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4957,7 +4947,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4967,14 +4957,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -5000,80 +4990,14 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release", - "XZ_OPT": "-9" - } - }, - "release-x86_64-linux-fedora38-release": { - "after_script": [ - ".gitlab/ci.sh save_cache", - ".gitlab/ci.sh save_test_output", - ".gitlab/ci.sh clean", - "cat ci_timings.txt" - ], - "allow_failure": false, - "artifacts": { - "expire_in": "1 year", - "paths": [ - "ghc-x86_64-linux-fedora38-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-fedora38-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora38:$DOCKER_REV", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)", - "when": "on_success" - } - ], - "script": [ - "sudo chown ghc:ghc -R .", - ".gitlab/ci.sh setup", - ".gitlab/ci.sh configure", - ".gitlab/ci.sh build_hadrian", - ".gitlab/ci.sh test_hadrian" - ], - "stage": "full-build", - "tags": [ - "x86_64-linux" - ], - "variables": { - "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora38-release", - "BUILD_FLAVOUR": "release", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "IGNORE_PERF_FAILURES": "all", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora38-release", + "TEST_ENV": "x86_64-linux-fedora42-release", "XZ_OPT": "-9" } }, @@ -7108,7 +7032,7 @@ "TEST_ENV": "x86_64-linux-deb9-validate" } }, - "x86_64-linux-fedora33-release": { + "x86_64-linux-fedora42-release": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7119,7 +7043,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7129,14 +7053,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7145,7 +7069,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora33-release(\\s|$).*/)) || (($ONLY_JOBS == null) && ((\"true\" == \"true\")))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-release(\\s|$).*/)) || (($ONLY_JOBS == null) && ((\"true\" == \"true\")))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7162,17 +7086,15 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release" + "TEST_ENV": "x86_64-linux-fedora42-release" } }, - "x86_64-linux-fedora33-release-hackage": { + "x86_64-linux-fedora42-release-hackage": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7183,7 +7105,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-release.tar.xz", + "ghc-x86_64-linux-fedora42-release.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7193,14 +7115,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7209,7 +7131,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora33-release(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-release(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7226,18 +7148,16 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-release", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-release", "BUILD_FLAVOUR": "release", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "HADRIAN_ARGS": "--haddock-for-hackage", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-release" + "TEST_ENV": "x86_64-linux-fedora42-release" } }, - "x86_64-linux-fedora33-validate+debug_info": { + "x86_64-linux-fedora42-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7248,7 +7168,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora33-validate+debug_info.tar.xz", + "ghc-x86_64-linux-fedora42-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7258,14 +7178,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora33-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7274,7 +7194,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora33-validate\\+debug_info(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7291,17 +7211,15 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora33-validate+debug_info", - "BUILD_FLAVOUR": "validate+debug_info", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate", + "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "LLC": "/bin/false", - "OPT": "/bin/false", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora33-validate+debug_info" + "TEST_ENV": "x86_64-linux-fedora42-validate" } }, - "x86_64-linux-fedora38-validate": { + "x86_64-linux-fedora42-validate+debug_info": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -7312,7 +7230,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-fedora38-validate.tar.xz", + "ghc-x86_64-linux-fedora42-validate+debug_info.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -7322,14 +7240,14 @@ "when": "always" }, "cache": { - "key": "x86_64-linux-fedora38-$CACHE_REV", + "key": "x86_64-linux-fedora42-$CACHE_REV", "paths": [ "cabal-cache", "toolchain" ] }, "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora38:$DOCKER_REV", + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora42:$DOCKER_REV", "needs": [ { "artifacts": false, @@ -7338,7 +7256,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora38-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-fedora42-validate\\+debug_info(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -7355,12 +7273,12 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-fedora38-validate", - "BUILD_FLAVOUR": "validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-fedora42-validate+debug_info", + "BUILD_FLAVOUR": "validate+debug_info", "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-fedora38-validate" + "TEST_ENV": "x86_64-linux-fedora42-validate+debug_info" } }, "x86_64-linux-rocky8-validate": { ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -23,10 +23,8 @@ def job_triple(job_name): 'release-x86_64-linux-ubuntu22_04-release': 'x86_64-ubuntu22_04-linux', 'release-x86_64-linux-ubuntu20_04-release': 'x86_64-ubuntu20_04-linux', 'release-x86_64-linux-ubuntu18_04-release': 'x86_64-ubuntu18_04-linux', - 'release-x86_64-linux-fedora38-release': 'x86_64-fedora38-linux', - 'release-x86_64-linux-fedora33-release+debug_info': 'x86_64-fedora33-linux-dwarf', - 'release-x86_64-linux-fedora33-release': 'x86_64-fedora33-linux', - 'release-x86_64-linux-fedora27-release': 'x86_64-fedora27-linux', + 'release-x86_64-linux-fedora42-release': 'x86_64-fedora42-linux', + 'release-x86_64-linux-fedora42-release+debug_info': 'x86_64-fedora42-linux-dwarf', 'release-x86_64-linux-deb12-release': 'x86_64-deb12-linux', 'release-x86_64-linux-deb11-release': 'x86_64-deb11-linux', 'release-x86_64-linux-deb10-release+debug_info': 'x86_64-deb10-linux-dwarf', ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -200,7 +200,7 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): ubuntu2204 = mk(ubuntu("22_04")) ubuntu2404 = mk(ubuntu("24_04")) rocky8 = mk(rocky("8")) - fedora33 = mk(fedora(33)) + fedora42 = mk(fedora(42)) darwin_x86 = mk(darwin("x86_64")) darwin_arm64 = mk(darwin("aarch64")) windows = mk(windowsArtifact) @@ -239,11 +239,9 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): , "unknown_versioning": ubuntu2004 } , "Linux_CentOS" : { "( >= 8 && < 9 )" : rocky8 , "unknown_versioning" : rocky8 } - , "Linux_Fedora" : { ">= 33": fedora33 + , "Linux_Fedora" : { ">= 42": fedora42 , "unknown_versioning": rocky8 } - , "Linux_RedHat" : { "< 9": rocky8 - , ">= 9": fedora33 - , "unknown_versioning": fedora33 } + , "Linux_RedHat" : { "unknown_versioning": rocky8 } , "Linux_UnknownLinux" : { "unknown_versioning": rocky8 } , "Darwin" : { "unknown_versioning" : darwin_x86 } , "Windows" : { "unknown_versioning" : windows } ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -421,7 +421,7 @@ loadExternalPlugins ps = do loadExternalPluginLib :: FilePath -> IO () loadExternalPluginLib path = do -- load library - loadDLL path >>= \case + loadDLLs [path] >>= \case Left errmsg -> pprPanic "loadExternalPluginLib" (vcat [ text "Can't load plugin library" , text " Library path: " <> text path ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -58,6 +58,7 @@ module GHC.HsToCore.Monad ( import GHC.Prelude import GHC.Driver.Env +import GHC.Driver.Env.KnotVars import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic @@ -117,7 +118,7 @@ import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict import Data.IORef -import GHC.Driver.Env.KnotVars + import GHC.IO.Unsafe (unsafeInterleaveIO) {- ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} -- -- (c) The University of Glasgow 2002-2006 @@ -104,6 +105,7 @@ import Data.Array import Data.ByteString (ByteString) import qualified Data.Set as Set import Data.Char (isSpace) +import Data.Foldable (for_) import qualified Data.Foldable as Foldable import Data.IORef import Data.List (intercalate, isPrefixOf, nub, partition) @@ -535,7 +537,7 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do return pls DLL dll_unadorned -> do - maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) + maybe_errstr <- loadDLLs interp [platformSOName platform dll_unadorned] case maybe_errstr of Right _ -> maybePutStrLn logger "done" Left mm | platformOS platform /= OSDarwin -> @@ -545,14 +547,14 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do -- since (apparently) some things install that way - see -- ticket #8770. let libfile = ("lib" ++ dll_unadorned) <.> "so" - err2 <- loadDLL interp libfile + err2 <- loadDLLs interp [libfile] case err2 of Right _ -> maybePutStrLn logger "done" Left _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do - do maybe_errstr <- loadDLL interp dll_path + do maybe_errstr <- loadDLLs interp [dll_path] case maybe_errstr of Right _ -> maybePutStrLn logger "done" Left mm -> preloadFailed mm lib_paths lib_spec @@ -892,7 +894,7 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] - m <- loadDLL interp soFile + m <- loadDLLs interp [soFile] case m of Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } Left err -> linkFail msg (text err) @@ -1129,51 +1131,91 @@ loadPackages interp hsc_env new_pkgs = do loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' - } + (reverse -> pkgs_info_list, pkgs_almost_loaded) <- + downsweep + ([], pkgs_loaded pls) + new_pks + loaded_pkgs_info_list <- loadPackage interp hsc_env pkgs_info_list + evaluate $ + pls + { pkgs_loaded = + foldl' + ( \pkgs (new_pkg_info, (hs_cls, extra_cls, loaded_dlls)) -> + adjustUDFM + ( \old_pkg_info -> + old_pkg_info + { loaded_pkg_hs_objs = hs_cls, + loaded_pkg_non_hs_objs = extra_cls, + loaded_pkg_hs_dlls = loaded_dlls + } + ) + pkgs + (Packages.unitId new_pkg_info) + ) + pkgs_almost_loaded + (zip pkgs_info_list loaded_pkgs_info_list) + } where - link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded - link pkgs new_pkgs = - foldM link_one pkgs new_pkgs - - link_one pkgs new_pkg - | new_pkg `elemUDFM` pkgs -- Already linked - = return pkgs - - | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg - = do { let deps = unitDepends pkg_cfg - -- Link dependents first - ; pkgs' <- link pkgs deps - -- Now link the package itself - ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg - ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg - | dep_pkg <- deps - , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) - ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } - - | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) - - -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) -loadPackage interp hsc_env pkg + -- The downsweep process takes an initial 'PkgsLoaded' and uses it + -- to memoize new packages to load when recursively downsweeping + -- the dependencies. The returned 'PkgsLoaded' is popularized with + -- placeholder 'LoadedPkgInfo' for new packages yet to be loaded, + -- which need to be modified later to fill in the missing fields. + -- + -- The [UnitInfo] list is an accumulated *reverse* topologically + -- sorted list of new packages to load: 'downsweep_one' appends a + -- package to its head after that package's transitive + -- dependencies go into that list. There are no duplicate items in + -- this list due to memoization. + downsweep :: + ([UnitInfo], PkgsLoaded) -> [UnitId] -> IO ([UnitInfo], PkgsLoaded) + downsweep = foldlM downsweep_one + + downsweep_one :: + ([UnitInfo], PkgsLoaded) -> UnitId -> IO ([UnitInfo], PkgsLoaded) + downsweep_one (pkgs_info_list, pkgs) new_pkg + | new_pkg `elemUDFM` pkgs = pure (pkgs_info_list, pkgs) + | Just new_pkg_info <- lookupUnitId (hsc_units hsc_env) new_pkg = do + let new_pkg_deps = unitDepends new_pkg_info + (pkgs_info_list', pkgs') <- downsweep (pkgs_info_list, pkgs) new_pkg_deps + let new_pkg_trans_deps = + unionManyUniqDSets + [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg + | dep_pkg <- new_pkg_deps, + loaded_pkg_info <- maybeToList $ pkgs' `lookupUDFM` dep_pkg + ] + pure + ( new_pkg_info : pkgs_info_list', + addToUDFM pkgs' new_pkg $ + LoadedPkgInfo + { loaded_pkg_uid = new_pkg, + loaded_pkg_hs_objs = [], + loaded_pkg_non_hs_objs = [], + loaded_pkg_hs_dlls = [], + loaded_pkg_trans_deps = new_pkg_trans_deps + } + ) + | otherwise = + throwGhcExceptionIO + (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + +loadPackage :: Interp -> HscEnv -> [UnitInfo] -> IO [([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])] +loadPackage interp hsc_env pkgs = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env platform = targetPlatform dflags is_dyn = interpreterDynamic interp - dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg - | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg + dirs | is_dyn = [map ST.unpack $ Packages.unitLibraryDynDirs pkg | pkg <- pkgs] + | otherwise = [map ST.unpack $ Packages.unitLibraryDirs pkg | pkg <- pkgs] - let hs_libs = map ST.unpack $ Packages.unitLibraries pkg + let hs_libs = [map ST.unpack $ Packages.unitLibraries pkg | pkg <- pkgs] -- The FFI GHCi import lib isn't needed as -- GHC.Linker.Loader + rts/Linker.c link the -- interpreted references to FFI to the compiled FFI. -- We therefore filter it out so that we don't get -- duplicate symbol errors. - hs_libs' = filter ("HSffi" /=) hs_libs + hs_libs' = filter ("HSffi" /=) <$> hs_libs -- Because of slight differences between the GHC dynamic linker and -- the native system linker some packages have to link with a @@ -1182,51 +1224,60 @@ loadPackage interp hsc_env pkg -- libs do not exactly match the .so/.dll equivalents. So if the -- package file provides an "extra-ghci-libraries" field then we use -- that instead of the "extra-libraries" field. - extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg) + extdeplibs = [map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg) then Packages.unitExtDepLibsSys pkg - else Packages.unitExtDepLibsGhc pkg) - linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] - extra_libs = extdeplibs ++ linkerlibs + else Packages.unitExtDepLibsGhc pkg) | pkg <- pkgs] + linkerlibs = [[ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] | pkg <- pkgs] + extra_libs = zipWith (++) extdeplibs linkerlibs -- See Note [Fork/Exec Windows] gcc_paths <- getGCCPaths logger dflags (platformOS platform) - dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + dirs_env <- traverse (addEnvPaths "LIBRARY_PATH") dirs hs_classifieds - <- mapM (locateLib interp hsc_env True dirs_env gcc_paths) hs_libs' + <- sequenceA [mapM (locateLib interp hsc_env True dirs_env_ gcc_paths) hs_libs'_ | (dirs_env_, hs_libs'_) <- zip dirs_env hs_libs' ] extra_classifieds - <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs - let classifieds = hs_classifieds ++ extra_classifieds + <- sequenceA [mapM (locateLib interp hsc_env False dirs_env_ gcc_paths) extra_libs_ | (dirs_env_, extra_libs_) <- zip dirs_env extra_libs] + let classifieds = zipWith (++) hs_classifieds extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. - let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] - known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] - known_dlls = known_hs_dlls ++ known_extra_dlls + let known_hs_dlls = [[ dll | DLLPath dll <- hs_classifieds_ ] | hs_classifieds_ <- hs_classifieds] + known_extra_dlls = [ dll | extra_classifieds_ <- extra_classifieds, DLLPath dll <- extra_classifieds_ ] + known_dlls = concat known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL) - dlls = [ dll | DLL dll <- classifieds ] + dlls = [ dll | classifieds_ <- classifieds, DLL dll <- classifieds_ ] #endif - objs = [ obj | Objects objs <- classifieds - , obj <- objs ] - archs = [ arch | Archive arch <- classifieds ] + objs = [ obj | classifieds_ <- classifieds, Objects objs <- classifieds_ + , obj <- objs] + archs = [ arch | classifieds_ <- classifieds, Archive arch <- classifieds_ ] -- Add directories to library search paths let dll_paths = map takeDirectory known_dlls - all_paths = nub $ map normalise $ dll_paths ++ dirs + all_paths = nub $ map normalise $ dll_paths ++ concat dirs all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath interp) all_paths_env maybePutSDoc logger - (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") + (text "Loading units " <> vcat (map pprUnitInfoForUser pkgs) <> text " ... ") #if defined(CAN_LOAD_DLL) - loadFrameworks interp platform pkg + for_ pkgs $ loadFrameworks interp platform -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn interp hsc_env True) known_extra_dlls - loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls + _ <- load_dyn interp hsc_env True known_extra_dlls + + -- We pass [[FilePath]] of dlls to load and flattens the list + -- before doing a LoadDLLs. The returned list of RemotePtrs + -- would need to be regrouped to the same shape of the input + -- [[FilePath]], each group's [RemotePtr LoadedDLL] + -- corresponds to the DLL handles of a Haskell unit. + let regroup :: [[a]] -> [b] -> [[b]] + regroup [] _ = [] + regroup (l:ls) xs = xs0: regroup ls xs1 where (xs0, xs1) = splitAt (length l) xs + loaded_dlls <- regroup known_hs_dlls <$> load_dyn interp hsc_env True (concat known_hs_dlls) -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) - mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls + _ <- load_dyn interp hsc_env (not is_dyn) $ map (platformSOName platform) dlls #else let loaded_dlls = [] #endif @@ -1248,9 +1299,9 @@ loadPackage interp hsc_env pkg if succeeded ok then do maybePutStrLn logger "done." - return (hs_classifieds, extra_classifieds, loaded_dlls) - else let errmsg = text "unable to load unit `" - <> pprUnitInfoForUser pkg <> text "'" + pure $ zip3 hs_classifieds extra_classifieds loaded_dlls + else let errmsg = text "unable to load units `" + <> vcat (map pprUnitInfoForUser pkgs) <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) {- @@ -1300,12 +1351,12 @@ restriction very easily. -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, --- loadDLL is going to search the system paths to find the library. -load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) -load_dyn interp hsc_env crash_early dll = do - r <- loadDLL interp dll +-- loadDLLs is going to search the system paths to find the library. +load_dyn :: Interp -> HscEnv -> Bool -> [FilePath] -> IO [RemotePtr LoadedDLL] +load_dyn interp hsc_env crash_early dlls = do + r <- loadDLLs interp dlls case r of - Right loaded_dll -> pure (Just loaded_dll) + Right loaded_dlls -> pure loaded_dlls Left err -> if crash_early then cmdLineErrorIO err @@ -1314,7 +1365,7 @@ load_dyn interp hsc_env crash_early dll = do $ reportDiagnostic logger neverQualify diag_opts noSrcSpan (WarningWithFlag Opt_WarnMissedExtraSharedLib) $ withPprStyle defaultUserStyle (note err) - pure Nothing + pure [] where diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env @@ -1370,7 +1421,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 -- then look in library-dirs and inplace GCC for a static library (libfoo.a) -- then try "gcc --print-file-name" to search gcc's search path -- for a dynamic library (#5289) - -- otherwise, assume loadDLL can find it + -- otherwise, assume loadDLLs can find it -- -- The logic is a bit complicated, but the rationale behind it is that -- loading a shared library for us is O(1) while loading an archive is ===================================== compiler/GHC/Linker/MacOS.hs ===================================== @@ -162,7 +162,7 @@ loadFramework interp extraPaths rootname -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] - -- Try to call loadDLL for each candidate path. + -- Try to call loadDLLs for each candidate path. -- -- See Note [macOS Big Sur dynamic libraries] findLoadDLL [] errs = @@ -170,7 +170,7 @@ loadFramework interp extraPaths rootname -- has no built-in paths for frameworks: give up return $ Just errs findLoadDLL (p:ps) errs = - do { dll <- loadDLL interp (p fwk_file) + do { dll <- loadDLLs interp [p fwk_file] ; case dll of Right _ -> return Nothing Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -494,7 +494,7 @@ data LibrarySpec | DLL String -- "Unadorned" name of a .DLL/.so -- e.g. On unix "qt" denotes "libqt.so" -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- loadDLLs is platform-specific and adds the lib/.so/.DLL -- suffixes platform-dependently | DLLPath FilePath -- Absolute or relative pathname to a dynamic library ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -38,7 +38,7 @@ module GHC.Runtime.Interpreter , lookupSymbol , lookupSymbolInDLL , lookupClosure - , loadDLL + , loadDLLs , loadArchive , loadObj , unloadObj @@ -559,13 +559,13 @@ withSymbolCache interp str determine_addr = do purgeLookupSymbolCache :: Interp -> IO () purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp) --- | loadDLL loads a dynamic library using the OS's native linker +-- | 'loadDLLs' loads dynamic libraries using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either --- an absolute pathname to the file, or a relative filename --- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL --- searches the standard locations for the appropriate library. -loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) -loadDLL interp str = interpCmd interp (LoadDLL str) +-- absolute pathnames to the files, or relative filenames +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, 'loadDLLs' +-- searches the standard locations for the appropriate libraries. +loadDLLs :: Interp -> [String] -> IO (Either String [RemotePtr LoadedDLL]) +loadDLLs interp strs = interpCmd interp (LoadDLLs strs) loadArchive :: Interp -> String -> IO () loadArchive interp path = do @@ -761,4 +761,3 @@ readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaks fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a - ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -26,6 +26,7 @@ module GHC.Tc.Module ( runTcInteractive, -- Used by GHC API clients (#8878) withTcPlugins, -- Used by GHC API clients (#20499) withHoleFitPlugins, -- Used by GHC API clients (#20499) + withDefaultingPlugins, tcRnLookupName, tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, @@ -53,7 +54,6 @@ import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic import GHC.IO.Unsafe ( unsafeInterleaveIO ) -import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Tc.Gen.HsType @@ -141,7 +141,6 @@ import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv -import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -212,10 +211,6 @@ tcRnModule hsc_env mod_sum save_rn_syntax (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ - withDefaultingPlugins hsc_env $ - withHoleFitPlugins hsc_env $ - tcRnModuleTcRnM hsc_env mod_sum parsedModule this_mod | otherwise @@ -3182,72 +3177,11 @@ hasTopUserName x {- ******************************************************************************** -Type Checker Plugins + Running plugins ******************************************************************************** -} -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of - [] -> m -- Common fast case - plugins -> do - (solvers, rewriters, stops) <- - unzip3 `fmap` mapM start_plugin plugins - let - rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] - !rewritersUniqFM = sequenceUFMList rewriters - -- The following ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ - updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers - , tcg_tc_plugin_rewriters = rewritersUniqFM }) m - mapM_ runTcPluginM stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (TcPlugin start solve rewrite stop) = - do s <- runTcPluginM start - return (solve s, rewrite s, stop s) - -withDefaultingPlugins :: HscEnv -> TcM a -> TcM a -withDefaultingPlugins hsc_env m = - do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins - -- This ensures that dePluginStop is called even if a type - -- error occurs during compilation - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m - mapM_ runTcPluginM stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (DefaultingPlugin start fill stop) = - do s <- runTcPluginM start - return (fill s, stop s) - -withHoleFitPlugins :: HscEnv -> TcM a -> TcM a -withHoleFitPlugins hsc_env m = - case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins - -- This ensures that hfPluginStop is called even if a type - -- error occurs during compilation. - eitherRes <- tryM $ - updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m - sequence_ stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (HoleFitPluginR init plugin stop) = - do ref <- init - return (plugin ref, stop ref) - - runRenamerPlugin :: TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -31,6 +31,9 @@ module GHC.Tc.Utils.Monad( updateEps, updateEps_, getHpt, getEpsAndHug, + -- * Initialising TcM plugins + withTcPlugins, withDefaultingPlugins, withHoleFitPlugins, + -- * Arrow scopes newArrowScope, escapeArrowScope, @@ -163,6 +166,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types( zonkAnyTyCon ) import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) import GHC.Tc.Types -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc @@ -183,13 +187,17 @@ import GHC.Unit.Module.Warnings import GHC.Unit.Home.PackageTable import GHC.Core.UsageEnv + +import GHC.Core.Coercion ( isReflCo ) import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Type( mkNumLitTy ) +import GHC.Core.TyCon ( TyCon ) import GHC.Driver.Env import GHC.Driver.Env.KnotVars +import GHC.Driver.Plugins ( Plugin(..), mapPlugins ) import GHC.Driver.Session import GHC.Driver.Config.Diagnostic @@ -226,7 +234,7 @@ import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr -import GHC.Types.Unique.FM ( emptyUFM ) +import GHC.Types.Unique.FM ( UniqFM, emptyUFM, sequenceUFMList ) import GHC.Types.Unique.DFM import GHC.Types.Unique.Supply import GHC.Types.Annotations @@ -240,8 +248,6 @@ import Data.IORef import Control.Monad import qualified Data.Map as Map -import GHC.Core.Coercion (isReflCo) - {- ************************************************************************ @@ -263,129 +269,139 @@ initTc :: HscEnv -- (error messages should have been printed already) initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - = do { keep_var <- newIORef emptyNameSet ; - used_gre_var <- newIORef [] ; - th_var <- newIORef False ; - infer_var <- newIORef True ; - infer_reasons_var <- newIORef emptyMessages ; - dfun_n_var <- newIORef emptyOccSet ; - zany_n_var <- newIORef 0 ; - let { type_env_var = hsc_type_env_vars hsc_env }; - - dependent_files_var <- newIORef [] ; - dependent_dirs_var <- newIORef [] ; - static_wc_var <- newIORef emptyWC ; - cc_st_var <- newIORef newCostCentreState ; - th_topdecls_var <- newIORef [] ; - th_foreign_files_var <- newIORef [] ; - th_topnames_var <- newIORef emptyNameSet ; - th_modfinalizers_var <- newIORef [] ; - th_coreplugins_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; - th_docs_var <- newIORef Map.empty ; - th_needed_deps_var <- newIORef ([], emptyUDFM) ; - next_wrapper_num <- newIORef emptyModuleEnv ; - let { - -- bangs to avoid leaking the env (#19356) - !dflags = hsc_dflags hsc_env ; - !mhome_unit = hsc_home_unit_maybe hsc_env; - !logger = hsc_logger hsc_env ; - - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val - - | gopt Opt_WriteHie dflags = Just empty_val - - -- We want to serialize the documentation in the .hi-files, - -- and need to extract it from the renamed syntax first. - -- See 'GHC.HsToCore.Docs.extractDocs'. - | gopt Opt_Haddock dflags = Just empty_val - - | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - - gbl_env = TcGblEnv { - tcg_th_topdecls = th_topdecls_var, - tcg_th_foreign_files = th_foreign_files_var, - tcg_th_topnames = th_topnames_var, - tcg_th_modfinalizers = th_modfinalizers_var, - tcg_th_coreplugins = th_coreplugins_var, - tcg_th_state = th_state_var, - tcg_th_remote_state = th_remote_state_var, - tcg_th_docs = th_docs_var, - - tcg_mod = mod, - tcg_semantic_mod = homeModuleInstantiation mhome_unit mod, - tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyNameEnv, - tcg_default = emptyDefaultEnv, - tcg_default_exports = emptyDefaultEnv, - tcg_type_env = emptyNameEnv, - tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_ann_env = emptyAnnEnv, - tcg_complete_match_env = [], - tcg_th_used = th_var, - tcg_th_needed_deps = th_needed_deps_var, - tcg_exports = [], - tcg_imports = emptyImportAvails, - tcg_import_decls = [], - tcg_used_gres = used_gre_var, - tcg_dus = emptyDUs, - - tcg_rn_imports = [], - tcg_rn_exports = - if hsc_src == HsigFile - -- Always retain renamed syntax, so that we can give - -- better errors. (TODO: how?) - then Just [] - else maybe_rn_syntax [], - tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_tr_module = Nothing, - tcg_binds = emptyLHsBinds, - tcg_imp_specs = [], - tcg_sigs = emptyNameSet, - tcg_ksigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = emptyWarn, - tcg_anns = [], - tcg_tcs = [], - tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_patsyns = [], - tcg_merged = [], - tcg_dfun_n = dfun_n_var, - tcg_zany_n = zany_n_var, - tcg_keep = keep_var, - tcg_hdr_info = (Nothing,Nothing), - tcg_main = Nothing, - tcg_self_boot = NoSelfBoot, - tcg_safe_infer = infer_var, - tcg_safe_infer_reasons = infer_reasons_var, - tcg_dependent_files = dependent_files_var, - tcg_dependent_dirs = dependent_dirs_var, - tcg_tc_plugin_solvers = [], - tcg_tc_plugin_rewriters = emptyUFM, - tcg_defaulting_plugins = [], - tcg_hf_plugins = [], - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [], - tcg_cc_st = cc_st_var, - tcg_next_wrapper_num = next_wrapper_num - } ; - } ; + = do { gbl_env <- initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc -- OK, here's the business end! - initTcWithGbl hsc_env gbl_env loc do_this + ; initTcWithGbl hsc_env gbl_env loc $ + + -- Make sure to initialise all TcM plugins from the ambient HscEnv. + -- + -- This ensures that all callers of 'initTc' enable plugins (#26395). + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ + + do_this } +-- | Create an empty 'TcGblEnv'. +initTcGblEnv :: HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> IO TcGblEnv +initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = + do { keep_var <- newIORef emptyNameSet + ; used_gre_var <- newIORef [] + ; th_var <- newIORef False + ; infer_var <- newIORef True + ; infer_reasons_var <- newIORef emptyMessages + ; dfun_n_var <- newIORef emptyOccSet + ; zany_n_var <- newIORef 0 + ; dependent_files_var <- newIORef [] + ; dependent_dirs_var <- newIORef [] + ; static_wc_var <- newIORef emptyWC + ; cc_st_var <- newIORef newCostCentreState + ; th_topdecls_var <- newIORef [] + ; th_foreign_files_var <- newIORef [] + ; th_topnames_var <- newIORef emptyNameSet + ; th_modfinalizers_var <- newIORef [] + ; th_coreplugins_var <- newIORef [] + ; th_state_var <- newIORef Map.empty + ; th_remote_state_var <- newIORef Nothing + ; th_docs_var <- newIORef Map.empty + ; th_needed_deps_var <- newIORef ([], emptyUDFM) + ; next_wrapper_num <- newIORef emptyModuleEnv + ; let + -- bangs to avoid leaking the env (#19356) + !dflags = hsc_dflags hsc_env + !mhome_unit = hsc_home_unit_maybe hsc_env + !logger = hsc_logger hsc_env + + maybe_rn_syntax :: forall a. a -> Maybe a ; + maybe_rn_syntax empty_val + | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val + + | gopt Opt_WriteHie dflags = Just empty_val + + -- We want to serialize the documentation in the .hi-files, + -- and need to extract it from the renamed syntax first. + -- See 'GHC.HsToCore.Docs.extractDocs'. + | gopt Opt_Haddock dflags = Just empty_val + + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + + ; return $ TcGblEnv + { tcg_th_topdecls = th_topdecls_var + , tcg_th_foreign_files = th_foreign_files_var + , tcg_th_topnames = th_topnames_var + , tcg_th_modfinalizers = th_modfinalizers_var + , tcg_th_coreplugins = th_coreplugins_var + , tcg_th_state = th_state_var + , tcg_th_remote_state = th_remote_state_var + , tcg_th_docs = th_docs_var + + , tcg_mod = mod + , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + , tcg_src = hsc_src + , tcg_rdr_env = emptyGlobalRdrEnv + , tcg_fix_env = emptyNameEnv + , tcg_default = emptyDefaultEnv + , tcg_default_exports = emptyDefaultEnv + , tcg_type_env = emptyNameEnv + , tcg_type_env_var = hsc_type_env_vars hsc_env + , tcg_inst_env = emptyInstEnv + , tcg_fam_inst_env = emptyFamInstEnv + , tcg_ann_env = emptyAnnEnv + , tcg_complete_match_env = [] + , tcg_th_used = th_var + , tcg_th_needed_deps = th_needed_deps_var + , tcg_exports = [] + , tcg_imports = emptyImportAvails + , tcg_import_decls = [] + , tcg_used_gres = used_gre_var + , tcg_dus = emptyDUs + + , tcg_rn_imports = [] + , tcg_rn_exports = if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [] + , tcg_rn_decls = maybe_rn_syntax emptyRnGroup + , tcg_tr_module = Nothing + , tcg_binds = emptyLHsBinds + , tcg_imp_specs = [] + , tcg_sigs = emptyNameSet + , tcg_ksigs = emptyNameSet + , tcg_ev_binds = emptyBag + , tcg_warns = emptyWarn + , tcg_anns = [] + , tcg_tcs = [] + , tcg_insts = [] + , tcg_fam_insts = [] + , tcg_rules = [] + , tcg_fords = [] + , tcg_patsyns = [] + , tcg_merged = [] + , tcg_dfun_n = dfun_n_var + , tcg_zany_n = zany_n_var + , tcg_keep = keep_var + , tcg_hdr_info = (Nothing,Nothing) + , tcg_main = Nothing + , tcg_self_boot = NoSelfBoot + , tcg_safe_infer = infer_var + , tcg_safe_infer_reasons = infer_reasons_var + , tcg_dependent_files = dependent_files_var + , tcg_dependent_dirs = dependent_dirs_var + , tcg_tc_plugin_solvers = [] + , tcg_tc_plugin_rewriters = emptyUFM + , tcg_defaulting_plugins = [] + , tcg_hf_plugins = [] + , tcg_top_loc = loc + , tcg_static_wc = static_wc_var + , tcg_complete_matches = [] + , tcg_cc_st = cc_st_var + , tcg_next_wrapper_num = next_wrapper_num + } } + -- | Run a 'TcM' action in the context of an existing 'GblEnv'. initTcWithGbl :: HscEnv -> TcGblEnv @@ -686,6 +702,83 @@ withIfaceErr ctx do_this = do liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg)) Succeeded result -> return result +{- +************************************************************************ +* * + Initialising plugins for TcM +* * +************************************************************************ +-} + +-- | Initialise typechecker plugins, run the inner action, then stop +-- the typechecker plugins. +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of + [] -> m -- Common fast case + plugins -> do + (solvers, rewriters, stops) <- + unzip3 `fmap` mapM start_plugin plugins + let + rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] + !rewritersUniqFM = sequenceUFMList rewriters + -- The following ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers + , tcg_tc_plugin_rewriters = rewritersUniqFM }) + m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (TcPlugin start solve rewrite stop) = + do s <- runTcPluginM start + return (solve s, rewrite s, stop s) + +-- | Initialise defaulting plugins, run the inner action, then stop +-- the defaulting plugins. +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a +withDefaultingPlugins hsc_env m = + do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that dePluginStop is called even if a type + -- error occurs during compilation + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) + m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (DefaultingPlugin start fill stop) = + do s <- runTcPluginM start + return (fill s, stop s) + +-- | Initialise hole fit plugins, run the inner action, then stop +-- the hole fit plugins. +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) + m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + {- ************************************************************************ * * ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -89,7 +89,7 @@ data Message a where LookupSymbol :: String -> Message (Maybe (RemotePtr ())) LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) LookupClosure :: String -> Message (Maybe HValueRef) - LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL)) + LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL]) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? UnloadObj :: String -> Message () -- error? @@ -448,7 +448,7 @@ data BreakModule -- that type isn't available here. data BreakUnitId --- | A dummy type that tags pointers returned by 'LoadDLL'. +-- | A dummy type that tags pointers returned by 'LoadDLLs'. data LoadedDLL -- SomeException can't be serialized because it contains dynamic @@ -564,7 +564,7 @@ getMessage = do 1 -> Msg <$> return InitLinker 2 -> Msg <$> LookupSymbol <$> get 3 -> Msg <$> LookupClosure <$> get - 4 -> Msg <$> LoadDLL <$> get + 4 -> Msg <$> LoadDLLs <$> get 5 -> Msg <$> LoadArchive <$> get 6 -> Msg <$> LoadObj <$> get 7 -> Msg <$> UnloadObj <$> get @@ -610,7 +610,7 @@ putMessage m = case m of InitLinker -> putWord8 1 LookupSymbol str -> putWord8 2 >> put str LookupClosure str -> putWord8 3 >> put str - LoadDLL str -> putWord8 4 >> put str + LoadDLLs strs -> putWord8 4 >> put strs LoadArchive str -> putWord8 5 >> put str LoadObj str -> putWord8 6 >> put str UnloadObj str -> putWord8 7 >> put str ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -12,7 +12,7 @@ -- dynamic linker. module GHCi.ObjLink ( initObjLinker, ShouldRetainCAFs(..) - , loadDLL + , loadDLLs , loadArchive , loadObj , unloadObj @@ -31,6 +31,7 @@ import GHCi.RemoteTypes import GHCi.Message (LoadedDLL) import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) +import Data.Foldable import Foreign.C import Foreign.Marshal.Alloc ( alloca, free ) import Foreign ( nullPtr, peek ) @@ -43,6 +44,10 @@ import Control.Exception (catch, evaluate) import GHC.Wasm.Prim #endif +#if defined(wasm32_HOST_ARCH) +import Data.List (intercalate) +#endif + -- --------------------------------------------------------------------------- -- RTS Linker Interface -- --------------------------------------------------------------------------- @@ -67,20 +72,25 @@ data ShouldRetainCAFs initObjLinker :: ShouldRetainCAFs -> IO () initObjLinker _ = pure () -loadDLL :: String -> IO (Either String (Ptr LoadedDLL)) -loadDLL f = +-- Batch load multiple DLLs at once via dyld to enable a single +-- dependency resolution and more parallel compilation. We pass a +-- NUL-delimited JSString to avoid array marshalling on wasm. +loadDLLs :: [String] -> IO (Either String [Ptr LoadedDLL]) +loadDLLs fs = m `catch` \(err :: JSException) -> - pure $ Left $ "loadDLL failed for " <> f <> ": " <> show err + pure $ Left $ "loadDLLs failed: " <> show err where + packed :: JSString + packed = toJSString (intercalate ['\0'] fs) m = do - evaluate =<< js_loadDLL (toJSString f) - pure $ Right nullPtr + evaluate =<< js_loadDLLs packed + pure $ Right (replicate (length fs) nullPtr) -- See Note [Variable passing in JSFFI] for where -- __ghc_wasm_jsffi_dyld comes from -foreign import javascript safe "__ghc_wasm_jsffi_dyld.loadDLL($1)" - js_loadDLL :: JSString -> IO () +foreign import javascript safe "__ghc_wasm_jsffi_dyld.loadDLLs($1)" + js_loadDLLs :: JSString -> IO () loadArchive :: String -> IO () loadArchive f = throwIO $ ErrorCall $ "loadArchive: unsupported on wasm for " <> f @@ -241,6 +251,16 @@ resolveObjs = do r <- c_resolveObjs return (r /= 0) +loadDLLs :: [String] -> IO (Either String [Ptr LoadedDLL]) +loadDLLs = foldrM load_one $ Right [] + where + load_one _ err@(Left _) = pure err + load_one p (Right dlls) = do + r <- loadDLL p + pure $ case r of + Left err -> Left err + Right dll -> Right $ dll : dlls + -- --------------------------------------------------------------------------- -- Foreign declarations to RTS entry points which does the real work; -- --------------------------------------------------------------------------- ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -57,7 +57,7 @@ run m = case m of #if defined(javascript_HOST_ARCH) LoadObj p -> withCString p loadJS InitLinker -> notSupportedJS m - LoadDLL {} -> notSupportedJS m + LoadDLLs {} -> notSupportedJS m LoadArchive {} -> notSupportedJS m UnloadObj {} -> notSupportedJS m AddLibrarySearchPath {} -> notSupportedJS m @@ -69,7 +69,7 @@ run m = case m of LookupClosure str -> lookupJSClosure str #else InitLinker -> initObjLinker RetainCAFs - LoadDLL str -> fmap toRemotePtr <$> loadDLL str + LoadDLLs strs -> fmap (map toRemotePtr) <$> loadDLLs strs LoadArchive str -> loadArchive str LoadObj str -> loadObj str UnloadObj str -> unloadObj str ===================================== testsuite/tests/rts/linker/T2615.hs ===================================== @@ -4,7 +4,7 @@ library_name = "libfoo_script_T2615.so" -- this is really a linker script main = do initObjLinker RetainCAFs - result <- loadDLL library_name + result <- loadDLLs [library_name] case result of Right _ -> putStrLn (library_name ++ " loaded successfully") Left x -> putStrLn ("error: " ++ x) ===================================== testsuite/tests/tcplugins/T26395.hs ===================================== @@ -0,0 +1,51 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnliftedDatatypes #-} + +{-# OPTIONS_GHC -fplugin=T26395_Plugin #-} + +{-# OPTIONS_GHC -Wincomplete-patterns #-} +{-# OPTIONS_GHC -Winaccessible-code #-} +{-# OPTIONS_GHC -Woverlapping-patterns #-} + +module T26395 where + +import Data.Kind +import GHC.TypeNats +import GHC.Exts ( UnliftedType ) + +-- This test verifies that typechecker plugins are enabled +-- when we run the solver for pattern-match checking. + +type Peano :: Nat -> UnliftedType +data Peano n where + Z :: Peano 0 + S :: Peano n -> Peano (1 + n) + +test1 :: Peano n -> Peano n -> Int +test1 Z Z = 0 +test1 (S n) (S m) = 1 + test1 n m + +{- +The following test doesn't work properly due to #26401: +the pattern-match checker reports a missing equation + + Z (S _) _ + +but there is no invocation of the solver of the form + + [G] n ~ 0 + [G] m ~ 1 + m1 + [G] (n-m) ~ m2 + +for which we could report the Givens as contradictory. + +test2 :: Peano n -> Peano m -> Peano (n - m) -> Int +test2 Z Z Z = 0 +test2 (S _) (S _) _ = 1 +test2 (S _) Z (S _) = 2 +-} ===================================== testsuite/tests/tcplugins/T26395.stderr ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling T26395_Plugin ( T26395_Plugin.hs, T26395_Plugin.o ) +[2 of 2] Compiling T26395 ( T26395.hs, T26395.o ) ===================================== testsuite/tests/tcplugins/T26395_Plugin.hs ===================================== @@ -0,0 +1,208 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall -Wno-orphans #-} + +module T26395_Plugin where + +-- base +import Prelude hiding ( (<>) ) +import qualified Data.Semigroup as S +import Data.List ( partition ) +import Data.Maybe +import GHC.TypeNats + +-- ghc +import GHC.Builtin.Types.Literals +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep +import GHC.Plugins +import GHC.Tc.Plugin +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.TcType +import GHC.Types.Unique.Map + +-------------------------------------------------------------------------------- + +plugin :: Plugin +plugin = + defaultPlugin + { pluginRecompile = purePlugin + , tcPlugin = \ _-> Just $ + TcPlugin + { tcPluginInit = pure () + , tcPluginSolve = \ _ -> solve + , tcPluginRewrite = \ _ -> emptyUFM + , tcPluginStop = \ _ -> pure () + } + } + +solve :: EvBindsVar -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult +solve _ givens wanteds + -- This plugin only reports inconsistencies among Given constraints. + | not $ null wanteds + = pure $ TcPluginOk [] [] + | otherwise + = do { let givenLinearExprs = mapMaybe linearExprCt_maybe givens + sols = solutions givenLinearExprs + + ; tcPluginTrace "solveLinearExprs" $ + vcat [ text "givens:" <+> ppr givens + , text "linExprs:" <+> ppr givenLinearExprs + , text "sols:" <+> ppr (take 1 sols) + ] + ; return $ + if null sols + then TcPluginContradiction givens + else TcPluginOk [] [] + } + +data LinearExpr = + LinearExpr + { constant :: Integer + , coeffs :: UniqMap TyVar Integer + } +instance Semigroup LinearExpr where + LinearExpr c xs <> LinearExpr d ys = + LinearExpr ( c + d ) ( plusMaybeUniqMap_C comb xs ys ) + where + comb a1 a2 = + let a = a1 + a2 + in if a == 0 + then Nothing + else Just a + +instance Monoid LinearExpr where + mempty = LinearExpr 0 emptyUniqMap + +mapLinearExpr :: (Integer -> Integer) -> LinearExpr -> LinearExpr +mapLinearExpr f (LinearExpr c xs) = LinearExpr (f c) (mapUniqMap f xs) + +minusLinearExpr :: LinearExpr -> LinearExpr -> LinearExpr +minusLinearExpr a b = a S.<> mapLinearExpr negate b + +instance Outputable LinearExpr where + ppr ( LinearExpr c xs ) = + hcat $ punctuate ( text " + " ) $ + ( ppr c : map ppr_var ( nonDetUniqMapToList xs ) ) + where + ppr_var ( tv, i ) + | i == 1 + = ppr tv + | i < 0 + = parens ( text "-" <> ppr (abs i) ) <> text "*" <> ppr tv + | otherwise + = ppr i <> text "*" <> ppr tv + +maxCoeff :: LinearExpr -> Double +maxCoeff ( LinearExpr c xs ) = + maximum ( map fromInteger ( c : nonDetEltsUniqMap xs ) ) + + +linearExprCt_maybe :: Ct -> Maybe LinearExpr +linearExprCt_maybe ct = + case classifyPredType (ctPred ct) of + EqPred NomEq lhs rhs + | all isNaturalTy [ typeKind lhs, typeKind rhs ] + , Just e1 <- linearExprTy_maybe lhs + , Just e2 <- linearExprTy_maybe rhs + -> Just $ e1 `minusLinearExpr` e2 + _ -> Nothing + +isNat :: Type -> Maybe Integer +isNat ty + | Just (NumTyLit n) <- isLitTy ty + = Just n + | otherwise + = Nothing + +linearExprTy_maybe :: Type -> Maybe LinearExpr +linearExprTy_maybe ty + | Just n <- isNat ty + = Just $ LinearExpr n emptyUniqMap + | Just (tc, args) <- splitTyConApp_maybe ty + = if | tc == typeNatAddTyCon + , [x, y] <- args + , Just e1 <- linearExprTy_maybe x + , Just e2 <- linearExprTy_maybe y + -> Just $ e1 S.<> e2 + | tc == typeNatSubTyCon + , [x,y] <- args + , Just e1 <- linearExprTy_maybe x + , Just e2 <- linearExprTy_maybe y + -> Just $ e1 `minusLinearExpr` e2 + | tc == typeNatMulTyCon + , [x, y] <- args + -> + if | Just ( LinearExpr n xs ) <- linearExprTy_maybe x + , isNullUniqMap xs + , Just e <- linearExprTy_maybe y + -> Just $ + if n == 0 + then mempty + else mapLinearExpr (n *) e + | Just ( LinearExpr n ys ) <- linearExprTy_maybe y + , isNullUniqMap ys + , Just e <- linearExprTy_maybe x + -> Just $ + if n == 0 + then mempty + else mapLinearExpr (fromIntegral n *) e + | otherwise + -> Nothing + | otherwise + -> Nothing + | Just tv <- getTyVar_maybe ty + = Just $ LinearExpr 0 ( unitUniqMap tv 1 ) + | otherwise + = Nothing + +-- Brute force algorithm to check whether a system of Diophantine +-- linear equations is solvable in natural numbers. +solutions :: [ LinearExpr ] -> [ UniqMap TyVar Natural ] +solutions eqs = + let + (constEqs, realEqs) = partition (isNullUniqMap . coeffs) eqs + d = length realEqs + fvs = nonDetKeysUniqMap $ plusUniqMapList ( map coeffs realEqs ) + in + if | any ( ( /= 0 ) . evalLinearExpr emptyUniqMap ) constEqs + -> [] + | d == 0 + -> [ emptyUniqMap ] + | otherwise + -> + let + m = maximum $ map maxCoeff realEqs + hadamardBound = sqrt ( fromIntegral $ d ^ d ) * m ^ d + tests = mkAssignments ( floor hadamardBound ) fvs + in + filter ( \ test -> isSolution test realEqs ) tests + + +mkAssignments :: Natural -> [ TyVar ] -> [ UniqMap TyVar Natural ] +mkAssignments _ [] = [ emptyUniqMap ] +mkAssignments b (v : vs) = + [ addToUniqMap rest v n + | n <- [ 0 .. b ] + , rest <- mkAssignments b vs + ] + +isSolution :: UniqMap TyVar Natural -> [ LinearExpr ] -> Bool +isSolution assig = + all ( \ expr -> evalLinearExpr assig expr == 0 ) + +evalLinearExpr :: UniqMap TyVar Natural -> LinearExpr -> Integer +evalLinearExpr vals ( LinearExpr c xs ) = nonDetFoldUniqMap aux c xs + where + aux ( tv, coeff ) !acc = acc + coeff * val + where + val :: Integer + val = case lookupUniqMap vals tv of + Nothing -> pprPanic "evalLinearExpr: missing tv" (ppr tv) + Just v -> fromIntegral v ===================================== testsuite/tests/tcplugins/all.T ===================================== @@ -110,6 +110,19 @@ test('TcPlugin_CtId' , '-dynamic -package ghc' if have_dynamic() else '-package ghc' ] ) +# Checks that we run type-checker plugins for pattern-match warnings. +test('T26395' + , [ extra_files( + [ 'T26395_Plugin.hs' + , 'T26395.hs' + ]) + , req_th + ] + , multimod_compile + , [ 'T26395.hs' + , '-dynamic -package ghc' if have_dynamic() else '-package ghc' ] + ) + test('T11462', [js_broken(22261), req_th, req_plugins], multi_compile, [None, [('T11462_Plugin.hs', '-package ghc'), ('T11462.hs', '')], '-dynamic' if have_dynamic() else '']) ===================================== utils/jsffi/dyld.mjs ===================================== @@ -9,7 +9,7 @@ // iserv (GHCi.Server.defaultServer). This part only runs in // nodejs. // 2. Dynamic linker: provide RTS linker interfaces like -// loadDLL/lookupSymbol etc which are imported by wasm iserv. This +// loadDLLs/lookupSymbol etc which are imported by wasm iserv. This // part can run in browsers as well. // // When GHC starts external interpreter for the wasm target, it starts @@ -50,7 +50,7 @@ // // *** What works right now and what doesn't work yet? // -// loadDLL & bytecode interpreter work. Template Haskell & ghci work. +// loadDLLs & bytecode interpreter work. Template Haskell & ghci work. // Profiled dynamic code works. Compiled code and bytecode can all be // loaded, though the side effects are constrained to what's supported // by wasi preview1: we map the full host filesystem into wasm cause @@ -777,17 +777,17 @@ class DyLD { return this.#rpc.findSystemLibrary(f); } - // When we do loadDLL, we first perform "downsweep" which return a + // When we do loadDLLs, we first perform "downsweep" which return a // toposorted array of dependencies up to itself, then sequentially // load the downsweep result. // // The rationale of a separate downsweep phase, instead of a simple - // recursive loadDLL function is: V8 delegates async + // recursive loadDLLs function is: V8 delegates async // WebAssembly.compile to a background worker thread pool. To // maintain consistent internal linker state, we *must* load each so // file sequentially, but it's okay to kick off compilation asap, // store the Promise in downsweep result and await for the actual - // WebAssembly.Module in loadDLL logic. This way we can harness some + // WebAssembly.Module in loadDLLs logic. This way we can harness some // background parallelism. async #downsweep(p) { const toks = p.split("/"); @@ -828,8 +828,26 @@ class DyLD { return acc; } - // The real stuff - async loadDLL(p) { + // Batch load multiple DLLs in one go. + // Accepts a NUL-delimited string of paths to avoid array marshalling. + // Each path can be absolute or a soname; dependency resolution is + // performed across the full set to enable maximal parallel compile + // while maintaining sequential instantiation order. + async loadDLLs(packed) { + // Normalize input to an array of strings. When called from Haskell + // we pass a single JSString containing NUL-separated paths. + const paths = (typeof packed === "string" + ? (packed.length === 0 ? [] : packed.split("\0")) + : [packed] // tolerate an accidental single path object + ).filter((s) => s.length > 0).reverse(); + + // Compute a single downsweep plan for the whole batch. + // Note: #downsweep mutates #loadedSos to break cycles and dedup. + const plan = []; + for (const p of paths) { + plan.push(...(await this.#downsweep(p))); + } + for (const { memSize, memP2Align, @@ -837,7 +855,7 @@ class DyLD { tableP2Align, modp, soname, - } of await this.#downsweep(p)) { + } of plan) { const import_obj = { wasi_snapshot_preview1: this.#wasi.wasiImport, env: { @@ -1128,7 +1146,7 @@ export async function main({ rpc, libdir, ghciSoPath, args }) { rpc, }); await dyld.addLibrarySearchPath(libdir); - await dyld.loadDLL(ghciSoPath); + await dyld.loadDLLs(ghciSoPath); const reader = rpc.readStream.getReader(); const writer = rpc.writeStream.getWriter(); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be9f9fb259cbfc8f6e7db3c909f51b3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be9f9fb259cbfc8f6e7db3c909f51b3... You're receiving this email because of your account on gitlab.haskell.org.