- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/supersven/hadrian-cross-stage3] 16 commits: Build stage2 libs for testing
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/supersven/hadrian-cross-stage3 at Glasgow Haskell Compiler / GHC Commits: 46caa89b by Sven Tennie at 2026-02-24T23:06:12+00:00 Build stage2 libs for testing Provide js and wasm dependencies for stage1 as well. Stage2 should be good enough; However, this would imply changing topDir or adding a new configuration flag which would be a bigger untertaking. - - - - - bc30c235 by Sven Tennie at 2026-02-24T23:22:29+00:00 Fix weird space character - - - - - a366bebe by Sven Tennie at 2026-02-25T17:11:18+00:00 Add a config flag for LibDir and derived values For cross-compilers, we have to refer to the libs of the succeeding stage. This also affects other files previously relying on top_dir in GHC. - - - - - 6c99ca77 by Sven Tennie at 2026-02-25T17:13:24+00:00 Remove prior hack to provide WASM and GHCJS deps This can now be found in the succeeding stage. - - - - - 6a2aa024 by Sven Tennie at 2026-02-25T19:34:01+00:00 Use topLibDir - - - - - 5d7e35f3 by Sven Tennie at 2026-02-25T20:52:55+00:00 Fix stages in generateSettings - - - - - 9ad127f3 by Sven Tennie at 2026-02-26T11:12:42+00:00 Replace artificial "Lib TopDir" setting Hadrian can simply set "LibDir" instead. - - - - - c59356fb by Sven Tennie at 2026-02-26T12:50:15+00:00 Enable stage3 bin-dists - - - - - 1631a297 by Sven Tennie at 2026-02-26T12:50:15+00:00 Generated cross stage 3 CI jobs - - - - - f1c02ddf by Sven Tennie at 2026-02-26T12:50:15+00:00 Hack - - - - - 08edfc24 by Sven Tennie at 2026-02-26T12:50:15+00:00 WIP: Validate script - - - - - e921d232 by Sven Tennie at 2026-02-26T12:50:15+00:00 Fix stage3 bindist creation - - - - - 2d088be9 by Sven Tennie at 2026-02-26T12:50:15+00:00 Adjust jobs.yaml - - - - - 215fed2f by Sven Tennie at 2026-02-26T12:50:15+00:00 Fix final ghc-pkg recache run Sage3 cross-compiler's ghc-pkg cannot run on the build host. Resort to a prior stage's ghc-pkg. - - - - - c4c6e64e by Sven Tennie at 2026-02-26T12:50:15+00:00 Bindist name must start with ghc* - - - - - 568a597d by Sven Tennie at 2026-02-26T12:50:15+00:00 Increase generate-ci happyness Pass its checks by adding some metadata. - - - - - 15 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/bindist/Makefile - hadrian/src/BindistConfig.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/RunTest.hs - + validate-riscv-bindist.sh Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -286,6 +286,18 @@ crossConfig triple emulator configure_wrapper = , configureWrapper = configure_wrapper } +-- | cross-compiled compilers (build /= host/target) +stage3CrossConfig :: String -- ^ target triple + -> CrossEmulator -- ^ emulator for testing + -> Maybe String -- ^ Configure wrapper + -> BuildConfig +stage3CrossConfig triple emulator configure_wrapper = + vanilla { crossTarget = Just triple + , crossStage = Just 3 + , crossEmulator = emulator + , configureWrapper = configure_wrapper + } + llvm :: BuildConfig llvm = vanilla { llvmBootstrap = True } @@ -373,6 +385,8 @@ testEnv arch opsys bc = , ["zstd" | withZstd bc ] , ["no_tntc" | not (tablesNextToCode bc) ] , ["cross_"++triple | Just triple <- pure $ crossTarget bc ] + -- TODO: Is there something better than `show` for this? + , ["stage" ++ show stage | Just stage <- pure (crossStage bc), Just triple <- pure (crossTarget bc), "riscv" `isInfixOf` triple ] , [flavourString (mkJobFlavour bc)] ] @@ -1293,9 +1307,12 @@ cross_jobs = [ -- x86 -> aarch64 validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) - -- x86_64 -> riscv + -- x86_64 (build/host) -> riscv (target) , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing)) + -- x86_64 (build) -> riscv (host/target) + , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (stage3CrossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing)) + -- x86_64 -> loongarch64 , addValidateRule LoongArch64 (validateBuilds Amd64 (Linux Ubuntu2404LoongArch64) (crossConfig "loongarch64-linux-gnu" (Emulator "qemu-loongarch64 -L /usr/loongarch64-linux-gnu") Nothing)) @@ -1430,6 +1447,11 @@ platform_mapping = Map.map go combined_result , "release-x86_64-linux-deb12-release" , "release-x86_64-linux-fedora43-release" , "release-x86_64-windows-release" + , "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate" + , "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate" + -- TODO: Added those here for now, but do we really need RISC-V nightlies? Weekly should be fine. + , "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate" + , "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate" ] process sel = ===================================== .gitlab/jobs.yaml ===================================== @@ -2442,7 +2442,7 @@ "XZ_OPT": "-9" } }, - "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": { + "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -2453,7 +2453,7 @@ "artifacts": { "expire_in": "8 weeks", "paths": [ - "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz", + "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -2496,7 +2496,7 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu", @@ -2504,7 +2504,73 @@ "CROSS_TARGET": "riscv64-linux-gnu", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "-e config.timeout=900", - "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate", + "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate", + "XZ_OPT": "-9" + } + }, + "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-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-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb12-riscv-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_…", + "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-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu", + "CROSS_STAGE": "3", + "CROSS_TARGET": "riscv64-linux-gnu", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "-e config.timeout=900", + "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate", "XZ_OPT": "-9" } }, @@ -6610,7 +6676,7 @@ "TEST_ENV": "x86_64-linux-deb12-release" } }, - "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": { + "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -6621,7 +6687,7 @@ "artifacts": { "expire_in": "2 weeks", "paths": [ - "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz", + "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -6647,7 +6713,7 @@ ], "rules": [ { - "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)", "when": "on_success" } ], @@ -6664,7 +6730,7 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu", @@ -6672,7 +6738,72 @@ "CROSS_TARGET": "riscv64-linux-gnu", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "-e config.timeout=900", - "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate" + "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage2-validate" + } + }, + "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-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-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate.tar.xz", + "junit.xml", + "unexpected-test-output.tar.gz" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb12-riscv-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_…", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "((($ONLY_JOBS) && ($ONLY_JOBS =~ /.*\\bx86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate(\\s|$).*/)) || (($ONLY_JOBS == null) && ((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)))) && ($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-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check", + "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu", + "CROSS_STAGE": "3", + "CROSS_TARGET": "riscv64-linux-gnu", + "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", + "RUNTEST_ARGS": "-e config.timeout=900", + "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-stage3-validate" } }, "x86_64-linux-deb12-unreg-validate": { ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ topDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ topDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,6 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,6 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", topDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,6 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath + , fileSettings_libDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,6 +148,8 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" + lib_dir <- getSetting "LibDir" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -159,6 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/bindist/Makefile ===================================== @@ -90,6 +90,7 @@ lib/settings : config.mk @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ + @echo ',("LibDir", "$$topdir")' >> $@ @echo "]" >> $@ lib/targets/default.target : config.mk default.target ===================================== hadrian/src/BindistConfig.hs ===================================== @@ -1,29 +1,33 @@ module BindistConfig where -import Stage -import Oracles.Flag import Expression +import Oracles.Flag -data BindistConfig = BindistConfig { library_stage :: Stage -- ^ The stage compiler which builds the libraries - , executable_stage :: Stage -- ^ The stage compiler which builds the executables - } +data BindistConfig = BindistConfig + { -- | The stage compiler which builds the libraries + library_stage :: Stage, + -- | The stage compiler which builds the executables + executable_stage :: Stage, + -- | Which ghc-pkg to use (`targetBindist`'s + -- ghc-pkg cannot run on the build platform) + use_inplace_ghcPkg :: Bool + } -- | A bindist for when the host = target, non cross-compilation setting. -- Both the libraries and final executables are built with stage1 compiler. normalBindist :: BindistConfig -normalBindist = BindistConfig { library_stage = Stage1, executable_stage = Stage1 } +normalBindist = BindistConfig {library_stage = Stage1, executable_stage = Stage1, use_inplace_ghcPkg = True} -- | A bindist which contains a cross compiler (when host /= target) -- The cross compiler is produced by the stage1 compiler, but then we must compile -- all the boot libraries with the cross compiler (hence stage2 for libraries) crossBindist :: BindistConfig -crossBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage1 } +crossBindist = BindistConfig {library_stage = Stage2, executable_stage = Stage1, use_inplace_ghcPkg = True} -- | A bindist which contains executables for the target, which produce code for the -- target. These are produced as "Stage3" build products, produced by a stage2 cross compiler. -targetBindist :: BindistConfig -targetBindist = BindistConfig { library_stage = Stage2, executable_stage = Stage2 } - +targetBindist :: BindistConfig +targetBindist = BindistConfig {library_stage = Stage2, executable_stage = Stage2, use_inplace_ghcPkg = False} -- | The implicit bindist config, if we don't know any better. implicitBindistConfig :: Action BindistConfig @@ -35,7 +39,7 @@ implicitBindistConfig = do return $ if cross then crossBindist else normalBindist -- | Are we building things in this stage for the final target? -buildingForTarget :: Stage -> Action Bool +buildingForTarget :: Stage -> Action Bool buildingForTarget st = do cfg <- implicitBindistConfig return $ st >= (library_stage cfg) ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -96,7 +96,7 @@ arSupportsAtFile stage = Toolchain.arSupportsAtFile . tgtAr <$> targetStage stag targetSupportsSharedLibs :: Stage -> Action Bool targetSupportsSharedLibs stage = do windows <- isWinTarget stage - ppc_linux <- (&&) <$> anyTargetArch stage [ ArchPPC ] <*> anyTargetOs stage [ OSLinux ] + ppc_linux <- (&&) <$> anyTargetArch stage [ ArchPPC ] <*> anyTargetOs stage [ OSLinux ] solaris <- (&&) <$> anyTargetArch stage [ ArchX86 ] <*> anyTargetOs stage [ OSSolaris2 ] javascript <- anyTargetArch stage [ ArchJavaScript ] return $ not (windows || javascript || ppc_linux || solaris) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -122,8 +122,8 @@ installTo relocatable prefix = do runBuilderWithCmdOptions env (Make bindistFilesDir) ["install"] [] [] -buildBinDistDir :: FilePath -> BindistConfig -> Action () -buildBinDistDir root conf@BindistConfig{..} = do +buildBinDistDir :: FilePath -> FilePath -> BindistConfig -> Action () +buildBinDistDir dirSuffix root conf@BindistConfig{..} = do verbosity <- getVerbosity -- We 'need' all binaries and libraries @@ -153,7 +153,7 @@ buildBinDistDir root conf@BindistConfig{..} = do distDir <- Context.distDir (vanillaContext library_stage rts) let ghcBuildDir = root -/- stageString library_stage - bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty + bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty <> dirSuffix ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform rtsIncludeDir = distDir -/- "include" @@ -222,10 +222,16 @@ buildBinDistDir root conf@BindistConfig{..} = do -- -- N.B. the ghc-pkg executable may be prefixed with a target triple -- (c.f. #20267). - - -- Not going to work for cross - ghcPkgName <- programName (vanillaContext Stage1 ghcPkg) - cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache", "--package-db", bindistFilesDir -/- "lib" -/- "package.conf.d" ] + -- + -- For Stage3 cross-compilers (those that are supposed to run on the target + -- platform), we have to resort to a prior stage's ghc-pkg as the final + -- stage can naturally not be executed on our current build host. + if use_inplace_ghcPkg then do + ghcPkgName <- programName (vanillaContext executable_stage ghcPkg) + cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache", "--package-db", bindistFilesDir -/- "lib" -/- "package.conf.d" ] + else do + ghcPkgPath <- builderPath $ GhcPkg Recache library_stage + cmd_ ghcPkgPath ["recache", "--package-db", bindistFilesDir -/- "lib" -/- "package.conf.d" ] need ["docs"] @@ -316,27 +322,27 @@ bindistRules = do phony "binary-dist-dir" $ do cfg <- implicitBindistConfig - buildBinDistDir root cfg + buildBinDistDir "" root cfg + + phony "binary-dist-dir-cross" $ buildBinDistDir "" root crossBindist - phony "binary-dist-dir-cross" $ buildBinDistDir root crossBindist - -- MP: Not working yet - -- phony "binary-dist-dir-stage3" $ buildBinDistDir root targetBindist + phony "binary-dist-dir-stage3" $ buildBinDistDir "-stage3" root targetBindist let buildBinDist compressor = do win_host <- isWinHost win_target <- isWinTarget Stage2 when (win_target && win_host) (error "normal binary-dist does not work for windows targets, use `reloc-binary-dist-*` target instead.") - buildBinDistX "binary-dist-dir" "bindist" compressor - buildBinDistReloc = buildBinDistX "reloc-binary-dist-dir" "reloc-bindist" + buildBinDistX "binary-dist-dir" "bindist" "" compressor + buildBinDistReloc = buildBinDistX "reloc-binary-dist-dir" "reloc-bindist" "" - buildBinDistX :: String -> FilePath -> Compressor -> Action () - buildBinDistX target bindist_folder compressor = do + buildBinDistX :: String -> FilePath -> FilePath -> Compressor -> Action () + buildBinDistX target bindist_folder dirSuffix compressor = do need [target] version <- setting ProjectVersion targetPlatform <- setting TargetPlatformFull - let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform + let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform <> dirSuffix -- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz tarPath <- builderPath (Tar Create) @@ -352,12 +358,12 @@ bindistRules = do phony (name <> "-dist-xz") $ mk_bindist Xz -- TODO: Generate these targets as well - phony ("binary-dist-cross") $ buildBinDistX "binary-dist-dir-cross" "bindist" Xz - phony ("binary-dist-stage3") $ buildBinDistX "binary-dist-dir-stage3" "bindist" Xz + phony "binary-dist-cross" $ buildBinDistX "binary-dist-dir-cross" "bindist" "" Xz + phony "binary-dist-stage3" $ buildBinDistX "binary-dist-dir-stage3" "bindist" "-stage3" Xz -- Prepare binary distribution configure script -- (generated under <ghc root>/distrib/configure by 'autoreconf') - root -/- "bindist" -/- "ghc-*" -/- "configure" %> \configurePath -> do + root -/- "bindist" -/- "*ghc-*" -/- "configure" %> \configurePath -> do need ["distrib" -/- "configure.ac"] ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") @@ -372,7 +378,7 @@ bindistRules = do moveFile (ghcRoot -/- "distrib" -/- "configure") configurePath -- Generate the Makefile that enables the "make install" part - root -/- "bindist" -/- "ghc-*" -/- "Makefile" %> \makefilePath -> do + root -/- "bindist" -/- "*ghc-*" -/- "Makefile" %> \makefilePath -> do top <- topDirectory copyFile (top -/- "hadrian" -/- "bindist" -/- "Makefile") makefilePath @@ -381,7 +387,7 @@ bindistRules = do -- (see the list of files needed in the 'binary-dist' rule above, before -- creating the archive). forM_ bindistInstallFiles $ \file -> - root -/- "bindist" -/- "ghc-*" -/- file %> \dest -> do + root -/- "bindist" -/- "*ghc-*" -/- file %> \dest -> do copyFile (fixup file) dest where @@ -466,7 +472,7 @@ pkgToWrappers stage pkg = do -- These are the packages which we want to expose to the user and hence -- there are wrappers installed in the bindist. | pkg `elem` [hpcBin, haddock, hp2ps, hsc2hs, ghc, ghcPkg] - -> (:[]) <$> (programName =<< programContext Stage1 pkg) + -> (:[]) <$> (programName =<< programContext stage pkg) | otherwise -> pure [] wrapper :: Stage -> FilePath -> Action String ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) import GHC.Platform.ArchOS import qualified Data.Set as Set import UserSettings (finalStage) +import Hadrian.Oracles.Path -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () @@ -417,9 +418,15 @@ bindistRules = do templateRule ("distrib" -/- "configure.ac") $ mconcat [ interpolateSetting "ConfiguredEmsdkVersion" EmsdkVersion , interpolateVar "CrossCompilePrefix" $ do - crossCompiling <- interp $ getFlag CrossCompiling - tpf <- setting TargetPlatformFull - pure $ if crossCompiling then tpf <> "-" else "" + -- For a bindist, the prefix is needed only if the distributed compiler + -- is a cross-compiler (i.e., host != target in the bindist). + -- For Stage3 bindist (isStage3Cross=True), both host and target are the + -- target platform, so no prefix. For cross-compiler bindist (Stage1), + -- host != target, so we add the prefix. + -- Note: This template is shared by all bindist types, evaluated in Stage2 context. + host <- ifM isStage3Cross (setting TargetPlatformFull) (setting HostPlatformFull) + target <- setting TargetPlatformFull + pure $ if host /= target then target <> "-" else "" , interpolateVar "LeadingUnderscore" $ yesNo <$> getTarget tgtSymbolsHaveLeadingUnderscore , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion , interpolateSetting "LlvmMinVersion" LlvmMinVersion @@ -429,8 +436,8 @@ bindistRules = do , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ yesNo <$> interp (staged (buildFlag TargetHasLibm)) , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple - , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple - , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple + , interpolateVar "BuildPlatform" $ ifM isStage3Cross (getTarget targetPlatformTriple) (interp $ queryBuild targetPlatformTriple) + , interpolateVar "HostPlatform" $ ifM isStage3Cross (getTarget targetPlatformTriple) (interp $ queryHost targetPlatformTriple) , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian , interpolateVar "TargetWordSize" $ getTarget wordSize , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised @@ -439,13 +446,19 @@ bindistRules = do , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP Stage2 , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull) - , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull) - , interpolateVar "HostPlatformFull" (setting HostPlatformFull) + , interpolateVar "BuildPlatformFull" $ ifM isStage3Cross (setting TargetPlatformFull) (setting BuildPlatformFull) + , interpolateVar "HostPlatformFull" $ ifM isStage3Cross (setting TargetPlatformFull) (setting HostPlatformFull) ] where interp = interpretInContext (semiEmptyTarget Stage2) getTarget = interp . queryTarget Stage2 + -- TODO: This is a hack. It should be covered by config files + isStage3Cross = do + crossCompiling <- interp $ getFlag CrossCompiling + stage <- interp getStage + pure $ if crossCompiling && stage >= Stage2 then True else False + -- | Given a 'String' replace characters '.' and '-' by underscores ('_') so that -- the resulting 'String' is a valid C preprocessor identifier. cppify :: String -> String @@ -468,6 +481,8 @@ generateSettings :: FilePath -> Expr String generateSettings settingsFile = do ctx <- getContext stage <- getStage + let ghcStage = predStage stage + isCrossStage <- expr $ crossStage ghcStage package_db_path <- expr $ do let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) @@ -487,7 +502,13 @@ generateSettings settingsFile = do Stage2 -> pkgUnitId Stage1 base Stage3 -> pkgUnitId Stage2 base + rel_lib_topDir :: FilePath <- expr $ buildRoot <&> (-/- stageString (if isCrossStage then stage else ghcStage) -/- "lib") let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path + make_absolute rel_path = do + abs_path <- liftIO (makeAbsolute rel_path) + fixAbsolutePathOnWindows abs_path + + lib_topDir :: FilePath <- expr $ make_absolute rel_lib_topDir settings <- traverse sequence $ [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit, Context.stage = predStage stage }))) @@ -498,6 +519,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) + , ("LibDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -316,8 +316,10 @@ timeoutProgBuilder = do needTestsuitePackages :: Stage -> Action () needTestsuitePackages stg = do allpkgs <- packages <$> flavour - -- TODO: This used to force the packages to Stage1. Check if the tuple dance is still useful now. - libpkgs <- map (stg,) . filter isLibrary <$> allpkgs stg + isCross <- crossStage stg + -- In cross case, the libraries are one stage ahead + let libraryStage = if isCross then succStage stg else stg + libpkgs <- map (libraryStage,) . filter isLibrary <$> allpkgs libraryStage -- And the executables of the current stage exepkgs <- map (stg,) . filter isProgram <$> allpkgs stg -- Don't require lib:ghc or lib:cabal when testing the stage1 compiler ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -105,6 +105,7 @@ allowHaveLLVM = not . (`elem` ["wasm32", "javascript"]) -- inTreeCompilerArgs :: Stage -> Action TestCompilerArgs inTreeCompilerArgs stg = do + -- TODO: executable and library stage would be clearer cross <- crossStage stg let ghcStage = succStage stg pkgCacheStage = if cross then ghcStage else stg @@ -142,7 +143,7 @@ inTreeCompilerArgs stg = do pkgConfCacheFile <- System.FilePath.normalise . (top -/-) <$> (packageDbPath (PackageDbLoc pkgCacheStage Final) <&> (-/- "package.cache")) libdir <- System.FilePath.normalise . (top -/-) - <$> stageLibPath stg + <$> stageLibPath pkgCacheStage -- For this information, we need to query ghc --info, however, that would -- require building ghc, which we don't want to do here. Therefore, the ===================================== validate-riscv-bindist.sh ===================================== @@ -0,0 +1,184 @@ +#!/usr/bin/env bash +# Script to validate that only RISC-V binaries, libraries, and target strings +# are present in _build/bindist/stage3-* directories + +set -e + +RED='\033[0;31m' +GREEN='\033[0;32m' +YELLOW='\033[1;33m' +NC='\033[0m' # No Color + +ERRORS=0 +WARNINGS=0 + +echo "=== RISC-V Bindist Validation Script ===" +echo "" + +# Find all stage3-* directories +STAGE3_DIRS=$(find _build/bindist -maxdepth 1 -name "stage3-*" -type d 2>/dev/null || true) + +if [ -z "$STAGE3_DIRS" ]; then + echo -e "${YELLOW}Warning: No stage3-* directories found in _build/bindist/${NC}" + exit 1 +fi + +echo "Found stage3 directories:" +echo "$STAGE3_DIRS" +echo "" + +# Function to check if a file is a RISC-V binary/library +check_binary_arch() { + local file="$1" + + # Skip non-binary files + if ! file "$file" | grep -qE "ELF|archive"; then + return 0 + fi + + # Check architecture + local arch_info=$(file "$file") + + if echo "$arch_info" | grep -qE "RISC-V|riscv"; then + return 0 + else + echo -e "${RED}ERROR: Non-RISC-V binary/library found:${NC}" + echo " File: $file" + echo " Arch: $arch_info" + echo "" + return 1 + fi +} + +# Function to check target strings in text files +check_target_strings() { + local file="$1" + + # Skip if file is not readable or is a directory + if [ ! -f "$file" ] || [ ! -r "$file" ]; then + return 0 + fi + + # Skip binary files (ELF binaries and archives) + if file "$file" | grep -qE "ELF|archive"; then + return 0 + fi + + # Look for common non-RISC-V target patterns (case insensitive) + # Common architectures to check for: x86_64, aarch64, arm, i386, i686, powerpc, etc. + # Also check for build/host alias variables + local bad_patterns=( + "build_alias=.*x86_64" + "build_alias=.*aarch64" + "build_alias=.*i386" + "build_alias=.*i686" + "host_alias=.*x86_64" + "host_alias=.*aarch64" + "host_alias=.*i386" + "host_alias=.*i686" + "bootstrap_build=.*x86_64" + "bootstrap_build=.*aarch64" + "bootstrap_build=.*i386" + "bootstrap_build=.*i686" + "bootstrap_host=.*x86_64" + "bootstrap_host=.*aarch64" + "bootstrap_host=.*i386" + "bootstrap_host=.*i686" + ) + + local found_bad=0 + for pattern in "${bad_patterns[@]}"; do + if grep -qiE "$pattern" "$file" 2>/dev/null; then + if [ $found_bad -eq 0 ]; then + echo -e "${RED}ERROR: Non-RISC-V target string found in:${NC}" + echo " File: $file" + found_bad=1 + fi + echo " Pattern: $pattern" + # Show context (up to 3 lines) + grep -niE "$pattern" "$file" | head -3 | sed 's/^/ /' + fi + done + + if [ $found_bad -eq 1 ]; then + echo "" + return 1 + fi + + return 0 +} + +# Function to check for RISC-V references (informational) +check_riscv_presence() { + local file="$1" + + # Skip binary files for this check + if file "$file" | grep -qE "ELF|archive|executable"; then + return 0 + fi + + if [ ! -f "$file" ] || [ ! -r "$file" ]; then + return 0 + fi + + # Check if it's a text file + if ! file "$file" | grep -qE "text|ASCII|UTF-8|script"; then + return 0 + fi + + # Look for RISC-V patterns + if grep -qiE "riscv|risc-v" "$file" 2>/dev/null; then + return 0 + fi + + return 1 +} + +echo "=== Checking binaries and libraries for architecture ===" +echo "" + +for dir in $STAGE3_DIRS; do + echo "Scanning: $dir" + + # Find all ELF binaries and archives + while IFS= read -r -d '' file; do + if ! check_binary_arch "$file"; then + ((ERRORS++)) + fi + done < <(find "$dir" -type f -executable -print0 2>/dev/null) + + # Also check .a and .so files + while IFS= read -r -d '' file; do + if ! check_binary_arch "$file"; then + ((ERRORS++)) + fi + done < <(find "$dir" -type f $ -name "*.a" -o -name "*.so" -o -name "*.so.*" $ -print0 2>/dev/null) +done + +echo "" +echo "=== Checking text files for non-RISC-V target strings ===" +echo "" + +for dir in $STAGE3_DIRS; do + echo "Scanning: $dir" + + # Check common configuration and script files + while IFS= read -r -d '' file; do + if ! check_target_strings "$file"; then + ((ERRORS++)) + fi + done < <(find "$dir" -type f $ -name "*.conf" -o -name "*.config" -o -name "*.sh" -o -name "*.txt" -o -name "*.cabal" -o -name "*.mk" -o -name "Makefile" -o -name "configure" $ -print0 2>/dev/null) +done + +echo "" +echo "=== Summary ===" +echo "" + +if [ $ERRORS -eq 0 ]; then + echo -e "${GREEN}✓ All checks passed! Only RISC-V binaries/libraries and target strings found.${NC}" + exit 0 +else + echo -e "${RED}✗ Found $ERRORS error(s)${NC}" + echo -e "${RED}Non-RISC-V content detected in stage3 bindist directories!${NC}" + exit 1 +fi View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c52a9b511ff993064098aa43e4fd95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c52a9b511ff993064098aa43e4fd95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Remove in-package dependencies on `GHC.Internal.System.IO`
by Wolfgang Jeltsch (＠jeltsch) 26 Feb '26

26 Feb '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC Commits: 537c4d0e by Wolfgang Jeltsch at 2026-02-26T14:42:42+02:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Move some `IsString` instance declarations into `base` * Move the `* -> *` `Heap.Closure` instances into `ghc-heap` * Move some code that needs `System.IO` to `template-haskell` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `GHCi.Helpers` implementation into `base` * Move the `System.IO.OS` implementation into `base` - - - - - 26 changed files: - libraries/base/src/Data/String.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/GHCi/Helpers.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - − libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/typecheck/should_fail/T12921.stderr Changes: ===================================== libraries/base/src/Data/String.hs ===================================== @@ -1,4 +1,8 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} -- | -- @@ -23,4 +27,13 @@ module Data.String unwords ) where -import GHC.Internal.Data.String \ No newline at end of file +import GHC.Internal.Data.String + +import GHC.Internal.Data.Functor.Const (Const (Const)) +import GHC.Internal.Data.Functor.Identity (Identity (Identity)) + +-- | @since base-4.9.0.0 +deriving instance IsString a => IsString (Const a (b :: k)) + +-- | @since base-4.9.0.0 +deriving instance IsString a => IsString (Identity a) ===================================== libraries/base/src/GHC/Fingerprint.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} module GHC.Fingerprint ( Fingerprint(..), fingerprint0, @@ -9,3 +9,50 @@ module GHC.Fingerprint ( ) where import GHC.Internal.Fingerprint + +import GHC.Internal.Base + ( + ($), + return, + when, + not, + (&&), + (/=), + (++), + Int, + errorWithoutStackTrace + ) +import GHC.Internal.Show (show) +import GHC.Internal.Data.Maybe (Maybe (Nothing, Just)) +import GHC.Internal.Word (Word8) +import GHC.Internal.System.IO + ( + IO, + FilePath, + IOMode (ReadMode), + withBinaryFile, + hGetBuf, + hIsEOF + ) +import GHC.Internal.Ptr (Ptr) + +-- | Computes the hash of a given file. +-- This function runs in constant memory. +-- +-- @since base-4.7.0.0 +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \ hdl -> + let + readChunk :: Ptr Word8 -> Int -> IO (Maybe Int) + readChunk bufferPtr bufferSize = do + chunkSize <- hGetBuf hdl bufferPtr bufferSize + isFinished <- hIsEOF hdl + when (chunkSize /= bufferSize && not isFinished) + ( + errorWithoutStackTrace $ + "GHC.Fingerprint.getFileHash: could only read " ++ + show chunkSize ++ + " bytes, but more are available" + ) + return (if isFinished then Just chunkSize else Nothing) + in fingerprintBufferedStream readChunk ===================================== libraries/base/src/GHC/GHCi/Helpers.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -24,4 +24,21 @@ module GHC.GHCi.Helpers evalWrapper ) where -import GHC.Internal.GHCi.Helpers \ No newline at end of file +import GHC.Internal.Base +import GHC.Internal.System.IO +import GHC.Internal.System.Environment + +disableBuffering :: IO () +disableBuffering = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + +flushAll :: IO () +flushAll = do + hFlush stdout + hFlush stderr + +evalWrapper :: String -> [String] -> IO a -> IO a +evalWrapper progName args m = + withProgName progName (withArgs args m) ===================================== libraries/base/src/GHC/ResponseFile.hs ===================================== @@ -1,4 +1,5 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} -- | -- Module : GHC.ResponseFile @@ -19,4 +20,140 @@ module GHC.ResponseFile ( expandResponse ) where -import GHC.Internal.ResponseFile +import GHC.Internal.Control.Exception +import GHC.Internal.Data.Foldable (Foldable(..)) +import GHC.Internal.Base +import GHC.Internal.Unicode (isSpace) +import GHC.Internal.Data.List (filter, unlines, concat, reverse) +import GHC.Internal.Text.Show (show) +import GHC.Internal.System.Environment (getArgs) +import GHC.Internal.System.IO +import System.Exit (exitFailure) + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechanism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like @\@foo@ will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -21,4 +21,59 @@ module System.Exit die ) where -import GHC.Internal.System.Exit \ No newline at end of file +import GHC.Internal.System.IO + +import GHC.Internal.Base +import GHC.Internal.IO +import GHC.Internal.IO.Exception + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be +-- caught using the functions of "Control.Exception". This means that +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from +-- "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since base-4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-| This module bridges between Haskell handles and underlying operating-system @@ -21,17 +23,293 @@ module System.IO.OS ) where -import GHC.Internal.System.IO.OS +import Control.Monad (return) +import Control.Concurrent.MVar (MVar) +import Control.Exception (mask) +import Data.Function (const, (.), ($)) +import Data.Functor (fmap) +import Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Just)) +#endif +import Data.List ((++)) +import Data.String (String) +import Data.Typeable (Typeable, cast) +import System.IO (IO) +import GHC.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.IO.Windows.Handle ( - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE ) +#endif +import GHC.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) -- ** Caveats ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box. @@ -42,3 +37,23 @@ module GHC.Exts.Heap.Closures ( ) where import GHC.Internal.Heap.Closures + +import GHC.Internal.Data.Functor +import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Traversable + +deriving instance Functor GenClosure +deriving instance Foldable GenClosure +deriving instance Traversable GenClosure + +deriving instance Functor GenStgStackClosure +deriving instance Foldable GenStgStackClosure +deriving instance Traversable GenStgStackClosure + +deriving instance Functor GenStackField +deriving instance Foldable GenStackField +deriving instance Traversable GenStackField + +deriving instance Functor GenStackFrame +deriving instance Foldable GenStackFrame +deriving instance Traversable GenStackFrame ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -228,7 +228,6 @@ Library GHC.Internal.ForeignPtr GHC.Internal.Functor.ZipList GHC.Internal.GHCi - GHC.Internal.GHCi.Helpers GHC.Internal.Generics GHC.Internal.Heap.Closures GHC.Internal.Heap.Constants @@ -284,7 +283,6 @@ Library GHC.Internal.Read GHC.Internal.Real GHC.Internal.Records - GHC.Internal.ResponseFile GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST @@ -323,10 +321,8 @@ Library GHC.Internal.Numeric.Natural GHC.Internal.System.Environment GHC.Internal.System.Environment.Blank - GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error - GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String.hs ===================================== @@ -1,8 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -33,8 +30,6 @@ module GHC.Internal.Data.String ( ) where import GHC.Internal.Base -import GHC.Internal.Data.Functor.Const (Const (Const)) -import GHC.Internal.Data.Functor.Identity (Identity (Identity)) import GHC.Internal.Data.List (lines, words, unlines, unwords) -- | `IsString` is used in combination with the @-XOverloadedStrings@ @@ -105,9 +100,3 @@ ensure the good behavior of the above example remains in the future. instance (a ~ Char) => IsString [a] where -- See Note [IsString String] fromString xs = xs - --- | @since base-4.9.0.0 -deriving instance IsString a => IsString (Const a (b :: k)) - --- | @since base-4.9.0.0 -deriving instance IsString a => IsString (Identity a) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..), (&&) ) +import GHC.Internal.Base ( Applicative(..), (&&), String ) import GHC.Internal.Generics import GHC.Internal.Unicode ( isDigit, isAlphaNum ) import GHC.Internal.Read ===================================== libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs ===================================== @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint ( fingerprintData, fingerprintString, fingerprintFingerprints, - getFileHash + fingerprintBufferedStream ) where import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.Bits import GHC.Internal.Num +import GHC.Internal.Data.Maybe import GHC.Internal.List import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Foreign.Storable -import GHC.Internal.System.IO import GHC.Internal.Fingerprint.Type @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $ fromIntegral (w32 `shiftR` 8), fromIntegral w32] --- | Computes the hash of a given file. --- This function loops over the handle, running in constant memory. --- --- @since base-4.7.0.0 -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> +-- | Reads data in chunks and computes its hash. +-- This function runs in constant memory. +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) + -> IO Fingerprint +fingerprintBufferedStream readChunk = allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do c_MD5Init pctxt - - processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size)) - + allocaBytes _BUFSIZE $ \arrPtr -> + let loop = do + maybeRemainderSize <- readChunk arrPtr _BUFSIZE + c_MD5Update pctxt + arrPtr + (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize)) + when (isNothing maybeRemainderSize) loop + in loop allocaBytes 16 $ \pdigest -> do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) - where _BUFSIZE = 4096 - -- Loop over _BUFSIZE sized chunks read from the handle, - -- passing the callback a block of bytes and its size. - processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () - processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> - - let loop = do - count <- hGetBuf h arrPtr _BUFSIZE - eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ - "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" - - f arrPtr count - - when (not eof) loop - - in loop - data MD5Context foreign import ccall unsafe "__hsbase_MD5Init" ===================================== libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs deleted ===================================== @@ -1,44 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.GHCi.Helpers --- Copyright : (c) The GHC Developers --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Various helpers used by the GHCi shell. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- ------------------------------------------------------------------------------ - -module GHC.Internal.GHCi.Helpers - ( disableBuffering, flushAll - , evalWrapper - ) where - -import GHC.Internal.Base -import GHC.Internal.System.IO -import GHC.Internal.System.Environment - -disableBuffering :: IO () -disableBuffering = do - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - hSetBuffering stderr NoBuffering - -flushAll :: IO () -flushAll = do - hFlush stdout - hFlush stderr - -evalWrapper :: String -> [String] -> IO a -> IO a -evalWrapper progName args m = - withProgName progName (withArgs args m) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -5,7 +5,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box. -- This can be removed once our boot compiler is no longer affected by #25212 @@ -69,8 +68,7 @@ in the profiling way. (#15197) import GHC.Internal.Heap.ProfInfo.Types import GHC.Internal.Data.Bits -import GHC.Internal.Data.Foldable (Foldable, toList) -import GHC.Internal.Data.Traversable (Traversable) +import GHC.Internal.Data.Foldable (toList) import GHC.Internal.Int import GHC.Internal.Num import GHC.Internal.Real @@ -383,7 +381,7 @@ data GenClosure b -- or an Int#). | UnknownTypeWordSizedPrimitive { wordVal :: !Word } - deriving (Show, Generic, Functor, Foldable, Traversable) + deriving (Show, Generic) -- | Get the info table for a heap closure, or Nothing for a prim value -- @@ -500,7 +498,7 @@ data GenStgStackClosure b = GenStgStackClosure , ssc_stack_size :: !Word32 -- ^ stack size in *words* , ssc_stack :: ![GenStackFrame b] } - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) type StackField = GenStackField Box @@ -510,7 +508,7 @@ data GenStackField b = StackWord !Word -- | A pointer field | StackBox !b - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) type StackFrame = GenStackFrame Box @@ -579,7 +577,7 @@ data GenStackFrame b = { info_tbl :: !StgInfoTable , annotation :: !b } - deriving (Foldable, Functor, Generic, Show, Traversable) + deriving (Generic, Show) data PrimType = PInt ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted ===================================== @@ -1,163 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.ResponseFile --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : internal --- Portability : portable --- --- GCC style response files. --- --- @since base-4.12.0.0 ----------------------------------------------------------------------------- - --- Migrated from Haddock. - -module GHC.Internal.ResponseFile ( - getArgsWithResponseFiles, - unescapeArgs, - escapeArgs, escapeArg, - expandResponse - ) where - -import GHC.Internal.Control.Exception -import GHC.Internal.Data.Foldable (Foldable(..)) -import GHC.Internal.Base -import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) -import GHC.Internal.Text.Show (show) -import GHC.Internal.System.Environment (getArgs) -import GHC.Internal.System.Exit (exitFailure) -import GHC.Internal.System.IO - -{-| -Like 'getArgs', but can also read arguments supplied via response files. - - -For example, consider a program @foo@: - -@ -main :: IO () -main = do - args <- getArgsWithResponseFiles - putStrLn (show args) -@ - - -And a response file @args.txt@: - -@ ---one 1 ---\'two\' 2 ---"three" 3 -@ - -Then the result of invoking @foo@ with @args.txt@ is: - -> > ./foo @args.txt -> ["--one","1","--two","2","--three","3"] - --} -getArgsWithResponseFiles :: IO [String] -getArgsWithResponseFiles = getArgs >>= expandResponse - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechanism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like @\@foo@ will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted ===================================== @@ -1,81 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.System.Exit --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : provisional --- Portability : portable --- --- Exiting the program. --- ------------------------------------------------------------------------------ - -module GHC.Internal.System.Exit - ( - ExitCode(ExitSuccess,ExitFailure) - , exitWith - , exitFailure - , exitSuccess - , die - ) where - -import GHC.Internal.System.IO - -import GHC.Internal.Base -import GHC.Internal.IO -import GHC.Internal.IO.Exception - --- --------------------------------------------------------------------------- --- exitWith - --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. --- Normally this terminates the program, returning @code@ to the --- program's caller. --- --- On program termination, the standard 'Handle's 'stdout' and --- 'stderr' are flushed automatically; any other buffered 'Handle's --- need to be flushed manually, otherwise the buffered data will be --- discarded. --- --- A program that fails in any other way is treated as if it had --- called 'exitFailure'. --- A program that terminates successfully without calling 'exitWith' --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. --- --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be --- caught using the functions of "Control.Exception". This means that --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from --- "Control.Exception") are also executed properly on 'exitWith'. --- --- Note: in GHC, 'exitWith' should be called from the main program --- thread in order to exit the process. When called from another --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the --- exception will not cause the process itself to exit. --- -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO ExitSuccess -exitWith code@(ExitFailure n) - | n /= 0 = throwIO code - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) - --- | The computation 'exitFailure' is equivalent to --- 'exitWith' @(@'ExitFailure' /exitfail/@)@, --- where /exitfail/ is implementation-dependent. -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- | The computation 'exitSuccess' is equivalent to --- 'exitWith' 'ExitSuccess', It terminates the program --- successfully. -exitSuccess :: IO a -exitSuccess = exitWith ExitSuccess - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since base-4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted ===================================== @@ -1,323 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - -{-| - This module bridges between Haskell handles and underlying operating-system - features. --} -module GHC.Internal.System.IO.OS -( - -- * Obtaining file descriptors and Windows handles - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw - - -- ** Caveats - -- $with-ref-caveats -) -where - -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (otherwise) -#endif -import GHC.Internal.Control.Monad (return) -import GHC.Internal.Control.Concurrent.MVar (MVar) -import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function (const, (.), ($)) -import GHC.Internal.Data.Functor (fmap) -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Maybe (Maybe (Just)) -#endif -import GHC.Internal.Data.List ((++)) -import GHC.Internal.Data.String (String) -import GHC.Internal.Data.Typeable (Typeable, cast) -import GHC.Internal.System.IO (IO) -import GHC.Internal.IO.FD (fdFD) -#if defined(mingw32_HOST_OS) -import GHC.Internal.IO.Windows.Handle - ( - NativeHandle, - ConsoleHandle, - IoHandle, - toHANDLE - ) -#endif -import GHC.Internal.IO.Handle.Types - ( - Handle (FileHandle, DuplexHandle), - Handle__ (Handle__, haDevice) - ) -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) -import GHC.Internal.IO.Exception - ( - IOErrorType (InappropriateType), - IOException (IOError), - ioException - ) -import GHC.Internal.Foreign.Ptr (Ptr) -import GHC.Internal.Foreign.C.Types (CInt) - --- * Obtaining POSIX file descriptors and Windows handles - -{-| - Executes a user-provided action on an operating-system handle that underlies - a Haskell handle. Before the user-provided action is run, user-defined - preparation based on the handle state that contains the operating-system - handle is performed. While the user-provided action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withOSHandle :: String - -- ^ The name of the overall operation - -> (Handle -> MVar Handle__) - {-^ - Obtaining of the handle state variable that holds the - operating-system handle - -} - -> (forall d. Typeable d => d -> IO a) - -- ^ Conversion of a device into an operating-system handle - -> (Handle__ -> IO ()) - -- ^ The preparation - -> Handle - -- ^ The Haskell handle to use - -> (a -> IO r) - -- ^ The action to execute on the operating-system handle - -> IO r -withOSHandle opName handleStateVar getOSHandle prepare handle act - = mask $ \ withOriginalMaskingState -> - withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do - osHandle <- getOSHandle dev - prepare handleState - withOriginalMaskingState $ act osHandle - where - - withHandleState = withHandle_' opName handle (handleStateVar handle) -{- - The 'withHandle_'' operation, which we use here, already performs masking. - Still, we have to employ 'mask', in order do obtain the operation that - restores the original masking state. The user-provided action should be - executed with this original masking state, as there is no inherent reason to - generally perform it with masking in place. The masking that 'withHandle_'' - performs is only for safely accessing handle state and thus constitutes an - implementation detail; it has nothing to do with the user-provided action. --} -{- - The order of actions in 'withOSHandle' is such that any exception from - 'getOSHandle' is thrown before the user-defined preparation is performed. --} - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for reading if the handle uses different state - variables for reading and writing. --} -handleStateVarReadingBiased :: Handle -> MVar Handle__ -handleStateVarReadingBiased (FileHandle _ var) = var -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for writing if the handle uses different state - variables for reading and writing. --} -handleStateVarWritingBiased :: Handle -> MVar Handle__ -handleStateVarWritingBiased (FileHandle _ var) = var -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar - -{-| - Yields the result of another operation if that operation succeeded, and - otherwise throws an exception that signals that the other operation failed - because some Haskell handle does not use an operating-system handle of a - required type. --} -requiringOSHandleOfType :: String - -- ^ The name of the operating-system handle type - -> Maybe a - {-^ - The result of the other operation if it succeeded - -} - -> IO a -requiringOSHandleOfType osHandleTypeName - = maybe (ioException osHandleOfTypeRequired) return - where - - osHandleOfTypeRequired :: IOException - osHandleOfTypeRequired - = IOError Nothing - InappropriateType - "" - ("handle does not use " ++ osHandleTypeName ++ "s") - Nothing - Nothing - -{-| - Obtains the POSIX file descriptor of a device if the device contains one, - and throws an exception otherwise. --} -getFileDescriptor :: Typeable d => d -> IO CInt -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . - fmap fdFD . cast - -{-| - Obtains the Windows handle of a device if the device contains one, and - throws an exception otherwise. --} -getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringOSHandleOfType "Windows handle" . - toMaybeWindowsHandle - where - - toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) -#if defined(mingw32_HOST_OS) - toMaybeWindowsHandle dev - | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) - = Just (toHANDLE nativeHandle) - | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) - = Just (toHANDLE consoleHandle) - | otherwise - = Nothing - {- - This is inspired by the implementation of - 'System.Win32.Types.withHandleToHANDLENative'. - -} -#else - toMaybeWindowsHandle _ = Nothing -#endif - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for reading if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" - handleStateVarReadingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for writing if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" - handleStateVarWritingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for reading if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" - handleStateVarReadingBiased - getWindowsHandle - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for writing if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" - handleStateVarWritingBiased - getWindowsHandle - flushBuffer - -{-| - Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiasedRaw - = withOSHandle "withFileDescriptorReadingBiasedRaw" - handleStateVarReadingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiasedRaw - = withOSHandle "withFileDescriptorWritingBiasedRaw" - handleStateVarWritingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiasedRaw - = withOSHandle "withWindowsHandleReadingBiasedRaw" - handleStateVarReadingBiased - getWindowsHandle - (const $ return ()) - -{-| - Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiasedRaw - = withOSHandle "withWindowsHandleWritingBiasedRaw" - handleStateVarWritingBiased - getWindowsHandle - (const $ return ()) - --- ** Caveats - -{-$with-ref-caveats - #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve - as the target of the hyperlinks above. The real documentation of the caveats - is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which - re-exports the above operations. --} ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad import Prelude import Data.Data hiding (Fixity(..)) import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO ( hPutStrLn, stderr ) +import System.IO (FilePath, hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) -import GHC.Types (TYPE, RuntimeRep(..)) +import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.Traversable import GHC.Internal.IORef -import GHC.Internal.System.IO +import GHC.Internal.IO (FilePath) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stderr) import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix) addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is recommended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignSource LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignSource :: ForeignSrcLang -> String -> Q () -addForeignSource lang src = do - let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" - LangObjcxx -> "mm" - LangAsm -> "s" - LangJs -> "js" - RawObject -> "a" - path <- addTempFile suffix - runIO $ writeFile path src - addForeignFilePath lang path - -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in -- conjunction with 'addTempFile'. ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) -- This module completely re-exports 'GHC.Boot.TH.Syntax', --- and exports additionally functions that depend on filepath. +-- and exports additionally functions that depend on @filepath@ or @System.IO@. -- | addForeignFile :: ForeignSrcLang -> String -> Q () @@ -218,6 +218,37 @@ addForeignFile = addForeignSource "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is recommended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignSource LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + LangAsm -> "s" + LangJs -> "js" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1673,7 +1673,7 @@ module Data.Semigroup where stimesMonoid :: forall b a. (GHC.Internal.Real.Integral b, GHC.Internal.Base.Monoid a) => b -> a -> a module Data.String where - -- Safety: Safe + -- Safety: Trustworthy type IsString :: * -> Constraint class IsString a where fromString :: String -> a @@ -7072,7 +7072,7 @@ module GHC.Exts where {-# MINIMAL #-} module GHC.Fingerprint where - -- Safety: Safe + -- Safety: Trustworthy type Fingerprint :: * data Fingerprint = Fingerprint {-# UNPACK #-} !GHC.Internal.Word.Word64 {-# UNPACK #-} !GHC.Internal.Word.Word64 fingerprint0 :: Fingerprint @@ -7353,7 +7353,7 @@ module GHC.GHCi where newtype NoIO a = ... module GHC.GHCi.Helpers where - -- Safety: Safe + -- Safety: Trustworthy disableBuffering :: GHC.Internal.Types.IO () evalWrapper :: forall a. GHC.Internal.Base.String -> [GHC.Internal.Base.String] -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a flushAll :: GHC.Internal.Types.IO () @@ -8905,7 +8905,7 @@ module GHC.Records where {-# MINIMAL getField #-} module GHC.ResponseFile where - -- Safety: Safe + -- Safety: Trustworthy escapeArgs :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String expandResponse :: [GHC.Internal.Base.String] -> GHC.Internal.Types.IO [GHC.Internal.Base.String] getArgsWithResponseFiles :: GHC.Internal.Types.IO [GHC.Internal.Base.String] @@ -9874,7 +9874,7 @@ module System.Environment.Blank where withProgName :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a module System.Exit where - -- Safety: Safe + -- Safety: Trustworthy type ExitCode :: * data ExitCode = ExitSuccess | ExitFailure GHC.Internal.Types.Int die :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a @@ -11779,8 +11779,8 @@ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.First -- Defined in instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ +instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘Data.String’ +instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance GHC.Internal.Data.Traversable.Traversable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Traversable.Traversable f, GHC.Internal.Data.Traversable.Traversable g) => GHC.Internal.Data.Traversable.Traversable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Traversable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1673,7 +1673,7 @@ module Data.Semigroup where stimesMonoid :: forall b a. (GHC.Internal.Real.Integral b, GHC.Internal.Base.Monoid a) => b -> a -> a module Data.String where - -- Safety: Safe + -- Safety: Trustworthy type IsString :: * -> Constraint class IsString a where fromString :: String -> a @@ -7044,7 +7044,7 @@ module GHC.Exts where {-# MINIMAL #-} module GHC.Fingerprint where - -- Safety: Safe + -- Safety: Trustworthy type Fingerprint :: * data Fingerprint = Fingerprint {-# UNPACK #-} !GHC.Internal.Word.Word64 {-# UNPACK #-} !GHC.Internal.Word.Word64 fingerprint0 :: Fingerprint @@ -7325,7 +7325,7 @@ module GHC.GHCi where newtype NoIO a = ... module GHC.GHCi.Helpers where - -- Safety: Safe + -- Safety: Trustworthy disableBuffering :: GHC.Internal.Types.IO () evalWrapper :: forall a. GHC.Internal.Base.String -> [GHC.Internal.Base.String] -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a flushAll :: GHC.Internal.Types.IO () @@ -8943,7 +8943,7 @@ module GHC.Records where {-# MINIMAL getField #-} module GHC.ResponseFile where - -- Safety: Safe + -- Safety: Trustworthy escapeArgs :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String expandResponse :: [GHC.Internal.Base.String] -> GHC.Internal.Types.IO [GHC.Internal.Base.String] getArgsWithResponseFiles :: GHC.Internal.Types.IO [GHC.Internal.Base.String] @@ -9912,7 +9912,7 @@ module System.Environment.Blank where withProgName :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a module System.Exit where - -- Safety: Safe + -- Safety: Trustworthy type ExitCode :: * data ExitCode = ExitSuccess | ExitFailure GHC.Internal.Types.Int die :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a @@ -11806,8 +11806,8 @@ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.First -- Defined in instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ +instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘Data.String’ +instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance GHC.Internal.Data.Traversable.Traversable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Traversable.Traversable f, GHC.Internal.Data.Traversable.Traversable g) => GHC.Internal.Data.Traversable.Traversable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Traversable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1673,7 +1673,7 @@ module Data.Semigroup where stimesMonoid :: forall b a. (GHC.Internal.Real.Integral b, GHC.Internal.Base.Monoid a) => b -> a -> a module Data.String where - -- Safety: Safe + -- Safety: Trustworthy type IsString :: * -> Constraint class IsString a where fromString :: String -> a @@ -7215,7 +7215,7 @@ module GHC.Exts where {-# MINIMAL #-} module GHC.Fingerprint where - -- Safety: Safe + -- Safety: Trustworthy type Fingerprint :: * data Fingerprint = Fingerprint {-# UNPACK #-} !GHC.Internal.Word.Word64 {-# UNPACK #-} !GHC.Internal.Word.Word64 fingerprint0 :: Fingerprint @@ -7496,7 +7496,7 @@ module GHC.GHCi where newtype NoIO a = ... module GHC.GHCi.Helpers where - -- Safety: Safe + -- Safety: Trustworthy disableBuffering :: GHC.Internal.Types.IO () evalWrapper :: forall a. GHC.Internal.Base.String -> [GHC.Internal.Base.String] -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a flushAll :: GHC.Internal.Types.IO () @@ -9123,7 +9123,7 @@ module GHC.Records where {-# MINIMAL getField #-} module GHC.ResponseFile where - -- Safety: Safe + -- Safety: Trustworthy escapeArgs :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String expandResponse :: [GHC.Internal.Base.String] -> GHC.Internal.Types.IO [GHC.Internal.Base.String] getArgsWithResponseFiles :: GHC.Internal.Types.IO [GHC.Internal.Base.String] @@ -10154,7 +10154,7 @@ module System.Environment.Blank where withProgName :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a module System.Exit where - -- Safety: Safe + -- Safety: Trustworthy type ExitCode :: * data ExitCode = ExitSuccess | ExitFailure GHC.Internal.Types.Int die :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a @@ -12037,8 +12037,8 @@ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.First -- Defined in instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ +instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘Data.String’ +instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance GHC.Internal.Data.Traversable.Traversable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Traversable.Traversable f, GHC.Internal.Data.Traversable.Traversable g) => GHC.Internal.Data.Traversable.Traversable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Traversable’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1673,7 +1673,7 @@ module Data.Semigroup where stimesMonoid :: forall b a. (GHC.Internal.Real.Integral b, GHC.Internal.Base.Monoid a) => b -> a -> a module Data.String where - -- Safety: Safe + -- Safety: Trustworthy type IsString :: * -> Constraint class IsString a where fromString :: String -> a @@ -7072,7 +7072,7 @@ module GHC.Exts where {-# MINIMAL #-} module GHC.Fingerprint where - -- Safety: Safe + -- Safety: Trustworthy type Fingerprint :: * data Fingerprint = Fingerprint {-# UNPACK #-} !GHC.Internal.Word.Word64 {-# UNPACK #-} !GHC.Internal.Word.Word64 fingerprint0 :: Fingerprint @@ -7353,7 +7353,7 @@ module GHC.GHCi where newtype NoIO a = ... module GHC.GHCi.Helpers where - -- Safety: Safe + -- Safety: Trustworthy disableBuffering :: GHC.Internal.Types.IO () evalWrapper :: forall a. GHC.Internal.Base.String -> [GHC.Internal.Base.String] -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a flushAll :: GHC.Internal.Types.IO () @@ -8905,7 +8905,7 @@ module GHC.Records where {-# MINIMAL getField #-} module GHC.ResponseFile where - -- Safety: Safe + -- Safety: Trustworthy escapeArgs :: [GHC.Internal.Base.String] -> GHC.Internal.Base.String expandResponse :: [GHC.Internal.Base.String] -> GHC.Internal.Types.IO [GHC.Internal.Base.String] getArgsWithResponseFiles :: GHC.Internal.Types.IO [GHC.Internal.Base.String] @@ -9874,7 +9874,7 @@ module System.Environment.Blank where withProgName :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO a module System.Exit where - -- Safety: Safe + -- Safety: Trustworthy type ExitCode :: * data ExitCode = ExitSuccess | ExitFailure GHC.Internal.Types.Int die :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a @@ -11779,8 +11779,8 @@ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.First -- Defined in instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance GHC.Internal.Data.Foldable.Foldable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ +instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘Data.String’ +instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance GHC.Internal.Data.Traversable.Traversable GHC.Internal.Functor.ZipList.ZipList -- Defined in ‘GHC.Internal.Functor.ZipList’ instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Data.Traversable.Traversable f, GHC.Internal.Data.Traversable.Traversable g) => GHC.Internal.Data.Traversable.Traversable (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Data.Traversable’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout ===================================== @@ -11190,8 +11190,6 @@ instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.FunPtr a) -- Defin instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.Ptr a) -- Defined in ‘GHC.Internal.Ptr’ instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Classes.Ord GHC.Internal.Base.Void -- Defined in ‘GHC.Internal.Base’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance forall a. GHC.Internal.Enum.Bounded a => GHC.Internal.Enum.Bounded (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. (GHC.Internal.Enum.Enum a, GHC.Internal.Enum.Bounded a, GHC.Internal.Classes.Eq a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ ===================================== testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 ===================================== @@ -11193,8 +11193,6 @@ instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.FunPtr a) -- Defin instance forall a. GHC.Internal.Classes.Ord (GHC.Internal.Ptr.Ptr a) -- Defined in ‘GHC.Internal.Ptr’ instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’ instance GHC.Internal.Classes.Ord GHC.Internal.Base.Void -- Defined in ‘GHC.Internal.Base’ -instance forall a k (b :: k). GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.String’ -instance forall a. GHC.Internal.Data.String.IsString a => GHC.Internal.Data.String.IsString (GHC.Internal.Data.Functor.Identity.Identity a) -- Defined in ‘GHC.Internal.Data.String’ instance forall a. (a ~ GHC.Internal.Types.Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ instance forall a. GHC.Internal.Enum.Bounded a => GHC.Internal.Enum.Bounded (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ instance forall a. (GHC.Internal.Enum.Enum a, GHC.Internal.Enum.Bounded a, GHC.Internal.Classes.Eq a) => GHC.Internal.Enum.Enum (GHC.Internal.Data.Ord.Down a) -- Defined in ‘GHC.Internal.Data.Ord’ ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -2,6 +2,7 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote +interfacePlugin: Data.List interfacePlugin: GHC.Internal.Base interfacePlugin: GHC.Internal.Data.NonEmpty interfacePlugin: GHC.Internal.Float ===================================== testsuite/tests/typecheck/should_fail/T12921.stderr ===================================== @@ -24,8 +24,6 @@ T12921.hs:4:16: error: [GHC-39999] Potentially matching instance: instance (a ~ Char) => GHC.Internal.Data.String.IsString [a] -- Defined in ‘GHC.Internal.Data.String’ - ...plus two instances involving out-of-scope types - (use -fprint-potential-instances to see them all) • In the annotation: {-# ANN module "HLint: ignore Reduce duplication" #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/537c4d0ea9b1fe5430c6b6765538f19… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/537c4d0ea9b1fe5430c6b6765538f19… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] 7 commits: Add optional `SrcLoc` to `StackAnnotation` class
by Wolfgang Jeltsch (＠jeltsch) 26 Feb '26

26 Feb '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC Commits: 4c40df3d by fendor at 2026-02-20T10:24:48-05:00 Add optional `SrcLoc` to `StackAnnotation` class `StackAnnotation`s give access to an optional `SrcLoc` field that user-added stack annotations can use to provide better backtraces in both error messages and when decoding the callstack. We update builtin stack annotations such as `StringAnnotation` and `ShowAnnotation` to also capture the `SrcLoc` of the current `CallStack` to improve backtraces by default (if stack annotations are used). This change is backwards compatible with GHC 9.14.1. - - - - - fd9aaa28 by Simon Hengel at 2026-02-20T10:25:33-05:00 docs: Fix grammar in explicit_namespaces.rst - - - - - 44354255 by Vo Minh Thu at 2026-02-20T18:53:06-05:00 GHCi: add a :version command. This looks like: ghci> :version GHCi, version 9.11.20240322 This closes #24576. Co-Author: Markus Läll <markus.l2ll(a)gmail.com> - - - - - eab3dbba by Andreas Klebinger at 2026-02-20T18:53:51-05:00 hadrian/build-cabal: Better respect and utilize -j * We now respect -j<n> for the cabal invocation to build hadrian rather than hardcoding -j * We use the --semaphore flag to ensure cabal/ghc build the hadrian executable in parallel using the -jsem mechanism. Saves 10-15s on fresh builds for me. Fixes #26876 - - - - - 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - 077edf85 by Wolfgang Jeltsch at 2026-02-26T14:13:09+02:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Move some `IsString` instance declarations into `base` * Move the `* -> *` `Heap.Closure` instances into `ghc-heap` * Move some code that needs `System.IO` to `template-haskell` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `GHCi.Helpers` implementation into `base` - - - - - 63 changed files: - compiler/GHC/Builtin/Names.hs - + docs/users_guide/10.0.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - hadrian/build-cabal - libraries/base/src/Control/Arrow.hs - libraries/base/src/Data/String.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/GHCi/Helpers.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO.hs - libraries/ghc-experimental/CHANGELOG.md - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - + libraries/ghc-experimental/tests/Makefile - + libraries/ghc-experimental/tests/all.T - + libraries/ghc-experimental/tests/backtraces/Makefile - + libraries/ghc-experimental/tests/backtraces/T26806a.hs - + libraries/ghc-experimental/tests/backtraces/T26806a.stderr - + libraries/ghc-experimental/tests/backtraces/T26806b.hs - + libraries/ghc-experimental/tests/backtraces/T26806b.stderr - + libraries/ghc-experimental/tests/backtraces/T26806c.hs - + libraries/ghc-experimental/tests/backtraces/T26806c.stderr - + libraries/ghc-experimental/tests/backtraces/all.T - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - − libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/typecheck/should_fail/T12921.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4c755528af30ab77fdf8a9bce5c19… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4c755528af30ab77fdf8a9bce5c19… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] Replace artificial "Lib TopDir" setting
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 9ad127f3 by Sven Tennie at 2026-02-26T11:12:42+00:00 Replace artificial "Lib TopDir" setting Hadrian can simply set "LibDir" instead. - - - - - 7 changed files: - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/bindist/Makefile - hadrian/src/Rules/Generate.hs Changes: ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ libTopDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ libTopDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, libTopDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,8 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags -libTopDir :: DynFlags -> FilePath -libTopDir dflags = fileSettings_libTopDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,6 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", libTopDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,7 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath - , fileSettings_libTopDir :: FilePath + , fileSettings_libDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,7 +148,7 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" - lib_top_dir <- getSetting "Lib TopDir" + lib_dir <- getSetting "LibDir" return $ Settings { sGhcNameVersion = GhcNameVersion @@ -161,7 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir - , fileSettings_libTopDir = lib_top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/bindist/Makefile ===================================== @@ -90,7 +90,7 @@ lib/settings : config.mk @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ - @echo ',("Lib TopDir", "$$topdir/")' >> $@ + @echo ',("LibDir", "$$topdir")' >> $@ @echo "]" >> $@ lib/targets/default.target : config.mk default.target ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -507,7 +507,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) - , ("Lib TopDir", pure lib_topDir) + , ("LibDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ad127f32ba679273ecd90477e68cb9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ad127f32ba679273ecd90477e68cb9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] Replace artificial "Lib TopDir" setting
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 72bc150e by Sven Tennie at 2026-02-26T10:53:04+00:00 Replace artificial "Lib TopDir" setting Hadrian can simply set "LibDir" instead. - - - - - 7 changed files: - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/bindist/Makefile - hadrian/src/Rules/Generate.hs Changes: ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ libTopDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ libTopDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, libTopDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,8 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags -libTopDir :: DynFlags -> FilePath -libTopDir dflags = fileSettings_libTopDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,6 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", libTopDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,7 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath - , fileSettings_libTopDir :: FilePath + , fileSettings_libDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,7 +148,7 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" - lib_top_dir <- getSetting "Lib TopDir" + lib_dir <- getSetting "LibDir" return $ Settings { sGhcNameVersion = GhcNameVersion @@ -161,7 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir - , fileSettings_libTopDir = lib_top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/bindist/Makefile ===================================== @@ -90,7 +90,7 @@ lib/settings : config.mk @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ - @echo ',("Lib TopDir", "$$topdir/")' >> $@ + @echo ',("LibDir", "$$topdir/lib")' >> $@ @echo "]" >> $@ lib/targets/default.target : config.mk default.target ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -507,7 +507,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) - , ("Lib TopDir", pure lib_topDir) + , ("LibDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72bc150e0213e310dbca2cb59d6ebd3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72bc150e0213e310dbca2cb59d6ebd3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix
by Marge Bot (＠marge-bot) 26 Feb '26

26 Feb '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 17839248 by Teo Camarasu at 2026-02-24T08:36:03-05:00 ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix This module contains the definition of MonadFix, since we want an instance for IO, that instance requires a lot of machinery and we want to avoid an orphan instance, this will naturally be quite high up in the dependency graph. So we want to avoid other modules depending on it as far as possible. On Windows, the IO manager depends on the RTSFlags type, which transtively depends on MonadFix. We refactor things to avoid this dependency, which would have caused a regression. Resolves #26875 Metric Decrease: T12227 - - - - - fa88d09a by Wolfgang Jeltsch at 2026-02-24T08:36:47-05:00 Refine the imports of `System.IO.OS` Commit 68bd08055594b8cbf6148a72d108786deb6c12a1 replaced the `GHC.Internal.Data.Bool` import by a `GHC.Internal.Base` import. However, while the `GHC.Internal.Data.Bool` import was conditional and partial, the `GHC.Internal.Base` import is unconditional and total. As a result, the import list is not tuned to import only the necessary bits anymore, and furthermore GHC emits a lot of warnings about redundant imports. This commit makes the `GHC.Internal.Base` import conditional and partial in the same way that the `GHC.Internal.Data.Bool` import was. - - - - - c951fef1 by Cheng Shao at 2026-02-25T20:58:28+00:00 wasm: add /assets endpoint to serve user-specified assets This patch adds an `/assets` endpoint to the wasm dyld http server, so that users can also fetch assets from the same host with sensible default MIME types, without needing a separate http server for assets that also introduces CORS headaches: - A `-fghci-browser-assets-dir` driver flag is added to specify the assets root directory (defaults to `$PWD`) - The dyld http server fetches `mime-db` on demand and uses it as source of truth for mime types. Closes #26951. - - - - - 5c0cb966 by Sylvain Henry at 2026-02-26T04:52:10-05:00 Fix -fcheck-prim-bounds for non constant args (#26958) Previously we were only checking bounds for constant (literal) arguments! I've refactored the code to simplify the generation of out-of-line Cmm code for the primop composed of some inline code + some call to an external Cmm function. - - - - - 32 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Runtime/Interpreter/Wasm.hs - compiler/GHC/StgToCmm/Prim.hs - docs/users_guide/wasm.rst - libraries/base/src/Control/Arrow.hs - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - + testsuite/tests/codeGen/should_fail/T26958.hs - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/T4175.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/mdo/should_fail/mdofail006.stderr - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff34fd17f6cf239ee7d5bfc577c896… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff34fd17f6cf239ee7d5bfc577c896… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] Replace artificial "Lib TopDir" setting
by Sven Tennie (＠supersven) 26 Feb '26

26 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 39b57017 by Sven Tennie at 2026-02-26T09:22:09+00:00 Replace artificial "Lib TopDir" setting Hadrian can simply set "LibDir" instead. - - - - - 7 changed files: - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/bindist/Makefile - hadrian/src/Rules/Generate.hs Changes: ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ libTopDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ libTopDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, libTopDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,8 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags -libTopDir :: DynFlags -> FilePath -libTopDir dflags = fileSettings_libTopDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", libTopDir dflags), + ("LibDir", libDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,7 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath - , fileSettings_libTopDir :: FilePath + , fileSettings_libDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,7 +148,7 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" - lib_top_dir <- getSetting "Lib TopDir" + lib_dir <- getSetting "LibDir" return $ Settings { sGhcNameVersion = GhcNameVersion @@ -161,7 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir - , fileSettings_libTopDir = lib_top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/bindist/Makefile ===================================== @@ -90,7 +90,7 @@ lib/settings : config.mk @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ - @echo ',("Lib TopDir", "$$topdir/")' >> $@ + @echo ',("LibDir", "$$topdir/lib")' >> $@ @echo "]" >> $@ lib/targets/default.target : config.mk default.target ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -507,7 +507,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) - , ("Lib TopDir", pure lib_topDir) + , ("LibDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39b57017d43a56309b0a79a343ab5c9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39b57017d43a56309b0a79a343ab5c9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghc-pkg-ospath] Long Path aware manifest
by Hannes Siebenhandl (＠fendor) 26 Feb '26

26 Feb '26

Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-ospath at Glasgow Haskell Compiler / GHC Commits: 5075477c by Fendor at 2026-02-26T10:12:48+01:00 Long Path aware manifest - - - - - 5 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Windows.hs - docs/users_guide/phases.rst Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1208,6 +1208,7 @@ defaultFlags settings = [ Opt_AutoLinkPackages, Opt_DiagnosticsShowCaret, Opt_EmbedManifest, + Opt_WinLongPathAware, Opt_FamAppCache, Opt_GenManifest, Opt_GhciHistory, ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -743,6 +743,7 @@ data GeneralFlag | Opt_PrintBindContents | Opt_GenManifest | Opt_EmbedManifest + | Opt_WinLongPathAware | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_IgnoreDotGhci ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2523,6 +2523,7 @@ fFlagsDeps = [ flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "win-aware-long-paths" Opt_WinLongPathAware, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -16,6 +16,7 @@ import System.Directory data ManifestOpts = ManifestOpts { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestLongPathAware :: !Bool , manifestTempdir :: TempDir , manifestWindresConfig :: WindresConfig , manifestObjectSuf :: String @@ -24,11 +25,45 @@ data ManifestOpts = ManifestOpts initManifestOpts :: DynFlags -> ManifestOpts initManifestOpts dflags = ManifestOpts { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestLongPathAware = gopt Opt_WinLongPathAware dflags , manifestTempdir = tmpDir dflags , manifestWindresConfig = configureWindres dflags , manifestObjectSuf = objectSuf dflags } +manifestContents :: Bool -> FilePath -> String +manifestContents longPathAware exe_filename = + concat $ + [ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n" + , " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n" + , " <assemblyIdentity version=\"1.0.0.0\"\n" + , " processorArchitecture=\"X86\"\n" + , " name=\"" ++ dropExtension exe_filename ++ "\"\n" + , " type=\"win32\"/>\n\n" + , " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n" + , " <security>\n" + , " <requestedPrivileges>\n" + , " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n" + , " </requestedPrivileges>\n" + , " </security>\n" + , " </trustInfo>\n" + ] + ++ + ( + if longPathAware + then + [ " <application xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n" + , " <windowsSettings xmlns:ws2=\"http://schemas.microsoft.com/SMI/2016/WindowsSettings\">\n" + , " <ws2:longPathAware>true</ws2:longPathAware>\n" + , " </windowsSettings>\n" + , " </application>\n" + ] + else + [] + ) ++ + [ " </assembly>\n" + ] + maybeCreateManifest :: Logger -> TmpFs @@ -37,21 +72,7 @@ maybeCreateManifest -> IO [FilePath] -- ^ extra objects to embed, maybe maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" - manifest = - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ - \ <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\ - \ <assemblyIdentity version=\"1.0.0.0\"\n\ - \ processorArchitecture=\"X86\"\n\ - \ name=\"" ++ dropExtension exe_filename ++ "\"\n\ - \ type=\"win32\"/>\n\n\ - \ <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\ - \ <security>\n\ - \ <requestedPrivileges>\n\ - \ <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\ - \ </requestedPrivileges>\n\ - \ </security>\n\ - \ </trustInfo>\n\ - \</assembly>\n" + manifest = manifestContents (manifestLongPathAware opts) exe_filename writeFile manifest_filename manifest ===================================== docs/users_guide/phases.rst ===================================== @@ -1430,6 +1430,16 @@ for example). See also :ghc-flag:`-pgmwindres ⟨cmd⟩` (:ref:`replacing-phases`) and :ghc-flag:`-optwindres ⟨option⟩` (:ref:`forcing-options-through`). +.. ghc-flag:: -fwin-aware-long-paths + :shortdesc: Do not embed the manifest in the executable (Windows only) + :type: dynamic + :category: linking + + .. index:: + single: windres + + The manifest file that GHC + .. ghc-flag:: -fno-shared-implib :shortdesc: Don't generate an import library for a DLL (Windows only) :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5075477ca5ac4f2a68fe80533314b54… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5075477ca5ac4f2a68fe80533314b54… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] Add Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: fab8136e by Brandon Chinn at 2026-02-25T19:25:04-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -1,4 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | -- @@ -13,6 +15,28 @@ module Data.RealFloat ( RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, ) where +import GHC.Internal.Data.Bool +import GHC.Internal.Data.Ord import GHC.Internal.Float +import GHC.Internal.Real + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fab8136ede6e3bb48e53aef94307fff… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fab8136ede6e3bb48e53aef94307fff… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] Replace artificial "Lib TopDir" setting
by Sven Tennie (＠supersven) 25 Feb '26

25 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 15aa6fc8 by Sven Tennie at 2026-02-25T23:35:02+00:00 Replace artificial "Lib TopDir" setting Hadrian can simply set "LibDir" instead. - - - - - 6 changed files: - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ libTopDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ libTopDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, libTopDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,8 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags -libTopDir :: DynFlags -> FilePath -libTopDir dflags = fileSettings_libTopDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", libTopDir dflags), + ("LibDir", libDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,7 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath - , fileSettings_libTopDir :: FilePath + , fileSettings_libDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,7 +148,7 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" - lib_top_dir <- getSetting "Lib TopDir" + lib_dir <- getSetting "LibDir" return $ Settings { sGhcNameVersion = GhcNameVersion @@ -161,7 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir - , fileSettings_libTopDir = lib_top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -507,7 +507,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) - , ("Lib TopDir", pure lib_topDir) + , ("LibDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15aa6fc8b55b5f33b67b09f9ee38d6b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15aa6fc8b55b5f33b67b09f9ee38d6b… You're receiving this email because of your account on gitlab.haskell.org.

1 0