Cheng Shao pushed to branch wip/validate-fix-werror at Glasgow Haskell Compiler / GHC Commits: 18513365 by Matthew Pickering at 2026-03-21T04:43:26-04:00 Add support for custom external interpreter commands It can be useful for GHC API clients to implement their own external interpreter commands. For example, the debugger may want an efficient way to inspect the stacks of the running threads in the external interpreter. - - - - - 4636d906 by mangoiv at 2026-03-21T04:44:10-04:00 ci: remove obsolete fallback for old debian and ubuntu versions - - - - - 2e3a2805 by mangoiv at 2026-03-21T04:44:10-04:00 ci: drop ubuntu 18 and 20 Ubuntu 18 EOL: May 2023 Ubuntu 20 EOL: May 2025 We should probably not make another major release supporting these platforms. Also updates the generator script. Resolves #25876 - - - - - de54e264 by Cheng Shao at 2026-03-21T17:52:08+01:00 rts: fix -Wcompare-distinct-pointer-types errors This commit fixes `-Wcompare-distinct-pointer-types` errors in the RTS which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. - - - - - b9bd73de by Cheng Shao at 2026-03-21T17:52:08+01:00 ghc-internal: fix unused imports This commit fixes unused imports in `ghc-internal` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - da946a16 by Cheng Shao at 2026-03-21T17:03:51+00:00 ghci: fix unused imports This commit fixes unused imports in `ghci` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #26987 #27059. - - - - - 955b1cf8 by Cheng Shao at 2026-03-21T17:03:51+00:00 compiler: fix unused imports in GHC.Tc.Types.Origin This commit fixes unused imports in `GHC.Tc.Types.Origin` which should have been caught by the `validate` flavour but was warnings in CI due to the recent `+werror` regression. Fixes #27059. - - - - - 3b1aeb50 by Cheng Shao at 2026-03-21T17:03:51+00:00 hadrian: fix missing +werror in validate flavour This patch fixes missing `+werror` in validate flavour, which was an oversight in bb3a2ba1eefadf0b2ef4f39b31337a23eec67f29. Fixes #27066. - - - - - 30 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/flake.lock - .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/Tc/Types/Origin.hs - docs/users_guide/utils.py - hadrian/src/Settings/Flavours/Validate.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Server.hs - rts/Interpreter.c - + testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs - + testsuite/tests/ghci/custom-external-interpreter-commands/all.T - + testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1212,10 +1212,6 @@ ghcup-metadata-nightly: artifacts: false - job: nightly-x86_64-linux-ubuntu22_04-validate artifacts: false - - job: nightly-x86_64-linux-ubuntu20_04-validate - artifacts: false - - job: nightly-x86_64-linux-ubuntu18_04-validate - artifacts: false - job: nightly-x86_64-linux-rocky8-validate artifacts: false - job: nightly-x86_64-darwin-validate ===================================== .gitlab/generate-ci/flake.lock ===================================== @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1710146030, - "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -20,12 +20,10 @@ }, "nixpkgs": { "locked": { - "lastModified": 1724334015, - "narHash": "sha256-5sfvc0MswIRNdRWioUhG58rGKGn2o90Ck6l6ClpwQqA=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6d204f819efff3d552a88d0a44b5aaaee172b784", - "type": "github" + "lastModified": 0, + "narHash": "sha256-M0yS4AafhKxPPmOHGqIV0iKxgNO8bHDWdl1kOwGBwRY=", + "path": "/nix/store/nbylyyw8k98a0an6p6nz0hvk5psygwb8-source", + "type": "path" }, "original": { "id": "nixpkgs", ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -122,8 +122,6 @@ data LinuxDistro | Ubuntu2404LoongArch64 | Ubuntu2404 | Ubuntu2204 - | Ubuntu2004 - | Ubuntu1804 | Alpine312 | Alpine323 | AlpineWasm @@ -326,8 +324,6 @@ distroName Debian13Riscv = "deb13-riscv" distroName Debian12Wine = "deb12-wine" distroName Fedora43 = "fedora43" distroName Ubuntu2404LoongArch64 = "ubuntu24_04-loongarch" -distroName Ubuntu1804 = "ubuntu18_04" -distroName Ubuntu2004 = "ubuntu20_04" distroName Ubuntu2204 = "ubuntu22_04" distroName Ubuntu2404 = "ubuntu24_04" distroName Alpine312 = "alpine3_12" @@ -1193,9 +1189,7 @@ debian_i386 = ubuntu_x86 :: [JobGroup Job] ubuntu_x86 = - [ disableValidate (standardBuilds Amd64 (Linux Ubuntu1804)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2004)) - , disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) + [ disableValidate (standardBuilds Amd64 (Linux Ubuntu2204)) , disableValidate (standardBuilds Amd64 (Linux Ubuntu2404)) ] ===================================== .gitlab/jobs.yaml ===================================== @@ -3385,132 +3385,6 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-ubuntu18_04-validate": { - "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": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_REV", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "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-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate", - "XZ_OPT": "-9" - } - }, - "nightly-x86_64-linux-ubuntu20_04-validate": { - "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": "8 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_REV", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)", - "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-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate", - "XZ_OPT": "-9" - } - }, "nightly-x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -5192,134 +5066,6 @@ "XZ_OPT": "-9" } }, - "release-x86_64-linux-ubuntu18_04-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-ubuntu18_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$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-ubuntu18_04-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-ubuntu18_04-release", - "XZ_OPT": "-9" - } - }, - "release-x86_64-linux-ubuntu20_04-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-ubuntu20_04-release.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$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-ubuntu20_04-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-ubuntu20_04-release", - "XZ_OPT": "-9" - } - }, "release-x86_64-linux-ubuntu22_04-release": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -7472,130 +7218,6 @@ "TEST_ENV": "x86_64-linux-rocky8-validate" } }, - "x86_64-linux-ubuntu18_04-validate": { - "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": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu18_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu18_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu18_04:$DOCKER_REV", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu18_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($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-ubuntu18_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu18_04-validate" - } - }, - "x86_64-linux-ubuntu20_04-validate": { - "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": "2 weeks", - "paths": [ - "ghc-x86_64-linux-ubuntu20_04-validate.tar.xz", - "junit.xml", - "unexpected-test-output.tar.gz" - ], - "reports": { - "junit": "junit.xml" - }, - "when": "always" - }, - "cache": { - "key": "x86_64-linux-ubuntu20_04-$CACHE_REV", - "paths": [ - "cabal-cache", - "toolchain" - ] - }, - "dependencies": [], - "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_REV", - "needs": [ - { - "artifacts": false, - "job": "hadrian-ghc-in-ghci" - } - ], - "rules": [ - { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-ubuntu20_04-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && (\"disabled\" != \"disabled\"))) && ($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-ubuntu20_04-validate", - "BUILD_FLAVOUR": "validate", - "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", - "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-linux-ubuntu20_04-validate" - } - }, "x86_64-linux-ubuntu22_04-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -21,8 +21,6 @@ def job_triple(job_name): 'release-x86_64-linux-rocky8-release': 'x86_64-rocky8-linux', 'release-x86_64-linux-ubuntu24_04-release': 'x86_64-ubuntu24_04-linux', '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-fedora43-release': 'x86_64-fedora43-linux', 'release-x86_64-linux-fedora43-release+debug_info': 'x86_64-fedora43-linux-dwarf', 'release-x86_64-linux-deb13-release': 'x86_64-deb13-linux', ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -195,8 +195,6 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform)) # Here are all the bindists we can distribute - ubuntu1804 = mk(ubuntu("18_04")) - ubuntu2004 = mk(ubuntu("20_04")) ubuntu2204 = mk(ubuntu("22_04")) ubuntu2404 = mk(ubuntu("24_04")) rocky8 = mk(rocky("8")) @@ -227,15 +225,13 @@ def mk_new_yaml(release_mode, version, date, pipeline_type, job_map): , "( >= 12 && < 13 )": deb12 , ">= 13": deb13 , "unknown_versioning": deb11 } - , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2004 - , "( >= 18 && < 19 )": ubuntu1804 - , "( >= 19 && < 21 )": ubuntu2004 - , "( >= 21 && < 24 )": ubuntu2204 + , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2204 + , "( < 24 )": ubuntu2204 , "( >= 24 )": ubuntu2404 } - , "Linux_Mint" : { "< 20": ubuntu1804 - , ">= 20": ubuntu2004 - , "unknown_versioning": ubuntu2004 } + , "Linux_Mint" : { "< 24": ubuntu2204 + , ">= 24": ubuntu2404 + , "unknown_versioning": ubuntu2204 } , "Linux_CentOS" : { "( >= 8 && < 9 )" : rocky8 , "unknown_versioning" : rocky8 } , "Linux_Fedora" : { ">= 43": fedora43 ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -83,7 +83,6 @@ import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import qualified Data.Semigroup as Semi -import GHC.Generics {- ********************************************************************* * * ===================================== docs/users_guide/utils.py ===================================== @@ -1,11 +1,6 @@ from docutils import nodes -# N.B. `packaging` is not available in Ubuntu 18.04 or Debian 9 -# See #23818. -try: - from packaging.version import parse as parse_version -except ImportError as e: - from distutils.version import LooseVersion as parse_version +from packaging.version import parse as parse_version # Taken from Docutils source inside the ListTable class. We must bypass # using the class itself, but this function comes in handy. ===================================== hadrian/src/Settings/Flavours/Validate.hs ===================================== @@ -8,7 +8,7 @@ import {-# SOURCE #-} Settings.Default -- Please update doc/flavours.md when changing this file. validateFlavour :: Flavour -validateFlavour = enableLinting $ quickValidateFlavour +validateFlavour = enableLinting $ werror $ quickValidateFlavour { name = "validate" , extraArgs = validateArgs <> defaultHaddockExtraArgs , ghcDebugAssertions = (<= Stage1) ===================================== libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Internal.Conc.IO #endif ) where -import GHC.Internal.Base (otherwise, pure, return, ($)) +import GHC.Internal.Base (otherwise, return, ($)) import GHC.Internal.Conc.Sync as Sync import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.STM as STM @@ -82,6 +82,10 @@ import qualified GHC.Internal.Wasm.Prim.Conc as Wasm import qualified GHC.Internal.Wasm.Prim.Flag as Wasm #endif +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + ensureIOManagerIsRunning :: IO () #if defined(javascript_HOST_ARCH) ensureIOManagerIsRunning = pure () ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Control.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Internal.Event.Control #include <ghcplatform.h> #include "EventConfig.h" -import GHC.Internal.Base (fmap, otherwise, pure, return, when, ($), (.)) +import GHC.Internal.Base (fmap, otherwise, return, when, ($), (.)) import GHC.Internal.Classes (Eq(..), (&&)) import GHC.Internal.IORef import GHC.Internal.Conc.Signal (Signal) @@ -56,6 +56,10 @@ import GHC.Internal.Foreign.C.Types (CULLong(..)) import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF) #endif +#if defined(wasm32_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + data ControlMessage = CMsgWakeup | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc ===================================== @@ -33,7 +33,7 @@ import GHC.Internal.Data.Bits (Bits(..), FiniteBits(..)) import GHC.Internal.Err (errorWithoutStackTrace, undefined) import GHC.Internal.Int import GHC.Internal.Data.Maybe (Maybe(..), catMaybes) -import GHC.Internal.Types (Bool(..), Int, IO) +import GHC.Internal.Types (Bool(..), IO) import GHC.Internal.Word (Word16, Word32) import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, eNOTSUP, getErrno, throwErrno) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -185,12 +185,12 @@ import GHC.Internal.Prim ( decodeFloat_Int#, divideFloat#, double2Float#, eqWord#, expDouble#, expFloat#, expm1Double#, expm1Float#, fabsDouble#, fabsFloat#, float2Double#, geFloat#, gtFloat#, gtWord#, int2Float#, int2Double#, - int2Word#, int64ToInt#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, + int2Word#, leFloat#, log1pDouble#, log1pFloat#, logDouble#, logFloat#, ltFloat#, ltWord#, minusFloat#, minusWord#, negateDouble#, negateFloat#, negateInt#, plusFloat#, powerFloat#, sinDouble#, sinFloat#, sinhDouble#, sinhFloat#, sqrtDouble#, sqrtFloat#, tanDouble#, tanFloat#, tanhDouble#, tanhFloat#, timesFloat#, uncheckedIShiftRA#, uncheckedShiftL#, - word2Float#, word2Double#, word2Int#, word64ToWord#, + word2Float#, word2Double#, word2Int#, (+#), (+##), (-#), (-##), (*##), (**##), (/##), (<#), (<##), (<=#), (<=##), (>#), (>##), (>=#), (>=##), ) @@ -206,6 +206,13 @@ import GHC.Internal.Float.RealFracMethods import GHC.Internal.Float.ConversionUtils import GHC.Internal.Bignum.BigNat +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Prim ( + int64ToInt#, + word64ToWord#, + ) +#endif + infixr 8 ** -- $setup ===================================== libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Num () -- instance Num Integer -- (We could remove uses with a little effort) import GHC.Internal.Prim ( - Int#, eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, + eqFloat#, decodeFloat_Int#, double2Int#, float2Int#, int2Float#, int2Double#, int2Word#, ltFloat#, minusFloat#, negateFloat#, negateDouble#, negateInt#, uncheckedIShiftL#, uncheckedIShiftRA#, uncheckedIShiftRL#, (+#), (-#), (<#), (>#), (-##), (==##), (<##), @@ -86,6 +86,10 @@ import GHC.Internal.Prim ( #else +import GHC.Internal.Prim ( + Int#, + ) + #define TO64 integerToInt# #define FROM64 IS #define MINUS64 ( -# ) @@ -355,4 +359,3 @@ foreign import ccall unsafe "rintDouble" foreign import ccall unsafe "rintFloat" c_rintFloat :: Float -> Float - ===================================== libraries/ghc-internal/src/GHC/Internal/IO/FD.hs ===================================== @@ -30,7 +30,7 @@ module GHC.Internal.IO.FD ( ) where import GHC.Internal.Base ( - String, fmap, id, otherwise, pure, return, when, ($), (.), (++), (>>=), + String, fmap, otherwise, pure, return, when, ($), (.), (++), (>>=), ) import GHC.Internal.Bits import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) @@ -58,6 +58,10 @@ import GHC.Internal.Err (error) import GHC.Internal.Windows import GHC.Internal.IO.SubSystem ((<!>)) import GHC.Internal.Foreign.Storable +#else +import GHC.Internal.Base ( + id, + ) #endif import GHC.Internal.Foreign.C.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Int.hs ===================================== @@ -51,7 +51,7 @@ import GHC.Internal.Classes ( Eq(..), Ord(..), eqInt, neInt, gtInt, geInt, ltInt, leInt, divInt8#, divInt16#, divInt32#, - divModInt8#, divModInt16#, divModInt32#, divModInt#, + divModInt8#, divModInt16#, divModInt32#, modInt8#, modInt16#, modInt32#, (&&), (||), ) @@ -63,6 +63,12 @@ import GHC.Internal.Arr import GHC.Internal.Show import GHC.Internal.Types (Bool(..), Float, Double, Int(..), isTrue#) +#if WORD_SIZE_IN_BITS == 64 +import GHC.Internal.Classes ( + divModInt#, + ) +#endif + ------------------------------------------------------------------------ -- type Int8 ------------------------------------------------------------------------ ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc ===================================== @@ -66,7 +66,7 @@ import GHC.Internal.Ptr import GHC.Internal.Types (Bool(..), Double, Int) import GHC.Internal.Word import GHC.Internal.Base ( - String, otherwise, pure, return, (.), (++), (<*>), (=<<), + String, otherwise, return, (.), (++), (<*>), (=<<), ) import GHC.Internal.Enum import GHC.Internal.Generics (Generic) @@ -74,6 +74,10 @@ import GHC.Internal.IO import GHC.Internal.Real import GHC.Internal.Show +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#endif + -- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- -- @since base-4.8.2.0 ===================================== libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc ===================================== @@ -8,16 +8,20 @@ module GHC.Internal.RTS.Flags.Test ) where -import GHC.Internal.Base (pure) import GHC.Internal.Ptr -import GHC.Internal.Foreign.C.Types -import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import GHC.Internal.Data.Functor ((<$>)) import GHC.Internal.Types (Bool(..), Int, IO) import GHC.Internal.Word (Word32) import GHC.Internal.Real (fromIntegral) +#if defined(javascript_HOST_ARCH) +import GHC.Internal.Base (pure) +#else +import GHC.Internal.Foreign.C.Types +import GHC.Internal.Foreign.Marshal.Utils +#endif + #include "Rts.h" #include "rts/Flags.h" ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment.hs ===================================== @@ -49,9 +49,13 @@ import GHC.Internal.Base (fmap) import GHC.Internal.Classes (Ord(..)) import GHC.Internal.Control.Exception.Base (bracket) import GHC.Internal.Err (undefined) +#else +import GHC.Internal.Base ( + map, (++), + ) #endif import GHC.Internal.Base ( - String, liftM, map, mapM, otherwise, return, ($), (.), (++), (>>=), + String, liftM, mapM, otherwise, return, ($), (.), (>>=), ) import GHC.Internal.List (null, elem, takeWhile, break) import GHC.Internal.Maybe (Maybe(..)) ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc ===================================== @@ -43,7 +43,7 @@ import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Data.Functor import GHC.Internal.Data.List (elem, null, takeWhile) import GHC.Internal.Foreign.C.String -import GHC.Internal.Base (String, otherwise, return, ($)) +import GHC.Internal.Base (String, otherwise, ($)) #if defined(mingw32_HOST_OS) import GHC.Internal.Base ((.)) import GHC.Internal.Foreign.Ptr @@ -51,6 +51,7 @@ import GHC.Internal.Windows import GHC.Internal.Control.Monad import GHC.Internal.Data.List (lookup) #else +import GHC.Internal.Base (return) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Real (fromIntegral) ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -249,6 +249,7 @@ import GHC.Internal.Base (String, failIO, otherwise, return, ($), (.), (>>=)) import GHC.Internal.List #if !defined(mingw32_HOST_OS) import GHC.Internal.IORef +import GHC.Internal.Types (Int) #endif import GHC.Internal.Num import GHC.Internal.IO hiding ( bracket, onException ) @@ -262,7 +263,7 @@ import GHC.Internal.IO.Encoding import GHC.Internal.Text.Read import GHC.Internal.IO.StdHandles import GHC.Internal.Show -import GHC.Internal.Types (Bool(..), Char, Int) +import GHC.Internal.Types (Bool(..), Char) ----------------------------------------------------------------------------- -- Standard IO ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -46,19 +46,20 @@ import GHC.Internal.Data.Maybe #if !defined(HTYPE_TCFLAG_T) import GHC.Internal.System.IO.Error +#if !defined(mingw32_HOST_OS) +import GHC.Internal.Err (errorWithoutStackTrace) +#endif #endif import GHC.Internal.Base ( String, otherwise, pure, return, when, ($), (++), (>>=), ) import GHC.Internal.Bits -import GHC.Internal.Classes (Eq(..), Ord(..), not, (&&), (||)) -import GHC.Internal.CString (cstringLength#) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Classes (Eq(..), not, (&&), (||)) import GHC.Internal.Num import GHC.Internal.Prim (yield#) import GHC.Internal.Real -import GHC.Internal.Types (Bool(..), Int(..)) +import GHC.Internal.Types (Bool(..)) import GHC.Internal.Word import GHC.Internal.IO import GHC.Internal.IO.IOMode @@ -71,10 +72,13 @@ import GHC.Internal.Int (Int64) #endif #if !defined(mingw32_HOST_OS) +import GHC.Internal.CString (cstringLength#) +import GHC.Internal.Classes (Ord(..)) import {-# SOURCE #-} GHC.Internal.IO.Encoding (getFileSystemEncoding) import GHC.Internal.Foreign.Marshal.Utils import GHC.Internal.Foreign.Storable import qualified GHC.Internal.Foreign.C.String.Encoding as GHC +import GHC.Internal.Types (Int(..)) #else import GHC.Internal.Int import GHC.Internal.Data.OldList (elem) ===================================== libraries/ghc-internal/src/GHC/Internal/TopHandler.hs ===================================== @@ -39,12 +39,12 @@ module GHC.Internal.TopHandler ( import GHC.Internal.Control.Exception import GHC.Internal.Data.Maybe -import GHC.Internal.Classes (Eq(..), Ord(..), (&&)) +import GHC.Internal.Classes (Eq(..)) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String import GHC.Internal.Base ( - String, const, failIO, otherwise, pure, return, ($), (++), (>>), + String, failIO, return, ($), (++), (>>), ) import GHC.Internal.Conc.Sync hiding (throwTo) import GHC.Internal.Prim (Weak#, seq) @@ -67,6 +67,17 @@ import GHC.Internal.Conc.Signal import GHC.Internal.Data.Dynamic (toDyn) #endif +#if !defined(HAVE_SIGNAL_H) +import GHC.Internal.Base (pure) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH) +import GHC.Internal.Base ( + const, otherwise, + ) +import GHC.Internal.Classes (Ord(..), (&&)) +#endif + -- Note [rts_setMainThread must be called unsafely] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- rts_setMainThread must be called as unsafe, because it ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -246,6 +246,11 @@ data Message a where :: RemoteRef (ResumeContext ()) -> Message (EvalStatus ()) + -- | User-defined request encoded as a tag/payload pair. This is left + -- uninterpreted by GHC and is meant for GHC API applications to be able to supply + -- their own interpreter which understands additional commands. + CustomMessage :: Word8 -> ByteString -> Message ByteString + deriving instance Show (Message a) -- | Used to dynamically create a data constructor's info table at @@ -602,6 +607,7 @@ getMessage = do 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) 40 -> Msg <$> (WhereFrom <$> get) + 41 -> Msg <$> (CustomMessage <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -648,6 +654,7 @@ putMessage m = case m of ResumeSeq a -> putWord8 38 >> put a LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str WhereFrom a -> putWord8 40 >> put a + CustomMessage tag payload -> putWord8 41 >> put tag >> put payload {- Note [Parallelize CreateBCOs serialization] ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -125,6 +125,7 @@ run m = case m of Shutdown -> unexpectedMessage m RunTH {} -> unexpectedMessage m RunModFinalizers {} -> unexpectedMessage m + CustomMessage {} -> unexpectedMessage m unexpectedMessage :: Message a -> b unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m) ===================================== libraries/ghci/GHCi/Server.hs ===================================== @@ -1,7 +1,11 @@ {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-} module GHCi.Server - ( serv + ( MessageHook + , CustomMessageHandler + , serv + , servWithCustom , defaultServer + , defaultServerWithCustom ) where @@ -10,8 +14,8 @@ import GHCi.Run import GHCi.Signals import GHCi.TH import GHCi.Message -#if defined(wasm32_HOST_ARCH) import Data.ByteString (ByteString) +#if defined(wasm32_HOST_ARCH) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -36,11 +40,27 @@ import System.IO type MessageHook = Msg -> IO Msg +-- | How to interpret the 'CustomCommand'. +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString) + +noCustomHandler :: CustomMessageHandler +noCustomHandler _ _ = return Nothing + trace :: String -> IO () trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO () -serv verbose hook pipe restore = loop +serv verbose hook pipe restore = + servWithCustom verbose hook pipe restore noCustomHandler + +servWithCustom + :: Bool + -> MessageHook + -> Pipe + -> (forall a .IO a -> IO a) + -> CustomMessageHandler + -> IO () +servWithCustom verbose hook pipe restore customHandler = loop where loop = do when verbose $ trace "reading pipe..." @@ -50,6 +70,7 @@ serv verbose hook pipe restore = loop when verbose $ trace ("msg: " ++ (show msg)) case msg of + CustomMessage tag payload -> handleCustom tag payload Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs @@ -61,6 +82,13 @@ serv verbose hook pipe restore = loop writePipe pipe (put r) loop + handleCustom tag payload = do + mresp <- customHandler tag payload + case mresp of + Just resp -> reply resp + Nothing -> + error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag + -- Run some TH code, which may interact with GHC by sending -- THMessage requests, and then finally send RunTHDone followed by a -- QResult. For an overview of how TH works with Remote GHCi, see @@ -109,12 +137,24 @@ serv verbose hook pipe restore = loop -- | Default server #if defined(wasm32_HOST_ARCH) defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO () -defaultServer cb_sig cb_recv cb_send = do +defaultServer cb_sig cb_recv cb_send = + defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler + +defaultServerWithCustom + :: Callback (JSVal -> IO ()) + -> Callback (IO JSUint8Array) + -> Callback (JSUint8Array -> IO ()) + -> CustomMessageHandler + -> IO () +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do args <- getArgs let rest = args #else defaultServer :: IO () -defaultServer = do +defaultServer = defaultServerWithCustom noCustomHandler + +defaultServerWithCustom :: CustomMessageHandler -> IO () +defaultServerWithCustom customHandler = do args <- getArgs (outh, inh, rest) <- case args of @@ -152,7 +192,7 @@ defaultServer = do putStrLn "Waiting 3s" threadDelay 3000000 - uninterruptibleMask $ serv verbose hook pipe + uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because ===================================== rts/Interpreter.c ===================================== @@ -718,7 +718,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + else if(Sp_plusW(offset_words) < (void*)(cur_stack->stack + cur_stack->stack_size)) { // Still inside the stack chunk return Sp_plusW(offset_words); } else { @@ -2469,7 +2469,7 @@ run_BCO: threadStackUnderflow(cap, cap->r.rCurrentTSO); LOAD_STACK_POINTERS; by -= sp_to_uf; - } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + } else if (Sp_plusW(by) < (void*)(stk->stack + stk->stack_size)) { // we're within the first stack chunk, this chunk has // no underflow frame break; ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs ===================================== @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-} +module Main (main) where + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Word (Word8) +import GHCi.Message + ( Message(..) + , mkPipeFromHandles + , remoteCall + , Pipe + ) +import GHCi.Server + ( CustomMessageHandler + , defaultServerWithCustom + ) +import System.Environment + ( getArgs + , getExecutablePath + , getProgName + , withArgs + ) +import System.Exit (exitFailure) +import System.IO + ( Handle + , BufferMode(..) + , hSetBuffering + , hSetBinaryMode + , hClose + , hPutStrLn + , stderr + ) +import System.Posix.IO + ( createPipe + , fdToHandle + , setFdOption + , FdOption(CloseOnExec) + ) +import System.Process + ( createProcess + , proc + , std_in + , std_out + , std_err + , StdStream(Inherit) + , terminateProcess + , waitForProcess + , ProcessHandle + ) +import Text.Read (readMaybe) + +-------------------------------------------------------------------------------- +-- Shared request/response definitions and helpers + +data ClientCommand a where + SquareCommand :: Int -> ClientCommand Int + MulCommand :: Int -> Int -> ClientCommand Int + +deriving instance (Show (ClientCommand a)) + +data Some c f where + Some :: c a => f a -> Some c f + + +instance Bin.Binary (Some Bin.Binary ClientCommand) where + put (Some i) = + case i of + SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n + MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n + + get = do + (tag :: Word8) <- Bin.get + fmap Some $ case tag of + 0 -> SquareCommand <$> Bin.get + 1 -> MulCommand <$> Bin.get <*> Bin.get + + +customTag :: Word8 +customTag = 0x42 + +encodeLazy :: Bin.Binary a => a -> BS.ByteString +encodeLazy = BL.toStrict . Bin.encode + +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a +decodeLazy bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +-------------------------------------------------------------------------------- +-- Mode selection + +data Mode + = RunClient Int + | RunServer [String] -- forwarded to GHCi.Server + +defaultInput :: Int +defaultInput = 12 + +parseMode :: [String] -> Either String Mode +parseMode [] = Right (RunClient defaultInput) +parseMode ["client"] = Right (RunClient defaultInput) +parseMode ["client", nStr] = + case readMaybe nStr of + Just n -> Right (RunClient n) + Nothing -> Left $ "Unable to parse integer argument: " ++ nStr +parseMode ("client":_) = Left "Too many arguments for client mode." +parseMode ("server":rest) = Right (RunServer rest) +parseMode args = Left "Unknown mode, use client/server" + +usage :: IO () +usage = do + prog <- getProgName + putStrLn $ unlines + [ "Usage:" + , " " ++ prog ++ " [client [n]] Run the client and square n (default 12)." + , " " ++ prog ++ " server <write-fd> <read-fd> Run as an iserv process." + ] + +-------------------------------------------------------------------------------- +-- Client/server drivers + +main :: IO () +main = do + args <- getArgs + case parseMode args of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right (RunClient n) -> runClient n + Right (RunServer serverArgs) -> + withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand)) + +handleClientCommand :: ClientCommand a -> IO a +handleClientCommand (SquareCommand n) = pure $ n * n +handleClientCommand (MulCommand n m) = pure $ n * m + + +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a +customMessage pipe c = do + let payload = encodeLazy (Some @Bin.Binary c) + putStrLn $ "Sending: " ++ show c + respBytes <- remoteCall pipe (CustomMessage customTag payload) + case decodeLazy respBytes of + Left err -> error $ "Decode error: " ++ err + Right res -> pure res + + +runClient :: Int -> IO () +runClient input = do + serverExe <- getExecutablePath + withServer serverExe $ \hFromServer hToServer -> do + pipe <- mkPipeFromHandles hFromServer hToServer + res <- customMessage pipe (SquareCommand input) + putStrLn $ "Square returned: " ++ show res + res2 <- customMessage pipe (MulCommand 2 res) + putStrLn $ "Mul returned: " ++ show res2 + +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a +withServer serverExe action = do + (ghcRead, serverWrite) <- createPipe + (serverRead, ghcWrite) <- createPipe + mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead] + let args = ["server", show serverWrite, show serverRead] + (_, _, _, ph) <- createProcess (proc serverExe args) + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + bracket (mkHandles ghcRead ghcWrite) + (\(hFromServer, hToServer) -> do + hClose hFromServer + hClose hToServer + terminateProcess ph + void (waitForProcess ph)) + (\(hFromServer, hToServer) -> action hFromServer hToServer) + where + mkHandles r w = do + hR <- fdToHandle r + hW <- fdToHandle w + mapM_ (`hSetBuffering` NoBuffering) [hR, hW] + mapM_ (`hSetBinaryMode` True) [hR, hW] + pure (hR, hW) + +-------------------------------------------------------------------------------- +-- Custom handler + +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler +customHandler handler tag payload + | tag == customTag = + case decodeLazy payload of + Left err -> do + hPutStrLn stderr $ "Custom handler decode error: " ++ err + pure Nothing + Right (Some @Bin.Binary r) -> do + res <- handler r + pure . Just $ encodeLazy res + | otherwise = pure Nothing ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/all.T ===================================== @@ -0,0 +1,10 @@ +test('custom-external-interpreter-commands', + [ extra_files(['Main.hs']) + , windows_skip + , when(config.cross, skip) + , req_process + , req_interp + , omit_ways(prof_ways) + ], + multimod_compile_and_run, + ['Main.hs', '-package ghci']) ===================================== testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout ===================================== @@ -0,0 +1,4 @@ +Sending: SquareCommand 12 +Square returned: 144 +Sending: MulCommand 2 144 +Mul returned: 288 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2130e1932e926870622680c69ce5c4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2130e1932e926870622680c69ce5c4... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Cheng Shao (＠TerrorJack)