April 2026 - ghc-commits

[Git][ghc/ghc][wip/supersven/libDir-setting] Add config setting for LibDir (#19174)
by Sven Tennie (＠supersven) 18 Apr '26

18 Apr '26

Sven Tennie pushed to branch wip/supersven/libDir-setting at Glasgow Haskell Compiler / GHC Commits: f0863167 by Sven Tennie at 2026-04-18T13:16:11+02:00 Add config setting for LibDir (#19174) Previously, the libDir was derived from topDir. This won't work for inplace stage2 cross-compilers where binaries and libraries are in different stage dirs (`_build/stage1/` for executables and `_build/stage2` for libraries). - - - - - 8 changed files: - + changelog.d/libdir-setting - 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/BinaryDist.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== changelog.d/libdir-setting ===================================== @@ -0,0 +1,15 @@ +section: packaging +synopsis: Added a new configuration setting for ``LibDir`` to support inplace + stage2 cross-compilers where binaries and libraries are in different stage + directories. +issues: #19174 +mrs: !15716 + +description: { + Previously, the `libDir` was always derived from `topDir`, which won't work + for inplace stage2 cross-compilers where executables are in `_build/stage1/` + and libraries are in `_build/stage2/`. Now, `LibDir` can be set, but is by + default derived from `topDir`. This facilitates the mentioned behaviour + while leaving the binary distribution code untouched. This is a refactoring + step that does not change actual behaviour. +} ===================================== 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, @@ -1508,6 +1508,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 ===================================== @@ -3548,9 +3548,9 @@ compilerInfo dflags ("Project name", cProjectName) -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the - -- key) + -- key). We filter out LibDir from rawSettings to avoid duplication. : map (fmap expandDirectories) - (rawSettings dflags) + (filter ((/= "LibDir") . fst) (rawSettings dflags)) ++ [("C compiler command", queryCmd $ ccProgram . tgtCCompiler), ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler), @@ -3651,7 +3651,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", topDir 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,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 ===================================== @@ -28,6 +28,7 @@ import GHC.Toolchain.Program import GHC.Toolchain import GHC.Data.Maybe import Data.Bifunctor (Bifunctor(second)) +import Data.Either (fromRight) data SettingsError = SettingsError_MissingData String @@ -148,6 +149,13 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" + -- LibDir is optional. If not set, derive it from topDir. This allows + -- bindists to work without explicitly setting LibDir, but gives us the + -- option to override it for inplace test compilers (the "stage2 + -- cross-compiler" scenario). + let lib_dir = fromRight top_dir $ + getRawFilePathSetting top_dir settingsFile mySettings "LibDir" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -159,6 +167,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/src/Rules/BinaryDist.hs ===================================== @@ -14,6 +14,7 @@ import qualified System.Directory.Extra as IO import Data.Either import qualified Data.Set as Set import Oracles.Flavour +import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -218,6 +219,16 @@ bindistRules = do IO.createFileLink version_prog versioned_runhaskell_path copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir + + -- Regenerate settings file without LibDir for bindist. LibDir should + -- be derived from topdir at runtime such that the GHC binary is + -- relocatable. + let bindistSettings = bindistFilesDir -/- "lib" -/- "settings" + bindistContext = vanillaContext Stage1 compiler + bindistSettingsContent <- interpretInContext bindistContext $ + generateSettings bindistSettings False + writeFile' bindistSettings bindistSettingsContent + copyDirectory (rtsIncludeDir) bindistFilesDir when windowsHost $ createGhcii (bindistFilesDir -/- "bin") ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -1,7 +1,7 @@ module Rules.Generate ( isGeneratedCmmFile, compilerDependencies, generatePackageCode, generateRules, copyRules, generatedDependencies, - templateRules + templateRules, generateSettings ) where import Development.Shake.FilePath @@ -25,6 +25,7 @@ import Utilities import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) import GHC.Platform.ArchOS import Settings.Program (ghcWithInterpreter) +import Hadrian.Oracles.Path -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () @@ -257,7 +258,7 @@ generateRules = do forM_ allStages $ \stage -> do let prefix = root -/- stageString stage -/- "lib" go gen file = generate file (semiEmptyTarget (succStage stage)) gen - (prefix -/- "settings") %> \out -> go (generateSettings out) out + (prefix -/- "settings") %> \out -> go (generateSettings out True) out (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out where @@ -459,8 +460,10 @@ ghcWrapper stage = do return $ unwords $ map show $ [ ghcPath ] ++ [ "$@" ] -generateSettings :: FilePath -> Expr String -generateSettings settingsFile = do +-- | Generate settings file, optionally including LibDir. +-- For bindists, we omit LibDir so it defaults to topdir at runtime. +generateSettings :: FilePath -> Bool -> Expr String +generateSettings settingsFile includeLibDir = do ctx <- getContext stage <- getStage @@ -481,14 +484,26 @@ generateSettings settingsFile = do Stage3 -> pkgUnitId Stage2 base let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path + make_absolute rel_path = do + abs_path <- liftIO (makeAbsolute rel_path) + fixAbsolutePathOnWindows abs_path + + -- E.g. the Stage2 compiler lives in _build/stage1 + -- So, we need to decrement the stage to get the correct directory + stage_dir_stage = predStage stage + + rel_lib_topDir :: FilePath <- expr $ stageLibPath stage_dir_stage + lib_topDir :: FilePath <- expr $ make_absolute rel_lib_topDir settings <- traverse sequence $ - [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) - , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) - , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) - , ("Relative Global Package DB", pure rel_pkg_db) - , ("base unit-id", pure base_unit_id) - ] + [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) + , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) + , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) + , ("Relative Global Package DB", pure rel_pkg_db) + , ("base unit-id", pure base_unit_id) + ] + ++ ([("LibDir", pure lib_topDir) | includeLibDir]) + let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of [] -> "[]" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0863167051675da3f92867ff27004e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0863167051675da3f92867ff27004e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 59 commits: Bump directory submodule to 1.3.11.0 (unreleased)
by Simon Peyton Jones (＠simonpj) 18 Apr '26

18 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: b135a87d by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump directory submodule to 1.3.11.0 (unreleased) - - - - - 3a291d07 by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump file-io submodule to 0.2.0 - - - - - e0ab606d by Zubin Duggal at 2026-04-10T18:40:20+05:30 Release notes for GHC 10.0 - - - - - e08b9b34 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump ghc-prim version to 0.14.0 - - - - - a92aac6e by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump template-haskell to 2.25.0.0; update submodule exceptions for TH 2.25 - - - - - f254d9e8 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump GHC version to 10.0 - - - - - 6ce0368a by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump base to 4.23.0.0; update submodules for base 4.24 upper bound - - - - - 702fb8a5 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump GHC version to 10.1; update submodules template-haskell-lift and template-haskell-quasiquoter for ghc-internal 10.200 - - - - - 75df1ca4 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). (cherry picked from commit 989c07249978f418dfde1353abfad453f024d61a) - - - - - 585d7450 by Luite Stegeman at 2026-04-11T02:17:13-04:00 tc: discard warnings in tcUserStmt Plan C We typecheck let_stmt twice, but we don't want the warnings twice! see #26233 - - - - - 2df604e9 by Sylvain Henry at 2026-04-11T02:19:30-04:00 Introduce TargetInt to represent target's Int (#15973) GHC was using host 'Int' in several places to represent values that live in the target machine's 'Int' type. This is silently wrong when cross-compiling from a 32-bit host to a 64-bit target: the host Int is 32 bits while the target Int is 64 bits. See Note [TargetInt] in GHC.Platform. Also used the opportunity to make DynTag = Word8. Fixes #15973 Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - d419e972 by Luite Stegeman at 2026-04-13T15:16:04-04:00 Suppress desugaring warnings in the pattern match checker Avoid duplicating warnings from the actual desugaring pass. fixes #25996 - - - - - c5b80dd0 by Phil de Joux at 2026-04-13T15:16:51-04:00 Typo ~/ghc/arch-os-version/environments - - - - - 71462fff by Luite Stegeman at 2026-04-13T15:17:38-04:00 add changelog entry for #26233 - - - - - d1ddfd4b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add test for #25636 The existing test behaviour of "T23146_liftedeq" changed because the simplifier now does a bit more inlining. We can restore the previous bad behavior by using an OPAQUE pragma. This test doubles as a test for #25636 when run in ghci, so we add it as such. - - - - - b9df40ee by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: protoBCOName is always a Name Simplifies the code by removing the unnecessary type argument to ProtoBCO which was always 'Name' - - - - - 5c2a179e by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Allocate static constructors for bytecode This commit adds support for static constructors when compiling and linking ByteCode objects. Top-level StgRhsCon get lowered to ProtoStaticCons rather than to ProtoBCOs. A ProtoStaticCon gets allocated directly as a data con application on the heap (using the new primop newConApp#). Previously, we would allocate a ProtoBCO which, when evaluated, would PACK and return the constructor. A few more details are given in Note [Static constructors in Bytecode]. Secondly, this commit also fixes issue #25636 which was caused by linking *unlifted* constructors in BCO instructions as - (1) a thunk indexing the array of BCOs in a module - (2) which evaluated to a BCO which still had to be evaluated to return the unlifted constructor proper. The (2) issue has been resolved by allocating the static constructors directly. The (1) issue can be resolved by ensuring that we allocate all unlifted top-level constructors eagerly, and leave the knot-tying for the lifted BCOs and top-level constructors only. The top-level unlifted constructors are never mutually recursive, so we can allocate them all in one go as long as we do it in topological order. Lifted fields of unlifted constructors can still be filled by the knot-tied lifted variables since in those fields it is fine to keep those thunks. See Note [Tying the knot in createBCOs] for more details. Fixes #25636 ------------------------- Metric Decrease: LinkableUsage01 ------------------------- - - - - - cde47053 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Revert "StgToByteCode: Assert that PUSH_G'd values are lifted" This reverts commit ec26c54d818e0cd328276196930313f66b780905. Ever since f7a22c0f4e9ae0dc767115d4c53fddbd8372b777, we now do support and will link top-level unlifted constructors into evaluated and properly tagged values which we can reference with PUSH_G. This assertion is no longer true and triggered a failure in T25636 - - - - - c7a7e5b8 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: Tag more remote Ptrs as RemotePtr Pure refactor which improves the API of - GHC.ByteCode.Linker - GHC.Runtime.Interpreter - GHC.Runtime.Interpreter.Types.SymbolCache by using `RemotePtr` for more functions which used to return `Ptr`s that could potentially be in a foreign process. E.g. `lookupIE`, `lookupStaticPtr`, etc... - - - - - fc59494c by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add float# and subword tests for #25636 These tests cover that static constructors in bytecode work correctly for Float# and subword values (Word8#, Word16#) - - - - - 477f521b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 test: Validate topoSort logic in createBCOs This test validates that the topological sorting and ordering of the unlifted constructors and lifted constructors in `createBCOs` is correct. See `Note [Tying the knot in createBCOs]` for why tying the knot for the created BCOs is slightly difficult and why the topological sorting is necessary. This test fails when `let topoSortedObjs = topSortObjs objs` is substituted by `let topoSortedObjs = zip [0..] objs`, thus witnessing the toposort logic is correct and necessary. The test calls the ghci `createBCOs` directly because it is currently impossible to construct in Source Haskell a situation where a top-level static unlifted constructor depends on another (we don't have top-level unlifted constructors except for nullary constructors like `Leaf :: (UTree :: UnliftedType)`). This is another test for fix for #25636 - - - - - 2d9c30be by Simon Jakobi at 2026-04-14T18:42:00-04:00 Improve tests for `elem` ...in order to simplify the work on #27096. * Improve T17752 by including the Core output in golden files, checking both -O1 and -O2. * Add tests for fusion and no-fusion cases. Fixes #27101. - - - - - 2dadf3b0 by sheaf at 2026-04-16T13:28:39-04:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. The most important change is that we revert the logic (added in 85b0aae2) that allowed ticks to be placed around coercions, which caused serious issues (e.g. #27121). It was just a mistake, as it doesn't make sense to put a tick around a coercion. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - a0d6f1f4 by Simon Jakobi at 2026-04-16T13:29:28-04:00 Add regression test for #9074 Closes #9074. - - - - - d178ee89 by Sylvain Henry at 2026-04-16T13:30:25-04:00 Add changelog for #15973 - - - - - e8a196c6 by sheaf at 2026-04-16T13:31:19-04:00 Deal with 'noSpec' in 'coreExprToPmLit' This commit makes two separate changes relating to 'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit': 1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical, which led to the introduction of 'nospec' wrappers in the generated Core. This reverts that accident by declaring deferred errors as being canonical, avoiding spurious 'nospec' wrapping. 2. Look through magic identity-like Ids such as 'nospec', 'inline' and 'lazy' in 'coreExprAsPmLit', just like Core Prep does. There might genuinely be incoherent evidence, but that shouldn't obstruct the pattern match checker. See test T27124a. Fixes #25926 #27124 ------------------------- Metric Decrease: T3294 ------------------------- - - - - - 8cb99552 by Sylvain Henry at 2026-04-16T19:22:43-04:00 hadrian: warn when package index is missing (#16484) Since cabal-install 3.0 we can query the path of remote-repo-cache and check if hackage package index is present. Fixes #16484 - - - - - d6ce7477 by Richard Eisenberg at 2026-04-16T19:23:25-04:00 Teach hadrian to --skip-test. Fixes #27188. This adds the --skip-test flag to `hadrian build`, as documented in the patch. - - - - - 7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00 Kill off the substitution in Lint Now that we have invariant (NoTypeShadowing) we no longer need Lint to carry an ambient substitution. This makes it simpler and faster. A really worthwhile refactor. There are some knock-on effects * Linting join points after worker/wrapper. See Note [Join points and beta redexes] * Running a type substitution after the desugarer. See Note [Substituting type-lets] in the new module GHC.Core.SubstTypeLets Implements #27078 Most perf tests don't use Lint so we won't see a perf incresae. But T1969, which uses -O0 and Lint, gets 1.3% worse because it has to run the SubstTypeLets pass which is a somewhat expensive no-op Overall though compile-time allocations are down 0.1%. Metric Increase: T1969 - - - - - 86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00 testsuite: inline elemCoreTest Some weird (probably python scoping) rule caused elemCoreTest, a regex being out of scope on ubuntu, presumably because of a newer python version. This patch just inlines the regex, which fixes the issue. Fixes #27193 - - - - - 58c731a6 by Simon Peyton Jones at 2026-04-18T10:42:40+01:00 Major patch to re-engineer known-key names This big patch implements the New Plan for known-key names, described in #27013. Read the big Note [Overview of known-key names] in GHC.Types.Name Moving more into the new mechanism [skip ci] DOES NOT COMPILE, just work in progress More more stuff into the new mechanism fromString is known-key Onward Onward more Add imports in ghc-internal for known-key names [skip ci] Add known-key imports for ghc-internal [skip ci] More [skip ci] More Particularly using a proxy for `toList` from the IsList class. Add Real to known-key names [skip ci] More....[skip ci] Lots of Names have moved to new mechanism BuiltinRules had KnownKeyNameKeys Start on updating RdrName but incomplete, hence skip ci Onward [skip ci] Onward Added GHC.Tc.Deriv.RdrNames as a new module Onward Added -fexclude-known-key-define Wibble [skip ci] More .. forging ahead with KnownOccs Onward [skip ci] including renaming GHC.Builtin.Utils to GHC.Builtin More and more I think this might actually bootstrap! - - - - - 37bef526 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibbles [skip ci] - - - - - a472e42c by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibbles - - - - - da39e0a4 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibbles - - - - - e4477f27 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibble check-exact - - - - - a8ca40b9 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibble - - - - - 36f0aed8 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Update KnownKeyNames - - - - - 27e2f63f by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 More - - - - - 3f2b746c by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Wibble - - - - - 6f877054 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 More fixes - - - - - c231d71a by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 More and more - - - - - 758b63f5 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 Renaming GHC.Builtin.Names --> GHC.Builtin.KnownKeys GHC.Builtin.RdrNames --> GHC.Builtin.KnownOccs - - - - - 60c23cc6 by Simon Peyton Jones at 2026-04-18T10:42:45+01:00 More - - - - - 537707e3 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 A huge pile of import wibbles .. to satisfy known-occ names for generated Typeable bindings - - - - - bd993eff by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Onward - - - - - e0f750f6 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 More [skip ci] - - - - - 80245562 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Don't generate $trModule bindings if no type decls! - - - - - 42bfe5df by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Much progress - - - - - bb27de3d by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Add Builtin/Modules.hs - - - - - ba8fd0fc by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 More and more - - - - - ffae8c8a by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Final wibbles This actually bootstraps - - - - - a7eb9812 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Wibbles - - - - - 3b435262 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Wibbles - - - - - 908a3122 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Onwards [skip ci] - - - - - 10e17167 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Onward This version bootstraps. And the documentation in GHC.Builtin is much better - - - - - 03cb9119 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Knot-tying nonsense [skip ci] I ended up extending KKKNS_InScope - - - - - 72bb01d3 by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Onward! Some renaming, immprove docs More more things out of known-key into known-occ - - - - - 1c30f7bc by Simon Peyton Jones at 2026-04-18T10:42:46+01:00 Wibbles - - - - - 673 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/T15973 - + changelog.d/T25636 - + changelog.d/T27121.md - + changelog.d/T27124.md - + changelog.d/changelog-entries - + changelog.d/config - + changelog.d/fix-duplicate-pmc-warnings - + changelog.d/fix-ghci-duplicate-warnings-26233 - + changelog.d/ghc-pkg-long-path-support - + changelog.d/hadrian-warn-missing-package-index-16484 - + changelog.d/skip-test - + compiler/GHC/Builtin.hs - compiler/GHC/Builtin/Names.hs → compiler/GHC/Builtin/KnownKeys.hs - + compiler/GHC/Builtin/KnownOccs.hs - + compiler/GHC/Builtin/Modules.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - compiler/GHC/Builtin/Names/TH.hs → compiler/GHC/Builtin/TH.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Literals.hs - compiler/GHC/Builtin/Types/Prim.hs - − compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Liveness.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/Lint/SubstTypeLets.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/KnotVars.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Env.hs - − compiler/GHC/Iface/Env.hs-boot - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Platform.hs - compiler/GHC/Platform/Tag.hs - compiler/GHC/Plugins.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Prof.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/ghc.cabal.in - configure.ac - − docs/users_guide/10.0.1-notes.rst - + docs/users_guide/10.2.1-notes.rst - − docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/exts/rebindable_syntax.rst - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - docs/users_guide/packages.rst - docs/users_guide/release-notes.rst - docs/users_guide/separate_compilation.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - ghc/ghc-bin.cabal.in - hadrian/build-cabal - hadrian/build-cabal.bat - hadrian/doc/make.md - hadrian/doc/testsuite.md - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Default.hs - libraries/array - libraries/base/base.cabal.in - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Concurrent/Chan.hs - libraries/base/src/Control/Concurrent/QSem.hs - libraries/base/src/Control/Concurrent/QSemN.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bifoldable.hs - libraries/base/src/Data/Bifoldable1.hs - libraries/base/src/Data/Bifunctor.hs - libraries/base/src/Data/Bitraversable.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Complex.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Contravariant.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/Data/Semigroup.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Fingerprint.hs - + libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/CPUTime/Posix/ClockGetTime.hsc - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/base/src/System/Info.hs - libraries/base/src/System/Timeout.hs - libraries/base/src/Text/Printf.hs - + libraries/base/tests/perf/ElemFusionUnknownList.hs - + libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - + libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - + libraries/base/tests/perf/ElemNoFusion.hs - + libraries/base/tests/perf/ElemNoFusion_O1.stderr - + libraries/base/tests/perf/ElemNoFusion_O2.stderr - − libraries/base/tests/perf/Makefile - libraries/base/tests/perf/T17752.hs - − libraries/base/tests/perf/T17752.stdout - + libraries/base/tests/perf/T17752_O1.stderr - + libraries/base/tests/perf/T17752_O2.stderr - libraries/base/tests/perf/all.T - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/file-io - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-heap/tests/tso_and_stack_closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/ArrayArray.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bits.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Classes.hs - libraries/ghc-internal/src/GHC/Internal/Clock.hsc - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Bound.hs - libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/ConsoleHandler.hsc - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Concurrent/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/IO/Class.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Data/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Dynamic.hs - libraries/ghc-internal/src/GHC/Internal/Data/Either.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Function.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Data/IORef.hs - libraries/ghc-internal/src/GHC/Internal/Data/List.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Proxy.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Coercion.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Equality.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Data/Void.hs - libraries/ghc-internal/src/GHC/Internal/Debug/Trace.hs - libraries/ghc-internal/src/GHC/Internal/Desugar.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs - libraries/ghc-internal/src/GHC/Internal/Enum.hs-boot - libraries/ghc-internal/src/GHC/Internal/Environment.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - libraries/ghc-internal/src/GHC/Internal/Event/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Event/Array.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/IntTable.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Event/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/PSQ.hs - libraries/ghc-internal/src/GHC/Internal/Event/Poll.hsc - libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimeOut.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/ExecutionStack.hs - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint/Type.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Float/ConversionUtils.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/String/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/Types.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/ForeignPtr/Imp.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Alloc.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Array.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Error.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Pool.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Marshal/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/Storable.hs - libraries/ghc-internal/src/GHC/Internal/ForeignPtr.hs - libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/GHCi.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Buffer.hs - libraries/ghc-internal/src/GHC/Internal/IO/BufferedIO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Device.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Iconv.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Latin1.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF16.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF32.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/UTF8.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Common.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Flock.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/LinuxOFD.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/NoOp.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Lock/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs - libraries/ghc-internal/src/GHC/Internal/IO/SubSystem.hs - libraries/ghc-internal/src/GHC/Internal/IO/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/IOArray.hs - libraries/ghc-internal/src/GHC/Internal/IORef.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Int.hs - libraries/ghc-internal/src/GHC/Internal/IsList.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/Lexeme.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/MVar.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Magic/Dict.hs - libraries/ghc-internal/src/GHC/Internal/Maybe.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs-boot - libraries/ghc-internal/src/GHC/Internal/Numeric.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - libraries/ghc-internal/src/GHC/Internal/Pack.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs - libraries/ghc-internal/src/GHC/Internal/Prim/PtrEq.hs - libraries/ghc-internal/src/GHC/Internal/Profiling.hs - libraries/ghc-internal/src/GHC/Internal/Ptr.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/RTS/Flags/Test.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot - libraries/ghc-internal/src/GHC/Internal/Records.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/ghc-internal/src/GHC/Internal/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Show.hs - libraries/ghc-internal/src/GHC/Internal/Stable.hs - libraries/ghc-internal/src/GHC/Internal/StableName.hs - libraries/ghc-internal/src/GHC/Internal/Stack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr.hs - libraries/ghc-internal/src/GHC/Internal/StaticPtr/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Stats.hsc - libraries/ghc-internal/src/GHC/Internal/Storable.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - libraries/ghc-internal/src/GHC/Internal/System/Mem.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Types.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadP.hs - libraries/ghc-internal/src/GHC/Internal/Text/ParserCombinators/ReadPrec.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read.hs - libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs - libraries/ghc-internal/src/GHC/Internal/TopHandler.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection/Unsafe.hs - libraries/ghc-internal/src/GHC/Internal/TypeError.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits/Internal.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/DerivedCoreProperties.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/GeneralCategory.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs - libraries/ghc-internal/src/GHC/Internal/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/Word.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell-lift - libraries/template-haskell-quasiquoter - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/unix - m4/fp_setup_project_version.m4 - m4/fptools_ghc_version.m4 - rts/Interpreter.c - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/include/Rts.h - rts/include/rts/storage/ClosureMacros.h - rts/include/stg/MiscClosures.h - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - testsuite/tests/codeGen/should_run/T23146/T23146_liftedeq.hs - + testsuite/tests/codeGen/should_run/T23146/T25636.script - + testsuite/tests/codeGen/should_run/T23146/T25636.stdout - testsuite/tests/codeGen/should_run/T23146/all.T - + testsuite/tests/codeGen/should_run/T25636a/T25636a.script - + testsuite/tests/codeGen/should_run/T25636a/T25636a.stdout - + testsuite/tests/codeGen/should_run/T25636a/all.T - + testsuite/tests/codeGen/should_run/T25636b/T25636b.script - + testsuite/tests/codeGen/should_run/T25636b/T25636b.stdout - + testsuite/tests/codeGen/should_run/T25636b/all.T - + testsuite/tests/codeGen/should_run/T25636c/T25636c.script - + testsuite/tests/codeGen/should_run/T25636c/T25636c.stdout - + testsuite/tests/codeGen/should_run/T25636c/all.T - + testsuite/tests/codeGen/should_run/T25636d/T25636d.script - + testsuite/tests/codeGen/should_run/T25636d/T25636d.stdout - + testsuite/tests/codeGen/should_run/T25636d/all.T - + testsuite/tests/codeGen/should_run/T25636e/T25636e.script - + testsuite/tests/codeGen/should_run/T25636e/T25636e.stdout - + testsuite/tests/codeGen/should_run/T25636e/all.T - testsuite/tests/corelint/LintEtaExpand.stderr - testsuite/tests/corelint/T21115b.stderr - + testsuite/tests/deSugar/should_compile/T25996.hs - + testsuite/tests/deSugar/should_compile/T25996.stderr - testsuite/tests/deSugar/should_compile/all.T - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghci.debugger/scripts/print034.stdout - + testsuite/tests/ghci/T9074/Makefile - + testsuite/tests/ghci/T9074/T9074.hs - + testsuite/tests/ghci/T9074/T9074.stdout - + testsuite/tests/ghci/T9074/T9074a.c - + testsuite/tests/ghci/T9074/T9074b.c - + testsuite/tests/ghci/T9074/all.T - + testsuite/tests/ghci/scripts/T26233.script - + testsuite/tests/ghci/scripts/T26233.stderr - + testsuite/tests/ghci/scripts/T26233.stdout - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/should_run/T25636f.hs - + testsuite/tests/ghci/should_run/T25636f.stdout - testsuite/tests/ghci/should_run/all.T - 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/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + testsuite/tests/overloadedstrings/should_fail/T25926.hs - + testsuite/tests/overloadedstrings/should_fail/T25926.stderr - + testsuite/tests/overloadedstrings/should_fail/T27124.hs - + testsuite/tests/overloadedstrings/should_fail/T27124.stderr - + testsuite/tests/overloadedstrings/should_fail/all.T - + testsuite/tests/overloadedstrings/should_run/T27124a.hs - testsuite/tests/overloadedstrings/should_run/all.T - testsuite/tests/parser/should_fail/T16270h.hs - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/T26568.stderr - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal - utils/check-exact/Utils.hs - utils/deriveConstants/Main.hs - utils/genprimopcode/Main.hs - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6876e3140d039f5a1b591bf9faf404… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6876e3140d039f5a1b591bf9faf404… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/libDir-setting] Add config setting for LibDir (#19174)
by Sven Tennie (＠supersven) 18 Apr '26

18 Apr '26

Sven Tennie pushed to branch wip/supersven/libDir-setting at Glasgow Haskell Compiler / GHC Commits: a3ebb2d7 by Sven Tennie at 2026-04-18T13:04:49+02:00 Add config setting for LibDir (#19174) Previously, the libDir was derived from topDir. This won't work for inplace stage2 cross-compilers where binaries and libraries are in different stage dirs (`_build/stage1/` for executables and `_build/stage2` for libraries). - - - - - 8 changed files: - + changelog.d/libdir-setting - 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/BinaryDist.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== changelog.d/libdir-setting ===================================== @@ -0,0 +1,15 @@ +section: packaging +synopsis: Added a new configuration setting for ``LibDir`` to support inplace + stage2 cross-compilers where binaries and libraries are in different stage + directories. +issues: #19174 +mrs: !15716 + +description: { + Previously, the `libDir` was always derived from `topDir`, which won't work + for inplace stage2 cross-compilers where executables are in `_build/stage1/` + and libraries are in `_build/stage2/`. Now, `LibDir` can be set, but is by + default derived from `topDir`. This facilitates the mentioned behaviour + while leaving the binary distribution code untouched. This is a refactoring + step that does not change actual behaviour. +} ===================================== 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, @@ -1508,6 +1508,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 ===================================== @@ -3548,9 +3548,9 @@ compilerInfo dflags ("Project name", cProjectName) -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the - -- key) + -- key). We filter out LibDir from rawSettings to avoid duplication. : map (fmap expandDirectories) - (rawSettings dflags) + (filter ((/= "LibDir") . fst) (rawSettings dflags)) ++ [("C compiler command", queryCmd $ ccProgram . tgtCCompiler), ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler), @@ -3651,7 +3651,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", topDir 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,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 ===================================== @@ -28,6 +28,7 @@ import GHC.Toolchain.Program import GHC.Toolchain import GHC.Data.Maybe import Data.Bifunctor (Bifunctor(second)) +import Data.Either (fromRight) data SettingsError = SettingsError_MissingData String @@ -148,6 +149,13 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" + -- LibDir is optional. If not set, derive it from topDir. This allows + -- bindists to work without explicitly setting LibDir, but gives us the + -- option to override it for inplace test compilers (the "stage2 + -- cross-compiler" scenario). + let lib_dir = fromRight top_dir $ + getRawFilePathSetting top_dir settingsFile mySettings "LibDir" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -159,6 +167,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/src/Rules/BinaryDist.hs ===================================== @@ -14,6 +14,7 @@ import qualified System.Directory.Extra as IO import Data.Either import qualified Data.Set as Set import Oracles.Flavour +import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -218,6 +219,16 @@ bindistRules = do IO.createFileLink version_prog versioned_runhaskell_path copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir + + -- Regenerate settings file without LibDir for bindist. LibDir should + -- be derived from topdir at runtime such that the GHC binary is + -- relocatable. + let bindistSettings = bindistFilesDir -/- "lib" -/- "settings" + bindistContext = vanillaContext Stage1 compiler + bindistSettingsContent <- interpretInContext bindistContext $ + generateSettings bindistSettings False + writeFileLines bindistSettings [bindistSettingsContent] + copyDirectory (rtsIncludeDir) bindistFilesDir when windowsHost $ createGhcii (bindistFilesDir -/- "bin") ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -1,7 +1,7 @@ module Rules.Generate ( isGeneratedCmmFile, compilerDependencies, generatePackageCode, generateRules, copyRules, generatedDependencies, - templateRules + templateRules, generateSettings ) where import Development.Shake.FilePath @@ -25,6 +25,7 @@ import Utilities import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) import GHC.Platform.ArchOS import Settings.Program (ghcWithInterpreter) +import Hadrian.Oracles.Path -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () @@ -257,7 +258,7 @@ generateRules = do forM_ allStages $ \stage -> do let prefix = root -/- stageString stage -/- "lib" go gen file = generate file (semiEmptyTarget (succStage stage)) gen - (prefix -/- "settings") %> \out -> go (generateSettings out) out + (prefix -/- "settings") %> \out -> go (generateSettings out True) out (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out where @@ -459,8 +460,10 @@ ghcWrapper stage = do return $ unwords $ map show $ [ ghcPath ] ++ [ "$@" ] -generateSettings :: FilePath -> Expr String -generateSettings settingsFile = do +-- | Generate settings file, optionally including LibDir. +-- For bindists, we omit LibDir so it defaults to topdir at runtime. +generateSettings :: FilePath -> Bool -> Expr String +generateSettings settingsFile includeLibDir = do ctx <- getContext stage <- getStage @@ -481,14 +484,26 @@ generateSettings settingsFile = do Stage3 -> pkgUnitId Stage2 base let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path + make_absolute rel_path = do + abs_path <- liftIO (makeAbsolute rel_path) + fixAbsolutePathOnWindows abs_path + + -- E.g. the Stage2 compiler lives in _build/stage1 + -- So, we need to decrement the stage to get the correct directory + stage_dir_stage = predStage stage + + rel_lib_topDir :: FilePath <- expr $ stageLibPath stage_dir_stage + lib_topDir :: FilePath <- expr $ make_absolute rel_lib_topDir settings <- traverse sequence $ - [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) - , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) - , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) - , ("Relative Global Package DB", pure rel_pkg_db) - , ("base unit-id", pure base_unit_id) - ] + [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) + , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) + , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) + , ("Relative Global Package DB", pure rel_pkg_db) + , ("base unit-id", pure base_unit_id) + ] + ++ ([("LibDir", pure lib_topDir) | includeLibDir]) + let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of [] -> "[]" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ebb2d7ce28509a11ddd24ef584bd3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ebb2d7ce28509a11ddd24ef584bd3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] testsuite: inline elemCoreTest
by Marge Bot (＠marge-bot) 18 Apr '26

18 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00 testsuite: inline elemCoreTest Some weird (probably python scoping) rule caused elemCoreTest, a regex being out of scope on ubuntu, presumably because of a newer python version. This patch just inlines the regex, which fixes the issue. Fixes #27193 - - - - - 1 changed file: - libraries/base/tests/perf/all.T Changes: ===================================== libraries/base/tests/perf/all.T ===================================== @@ -5,15 +5,13 @@ setTestOpts(js_skip) # Check optimization of `elem` #-------------------------------------- -elemCoreFilter = "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'" - def elemCoreTest(test_name, module_name, opt): test(test_name, [only_ways(['normal']), extra_files([module_name + '.hs'])], multimod_compile_filter, [module_name, f'{opt} -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds', - elemCoreFilter]) + "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'"]) elemCoreTest('T17752_O1', 'T17752', '-O1') elemCoreTest('T17752_O2', 'T17752', '-O2') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86ca6c2cf93147ed67a39be1112911d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86ca6c2cf93147ed67a39be1112911d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Kill off the substitution in Lint
by Marge Bot (＠marge-bot) 18 Apr '26

18 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00 Kill off the substitution in Lint Now that we have invariant (NoTypeShadowing) we no longer need Lint to carry an ambient substitution. This makes it simpler and faster. A really worthwhile refactor. There are some knock-on effects * Linting join points after worker/wrapper. See Note [Join points and beta redexes] * Running a type substitution after the desugarer. See Note [Substituting type-lets] in the new module GHC.Core.SubstTypeLets Implements #27078 Most perf tests don't use Lint so we won't see a perf incresae. But T1969, which uses -O0 and Lint, gets 1.3% worse because it has to run the SubstTypeLets pass which is a somewhat expensive no-op Overall though compile-time allocations are down 0.1%. Metric Increase: T1969 - - - - - 9 changed files: - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/Lint/SubstTypeLets.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/ghc.cabal.in - testsuite/tests/corelint/LintEtaExpand.stderr - testsuite/tests/corelint/T21115b.stderr Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -18,7 +18,7 @@ module GHC.Core.Lint ( LintConfig (..), WarnsAndErrs, - lintCoreBindings', lintUnfolding, + lintCoreBindings, lintUnfolding, lintPassResult, lintExpr, lintAnnots, lintAxioms, @@ -46,6 +46,7 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) import GHC.Core.DataCon +import GHC.Core.Lint.SubstTypeLets( substTypeLets ) import GHC.Core.Ppr import GHC.Core.Coercion import GHC.Core.Type as Type @@ -178,65 +179,7 @@ Note [Linting function types] All saturated applications of funTyCon are represented with the FunTy constructor. See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim - We check this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Bool in - let x::a = True in <body> -That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". -One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] -in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). - -* Hence when linting <body> we need to remember that a=Int, else we - might reject a correct program. So we carry a type substitution (in - this example [a -> Bool]) and apply this substitution before - comparing types. In effect, in Lint, type equality is always - equality-modulo-le-subst. This is in the le_subst field of - LintEnv. But nota bene: - - (SI1) The le_subst substitution is applied to types and coercions only - - (SI2) The result of that substitution is used only to check for type - equality, to check well-typed-ness, /but is then discarded/. - The result of substitution does not outlive the CoreLint pass. - - (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. - -* The function - lintInTy :: Type -> LintM (Type, Kind) - returns a substituted type. - -* When we encounter a binder (like x::a) we must apply the substitution - to the type of the binding variable. lintBinders does this. - -* Clearly we need to clone tyvar binders as we go. - -* But take care (#17590)! We must also clone CoVar binders: - let a = TYPE (ty |> cv) - in \cv -> blah - blindly substituting for `a` might capture `cv`. - -* Alas, when cloning a coercion variable we might choose a unique - that happens to clash with an inner Id, thus - \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` because it's already in scope. Fine, - choose a new unique. Aha, X7 looks good. So we check the lambda - body with le_subst of [cv_66 :-> cv_X7] - - This is all fine, even though we use the same unique as wild_X7. - As (SI2) says, we do /not/ return a new lambda - (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst substitution in types/coercions only, when - checking for equality. - -* We still need to check that Id occurrences are bound by some - enclosing binding. We do /not/ use the InScopeSet for the le_subst - for this purpose -- it contains only TyCoVars. Instead we have a separate - le_ids for the in-scope Id binders. - -Sigh. We might want to explore getting rid of type-let! +We check this invariant in lintType. Note [Bad unsafe coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -311,6 +254,7 @@ path does not result in allocation in the hot path. This can be surprisingly impactful. Changing `lint_app` reduced allocations for one test program I was looking at by ~4%. + ************************************************************************ * * Beginning and ending passes @@ -407,26 +351,37 @@ data LintPassResultConfig = LintPassResultConfig , lpr_platform :: !Platform , lpr_makeLintFlags :: !LintFlags , lpr_passPpr :: !SDoc + , lpr_preSubst :: !Bool -- True <=> run substTypeLets before linting + -- See Note [Substituting type-lets] , lpr_localsInScope :: ![Var] } lintPassResult :: Logger -> LintPassResultConfig -> CoreProgram -> IO () lintPassResult logger cfg binds - = do { let warns_and_errs = lintCoreBindings' - (LintConfig + = do { let lint_config = LintConfig { l_diagOpts = lpr_diagOpts cfg , l_platform = lpr_platform cfg , l_flags = lpr_makeLintFlags cfg , l_vars = lpr_localsInScope cfg - }) - binds + } + + -- Do the pre-substitution if necessary + -- See Note [Substituting type-lets] in GHC.Core.SubstTypeLets + -- especially wrinkle (STL2) + ; let binds1 | lpr_preSubst cfg = substTypeLets binds + | otherwise = binds + + -- Do the main Lint pass itself + ; let warns_and_errs = lintCoreBindings lint_config binds1 + + -- Report the results ; Err.showPass logger $ "Core Linted result of " ++ renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger (lpr_passPpr cfg) - (pprCoreBindings binds) warns_and_errs + (pprCoreBindings binds1) warns_and_errs } displayLintResults :: Logger @@ -456,11 +411,11 @@ lint_banner string pass = text "*** Core Lint" <+> text string <+> text "***" -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs +lintCoreBindings :: LintConfig -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreBindings' cfg binds +lintCoreBindings cfg binds = initL cfg $ addLoc TopLevelBindings $ do { -- Check that all top-level binders are distinct @@ -472,8 +427,7 @@ lintCoreBindings' cfg binds ; checkL (null ext_dups) (dupExtVars ext_dups) -- Typecheck the bindings - ; lintRecBindings TopLevel all_pairs $ \_ -> - return () } + ; lintRecBindings TopLevel all_pairs $ return () } where all_pairs = flattenBinds binds -- Put all the top-level binders in scope at the start @@ -555,28 +509,28 @@ Check a core binding, returning the list of variables bound. -- Let lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv]) + -> LintM a -> LintM (a, [UsageEnv]) lintRecBindings top_lvl pairs thing_inside - = lintIdBndrs top_lvl bndrs $ \ bndrs' -> - do { ues <- zipWithM lint_pair bndrs' rhss - ; a <- thing_inside bndrs' + = lintIdBndrs top_lvl bndrs $ + do { ues <- zipWithM lint_pair bndrs rhss + ; a <- thing_inside ; return (a, ues) } where (bndrs, rhss) = unzip pairs - lint_pair bndr' rhs - = addLoc (RhsOf bndr') $ - do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + lint_pair bndr rhs + = addLoc (RhsOf bndr) $ + do { (rhs_ty, ue) <- lintRhs bndr rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr rhs rhs_ty ; return ue } -lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv) +lintLetBody :: LintLocInfo -> [Id] -> CoreExpr -> LintM (Type, UsageEnv) lintLetBody loc bndrs body = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body) ; mapM_ (lintJoinBndrType body_ty) bndrs ; return (body_ty, body_ue) } -lintLetBind :: TopLevelFlag -> RecFlag -> OutId - -> CoreExpr -> OutType -> LintM () +lintLetBind :: TopLevelFlag -> RecFlag -> Id + -> CoreExpr -> Type -> LintM () -- Binder's type, and the RHS, have already been linted -- This function checks other invariants lintLetBind top_lvl rec_flag binder rhs rhs_ty @@ -651,14 +605,17 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty _ -> return () - ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint any RULES + ; addLoc (RuleOf binder) $ + mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint the unfolding + -- Do this here, not in lintIdBinder, so that all the + -- binders of the letrec group are in scope ; addLoc (UnfoldingOf binder) $ lintIdUnfolding binder binder_ty (idUnfolding binder) - ; return () } - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. + ; return () } -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' -- in that it doesn't reject occurrences of the function 'makeStatic' when they @@ -667,7 +624,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- join point. -- -- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintRhs :: Id -> CoreExpr -> LintM (Type, UsageEnv) -- NB: the Id can be Linted or not -- it's only used for -- its OccInfo and join-pointer-hood lintRhs bndr rhs @@ -682,7 +639,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go where -- Allow occurrences of 'makeStatic' at the top-level but produce errors -- otherwise. - go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go :: StaticPtrCheck -> LintM (Type, UsageEnv) go AllowAtTopLevel | (binders0, rhs') <- collectTyBinders rhs , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' @@ -699,7 +656,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go -- | Lint the RHS of a join point with expected join arity of @n@ (see Note -- [Join points] in "GHC.Core"). -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (Type, UsageEnv) lintJoinLams join_arity enforce rhs = go join_arity rhs where @@ -715,17 +672,22 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf | isStableUnfolding uf , Just rhs <- maybeUnfoldingTemplate uf - = noMultiplicityChecks $ -- Skip linearity checking for unfoldings - -- See Note [Linting linearity] - do { ty <- fst <$> (if isCompulsoryUnfolding uf - then noFixedRuntimeRepChecks $ lintRhs bndr rhs - -- ^^^^^^^^^^^^^^^^^^^^^^^ - -- See Note [Checking for representation polymorphism] - else lintRhs bndr rhs) - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + = suppress_rr_checks $ + noMultiplicityChecks $ -- Skip linearity checking for unfoldings + -- See Note [Linting linearity] + do { (unf_ty, _unf_ue) <- lintRhs bndr rhs + ; ensureEqTys bndr_ty unf_ty (mkRhsMsg bndr (text "unfolding") unf_ty) } + + | otherwise + = -- Do not Lint the body of an unstable unfolding, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + return () + + where + -- See Note [Checking for representation polymorphism] + suppress_rr_checks thing_inside + | isCompulsoryUnfolding uf = noFixedRuntimeRepChecks thing_inside + | otherwise = thing_inside {- Note [Checking for INLINE loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -887,13 +849,8 @@ suspicious and worth investigating if you have a seg-fault or bizarre behaviour. ************************************************************************ -} -lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv) --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - +lintCoreExpr :: CoreExpr -> LintM (Type, UsageEnv) +-- The returned type is the type of the expression -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -920,7 +877,7 @@ lintCoreExpr (Cast expr co) ; lintCoercion co ; lintRole co Representational (coercionRole co) - ; Pair from_ty to_ty <- substCoKindM co + ; let Pair from_ty to_ty = coercionKind co ; checkValueType (typeKind to_ty) $ text "target of cast" <+> quotes (ppr co) ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty) @@ -934,27 +891,22 @@ lintCoreExpr (Tick tickish expr) lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- lintTypeAndSubst ty - ; lintTyCoBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendTvSubstL tv ty' $ - addLoc (BodyOfLet tv) $ - lintCoreExpr body } } + = do { lintType ty + ; lintTyCoBndr tv $ + do { addLoc (RhsOf tv) $ lintTyKind tv ty + ; addLoc (BodyOfLet tv) $ lintCoreExpr body } } lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr = do { -- First Lint the RHS, before bringing the binder into scope (rhs_ty, let_ue) <- lintRhs bndr rhs - -- See Note [Multiplicity of let binders] in Var + -- See Note [Multiplicity of let binders] in Var -- Now lint the binder - ; lintBinder LetBind bndr $ \bndr' -> - do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; addAliasUE bndr' let_ue $ - lintLetBody (BodyOfLet bndr') [bndr'] body } } + ; lintBinder LetBind bndr $ + do { lintLetBind NotTopLevel NonRecursive bndr rhs rhs_ty + ; addAliasUE bndr let_ue $ + lintLetBody (BodyOfLet bndr) [bndr] body } } | otherwise = failWithL (mkLetErr bndr rhs) -- Not quite accurate @@ -973,8 +925,8 @@ lintCoreExpr e@(Let (Rec pairs) body) -- See Note [Multiplicity of let binders] in Var ; ((body_type, body_ue), ues) <- - lintRecBindings NotTopLevel pairs $ \ bndrs' -> - lintLetBody (BodyOfLetRec bndrs') bndrs' body + lintRecBindings NotTopLevel pairs $ + lintLetBody (BodyOfLetRec bndrs) bndrs body ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) } where bndrs = map fst pairs @@ -986,7 +938,7 @@ lintCoreExpr e@(App _ _) -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y , ty_arg1 : ty_arg2 : cont_arg : rest <- args - = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) + = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (Type, UsageEnv) lint_rw_cont expr@(Lam _ _) mult fun_ue = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) @@ -1036,74 +988,73 @@ lintCoreExpr (Type ty) lintCoreExpr (Coercion co) -- See Note [Coercions in terms] = do { addLoc (InCo co) $ lintCoercion co - ; ty <- substTyM (coercionType co) + ; let ty = coercionType co ; return (ty, zeroUE) } ---------------------- -lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed - -> LintM (OutType, UsageEnv) -- returns type of the *variable* -lintIdOcc in_id nargs - = addLoc (OccOf in_id) $ - do { checkL (isNonCoVarId in_id) - (text "Non term variable" <+> ppr in_id) +lintIdOcc :: Id -> Int -- Number of arguments (type or value) being passed + -> LintM (Type, UsageEnv) -- returns type of the *variable* +lintIdOcc id nargs + = addLoc (OccOf id) $ + do { checkL (isNonCoVarId id) + (text "Non term variable" <+> ppr id) -- See GHC.Core Note [Variable occurrences in Core] - -- Check that the type of the occurrence is the same - -- as the type of the binding site. The inScopeIds are - -- /un-substituted/, so this checks that the occurrence type - -- is identical to the binder type. - -- This makes things much easier for things like: - -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... - -- The "::Maybe a" on the occurrence is referring to the /outer/ a. - -- If we compared /substituted/ types we'd risk comparing - -- (Maybe a) from the binding site with bogus (Maybe a1) from - -- the occurrence site. Comparing un-substituted types finesses - -- this altogether - ; out_ty <- lintVarOcc in_id + ; lintVarOcc id -- Check for a nested occurrence of the StaticPtr constructor. -- See Note [Checking StaticPtrs]. ; when (nargs /= 0) $ - checkL (idName in_id /= makeStaticName) $ + checkL (idName id /= makeStaticName) $ text "Found makeStatic nested in an expression" - ; checkDeadIdOcc in_id + ; checkDeadIdOcc id - ; case isDataConId_maybe in_id of + ; case isDataConId_maybe id of Nothing -> return () Just dc -> checkTypeDataConOcc "expression" dc - ; checkJoinOcc in_id nargs - ; usage <- varCallSiteUsage in_id - - ; return (out_ty, usage) } + ; checkJoinOcc id nargs + ; usage <- varCallSiteUsage id + ; return (idType id, usage) } +------------------ lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM (OutType, UsageEnv) -- Returns type of the *function* + -> Int -- Number of arguments (type or val) being passed + -> LintM (Type, UsageEnv) -- Returns type of the *function* lintCoreFun (Var var) nargs = lintIdOcc var nargs lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; - -- See Note [Beta redexes] + -- Act like lintCoreExpr of Lam, but *don't* necessarily call markAllJoinsBad; + -- See Note [Join points and beta-redexes] | nargs /= 0 = lintLambda var $ lintCoreFun body (nargs - 1) lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr + = do { mark_bad_joins + <- if nargs == 0 + then -- Saturated lambda + -- See Note [Join points and beta-redexes] + do { flags <- getLintFlags + ; return (not (lf_allow_beta_joins flags)) } + else -- Something else + -- See Note [Join points are less general than the paper] + return True + + ; markAllJoinsBadIf mark_bad_joins $ + lintCoreExpr expr } + ------------------ lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) lintLambda var lintBody = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> + lintBinder LambdaBind var $ do { (body_ty, ue) <- lintBody - ; ue' <- checkLinearity ue var' - ; return (mkLamType var' body_ty, ue') } + ; ue' <- checkLinearity ue var + ; return (mkLamType var body_ty, ue') } ------------------ checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -1117,8 +1068,8 @@ checkDeadIdOcc id = return () ------------------ -lintJoinBndrType :: OutType -- Type of the body - -> OutId -- Possibly a join Id +lintJoinBndrType :: Type -- Type of the body + -> Id -- Possibly a join Id -> LintM () -- Checks that the return type of a join Id matches the body -- E.g. join j x = rhs in body @@ -1337,8 +1288,55 @@ checkLinearity body_ue lam_var = return body_ue' Nothing -> return body_ue -- A type variable -{- Note [Linting join points with casts or ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Join points and beta-redexes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker/wrapper pass, the worker invokes the original function by calling +it with arguments, thus producing a beta-redex for the simplifier to munch away: + + \x y z -> e => (\x y z -> e) wx wy wz + +But we need to take care if `e` invokes a join point. For example: + + join j1 x = ... + join j2 y = if y == 0 then 0 else j1 y +=> + join j1 x = ... + join $wj2 y# = (\y -> if y == 0 then 0 else jump j1 y) (I# y#) + join j2 y = case y of I# y# -> jump $wj2 y# + +Now the jump to `j1` is inside a lambda and inside an application. That is ill-typed +from Lint's point of view. And yet, after one round of simplification it'll all be +fine. + +You might wonder if we could use a `let` instead of a lambda for the worker: + + join $wj2 y# = let y = I# y# + in if y == 0 then 0 else jump j1 y + +That would solve the join-point problem, but it really doesn't work because + 1. The lets shadow each other + 2. In particular the invariant (NoTypeShadowing) is easily broken. + (We might have type lambdas of course.) + +In short, te lambda arguments should not "see" any of the lambda-bound +variables. + +So our solution is this: + +* Use straightforward applicaion in the worker-wrapper pass, creating a beta-redex. + See the call to `mkApps` in GHC.Core.Opt.WorkWrap.Utils.mkWwBodies. + +* Tell Lint not to complain about a join-point invocation hidden under a + saturated beta-redex. The code is rather simple: see `lintCoreFun`. + + We guard this with a Lint flag `lf_allow_beta_joins`. + +* Teach occurrence analysis that `j1` is still a join point, despite its + call being nested inside the beta-redex. See Note [occAnal for applications] + in GHC.Core.Opt.OccurAnal. + +Note [Linting join points with casts or ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful when a cast or tick occurs in between a join point binding and a corresponding join point occurrence. @@ -1409,33 +1407,6 @@ lose track of why an expression is bottom, so we shouldn't make too much fuss when that happens. -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in GHC.Core). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - ************************************************************************ * * \subsection[lintCoreArgs]{lintCoreArgs} @@ -1449,23 +1420,23 @@ subtype of the required type, as one would expect. -- Takes the functions type and arguments as argument. -- Returns the *result* of applying the function to arguments. -- e.g. f :: Int -> Bool -> Int would return `Int` as result type. -lintCoreArgs :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv) +lintCoreArgs :: (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv) lintCoreArgs (fun_ty, fun_ue) args - = lintApp (text "expression") - lintTyArg lintValArg fun_ty args fun_ue + = lintApp (text "expression") lintTyArg lintValArg fun_ty args fun_ue -lintTyArg :: InExpr -> LintM OutType +lintTyArg :: CoreExpr -> LintM Type -- Type argument lintTyArg (Type arg_ty) = do { checkL (not (isCoercionTy arg_ty)) (text "Unnecessary coercion-to-type injection:" <+> ppr arg_ty) - ; lintTypeAndSubst arg_ty } + ; lintType arg_ty + ; return arg_ty } lintTyArg arg = failWithL (hang (text "Expected type argument but found") 2 (ppr arg)) -lintValArg :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) +lintValArg :: CoreExpr -> Mult -> UsageEnv -> LintM (Type, UsageEnv) lintValArg arg mult fun_ue = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg -- See Note [Representation polymorphism invariants] in GHC.Core @@ -1484,9 +1455,9 @@ lintValArg arg mult fun_ue ----------------- lintAltBinders :: UsageEnv - -> Var -- Case binder - -> OutType -- Scrutinee type - -> OutType -- Constructor type + -> Var -- Case binder + -> Type -- Scrutinee type + -> Type -- Constructor type -> [(Mult, OutVar)] -- Binders -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism @@ -1505,6 +1476,7 @@ lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + -- | Implements the case rules for linearity checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv checkCaseLinearity ue case_bndr var_w bndr = do @@ -1529,7 +1501,7 @@ checkCaseLinearity ue case_bndr var_w bndr = do ----------------- -lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp :: Type -> Type -> LintM Type lintTyApp fun_ty arg_ty | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty = do { lintTyKind tv arg_ty @@ -1547,8 +1519,8 @@ lintTyApp fun_ty arg_ty -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the -- application. -lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv - -> LintM (OutType, UsageEnv) +lintValApp :: CoreExpr -> Type -> Type -> UsageEnv -> UsageEnv + -> LintM (Type, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) @@ -1559,9 +1531,7 @@ lintValApp arg fun_ty arg_ty fun_ue arg_ue where err2 = mkNonFunAppMsg fun_ty arg_ty arg -lintTyKind :: OutTyVar -> OutType -> LintM () --- Both args have had substitution applied - +lintTyKind :: OutTyVar -> Type -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintTyKind tyvar arg_ty @@ -1579,36 +1549,36 @@ lintTyKind tyvar arg_ty ************************************************************************ -} -lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv) +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (Type, UsageEnv) lintCaseExpr scrut case_bndr alt_ty alts = do { let e = Case scrut case_bndr alt_ty alts -- Just for error messages -- Check the scrutinee - ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut -- See Note [Join points are less general than the paper] -- in GHC.Core - ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty + ; addLoc (CaseTy scrut) $ lintValueType alt_ty - ; checkCaseAlts e scrut scrut_ty' alts + ; checkCaseAlts e scrut scrut_ty alts -- Lint the case-binder. Must do this after linting the scrutinee -- because the case-binder isn't in scope in the scrutineex - ; lintBinder CaseBind case_bndr $ \case_bndr' -> + ; lintBinder CaseBind case_bndr $ -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate - do { let case_bndr_ty' = idType case_bndr' - scrut_mult = idMult case_bndr' + do { let case_bndr_ty = idType case_bndr + scrut_mult = idMult case_bndr - ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty') + ; ensureEqTys case_bndr_ty scrut_ty (mkScrutMsg case_bndr case_bndr_ty scrut_ty) -- See GHC.Core Note [Case expression invariants] item (7) ; -- Check the alternatives - ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts + ; alt_ues <- mapM (lintCoreAlt case_bndr scrut_ty scrut_mult alt_ty) alts ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues - ; return (alt_ty', case_ue) } } + ; return (alt_ty, case_ue) } } -checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM () +checkCaseAlts :: CoreExpr -> CoreExpr -> Type -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty -- b1) Check that the DEFAULT comes first, if it exists -- b2) Check that the others are in increasing order @@ -1683,17 +1653,17 @@ checkCaseAlts e scrut scrut_ty alts is_lit_alt (Alt (LitAlt _) _ _) = True is_lit_alt _ = False -lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv +lintAltExpr :: CoreExpr -> Type -> LintM UsageEnv lintAltExpr expr ann_ty = do { (actual_ty, ue) <- lintCoreExpr expr ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) ; return ue } -- See GHC.Core Note [Case expression invariants] item (6) -lintCoreAlt :: OutId -- Case binder - -> OutType -- Type of scrutinee +lintCoreAlt :: Id -- Case binder + -> Type -- Type of scrutinee -> Mult -- Multiplicity of scrutinee - -> OutType -- Type of the alternative + -> Type -- Type of the alternative -> CoreAlt -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism @@ -1738,11 +1708,11 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do + ; lintBinders CasePatBind args $ do { rhs_ue <- lintAltExpr rhs alt_ty ; rhs_ue' <- addLoc (CasePat alt) $ lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty - (zipEqual multiplicities args') + (zipEqual multiplicities args) ; return $ deleteUE rhs_ue' case_bndr } } @@ -1784,54 +1754,52 @@ lintLinearBinder doc actual_usage described_usage -} -- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') +-- 1. Lint var types or kinds +-- 2. Add the binder to the in scope set +lintBinders :: HasDebugCallStack => BindingSite -> [Var] -> LintM a -> LintM a +lintBinders _ [] linterF = linterF +lintBinders site (var:vars) linterF = lintBinder site var $ + lintBinders site vars $ + linterF -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a +lintBinder :: HasDebugCallStack => BindingSite -> Var -> LintM a -> LintM a lintBinder site var linterF | isTyCoVar var = lintTyCoBndr var linterF | otherwise = lintIdBndr NotTopLevel site var linterF -lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr :: HasDebugCallStack => TyCoVar -> LintM a -> LintM a lintTyCoBndr tcv thing_inside - = do { tcv_type' <- lintTypeAndSubst (varType tcv) - ; let tcv_kind' = typeKind tcv_type' + = do { let tcv_type = varType tcv + tcv_kind = typeKind tcv_type + ; lintType (varType tcv) -- See (FORALL1) and (FORALL2) in GHC.Core.Type ; if (isTyVar tcv) then -- Check that in (forall (a:ki). blah) we have ki:Type - lintL (isLiftedTypeKind tcv_kind') $ + lintL (isLiftedTypeKind tcv_kind) $ hang (text "TyVar whose kind does not have kind Type:") - 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') + 2 (ppr tcv <+> dcolon <+> ppr tcv_type <+> dcolon <+> ppr tcv_kind) else -- Check that in (forall (cv::ty). blah), -- then ty looks like (t1 ~# t2) - lintL (isCoVarType tcv_type') $ + lintL (isCoVarType tcv_type) $ text "CoVar with non-coercion type:" <+> pprTyVar tcv - ; addInScopeTyCoVar tcv tcv_type' thing_inside } + ; addInScopeTyCoVar tcv thing_inside } -lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a +lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> LintM a -> LintM a lintIdBndrs top_lvl ids thing_inside = go ids thing_inside where - go :: [Id] -> ([Id] -> LintM a) -> LintM a - go [] thing_inside = thing_inside [] - go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> - go ids $ \ids' -> - thing_inside (id' : ids') + go :: [Id] -> LintM a -> LintM a + go [] thing_inside = thing_inside + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ + go ids $ + thing_inside lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument + -> Var -> LintM a -> LintM a -- ToDo: lint its rules lintIdBndr top_lvl bind_site id thing_inside = assertPpr (isId id) (ppr id) $ @@ -1864,14 +1832,16 @@ lintIdBndr top_lvl bind_site id thing_inside ; lintL (not (isCoVarType id_ty)) (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - -- Check that the lambda binder has no value or OtherCon unfolding. + -- Check that lambda-bound Ids have no unfolding; not even OtherCon -- See #21496 - ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") + ; let unf = idUnfolding id + ; checkL (not (bind_site == LambdaBind && hasSomeUnfolding unf)) $ + hang (text "Lambda binder" <+> quotes (ppr id) <+> text "has an unfolding") + 2 (ppr unf) - ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) + ; addLoc (IdTy id) (lintValueType id_ty) - ; addInScopeId id out_ty thing_inside } + ; addInScopeId id thing_inside } where id_ty = idType id @@ -1891,62 +1861,44 @@ lintIdBndr top_lvl bind_site id thing_inside {- Note [Linting types and coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that - lintType :: InType -> LintM () - lintCoercion :: InCoercion -> LintM () + lintType :: Type -> LintM () + lintCoercion :: Coercion -> LintM () Neither returns anything. -If you need the kind of the type, then do `typeKind` and then apply -the ambient substitution using `substTyM`. Note that the substitution -empty unless there is shadowing or type-lets; and if the substitution is -empty, the `substTyM` is a no-op. - -It is better to take the kind and then substitute, rather than substitute -and then take the kind, becaues the kind is usually smaller. - -Note: you might wonder if we should apply the same logic to expressions. -Why do we have - lintExpr :: InExpr -> LintM OutType -Partly inertia; but also taking the type of an expresison involve looking -down a deep chain of let's, whereas that is not true of taking the kind -of a type. It'd be worth an experiment though. - -Historical note: in the olden days we had - lintType :: InType -> LintM OutType -but that burned a huge amount of allocation building an OutType that was -often discarded, or used only to get its kind. - -I also experimented with - lintType :: InType -> LintM OutKind -but that too was slower. It is also much simpler to return ()! If we -return the kind we have to duplicate the logic in `typeKind`; and it is -much worse for coercions. +Note: you might wonder why we have + lintExpr :: CoreExpr -> LintM Type + lintType :: Type -> LintM () + +That is, linting an expression yields its type, but linting a type does not +yield its kind. Partly inertia; but: + +* Taking the type of an expresison involves looking down a deep chain of let's, + whereas that is not true of taking the kind of a type. It'd be worth an + experiment though. + +* I did experiment with + lintType :: Type -> LintM Kind + but that too was slower. It is also much simpler to return ()! If we return + the kind we have to duplicate the logic in `typeKind`; and it is much worse + for coercions. -} -lintValueType :: Type -> LintM OutType +lintValueType :: Type -> LintM () -- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] lintValueType ty = addLoc (InType ty) $ - do { ty' <- lintTypeAndSubst ty - ; let sk = typeKind ty' + do { lintType ty + ; let sk = typeKind ty ; lintL (isTYPEorCONSTRAINT sk) $ hang (text "Ill-kinded type:" <+> ppr ty) - 2 (text "has kind:" <+> ppr sk) - ; return ty' } + 2 (text "has kind:" <+> ppr sk)} checkTyCon :: TyCon -> LintM () checkTyCon tc = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) ------------------- -lintTypeAndSubst :: InType -> LintM OutType -lintTypeAndSubst ty = do { lintType ty; substTyM ty } - -- In GHCi we may lint an expression with a free - -- type variable. Then it won't be in the - -- substitution, but it should be in scope - -lintType :: InType -> LintM () +lintType :: Type -> LintM () -- See Note [Linting types and coercions] -- -- If you edit this function, you may need to update the GHC formalism @@ -1956,8 +1908,7 @@ lintType (TyVarTy tv) = failWithL (mkBadTyVarMsg tv) | otherwise - = do { _ <- lintVarOcc tv - ; return () } + = lintVarOcc tv lintType ty@(AppTy t1 t2) | TyConApp {} <- t1 @@ -1965,7 +1916,7 @@ lintType ty@(AppTy t1 t2) | otherwise = do { let (fun_ty, arg_tys) = collect t1 [t2] ; lintType fun_ty - ; fun_kind <- substTyM (typeKind fun_ty) + ; let fun_kind = typeKind fun_ty ; lint_ty_app ty fun_kind arg_tys } where collect (AppTy f a) as = collect f (a:as) @@ -1997,21 +1948,21 @@ lintType ty@(FunTy af tw t1 t2) lintType ty@(ForAllTy {}) = go [] ty where - go :: [OutTyCoVar] -> InType -> LintM () + go :: [OutTyCoVar] -> Type -> LintM () -- Loop, collecting the forall-binders go tcvs ty@(ForAllTy (Bndr tcv _) body_ty) | not (isTyCoVar tcv) = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty) | otherwise - = lintTyCoBndr tcv $ \tcv' -> + = lintTyCoBndr tcv $ do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] -- Suspicious because it works on InTyCoVar; c.f. ForAllCo when (isCoVar tcv) $ lintL (anyFreeVarsOfType (== tcv) body_ty) $ text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) - ; go (tcv' : tcvs) body_ty } + ; go (tcv : tcvs) body_ty } go tcvs body_ty = do { lintType body_ty @@ -2019,7 +1970,7 @@ lintType ty@(ForAllTy {}) lintType (CastTy ty co) = do { lintType ty - ; ty_kind <- substTyM (typeKind ty) + ; let ty_kind = typeKind ty ; co_lk <- lintStarCoercion co ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) } @@ -2027,14 +1978,14 @@ lintType (LitTy l) = lintTyLit l lintType (CoercionTy co) = lintCoercion co ----------------- -lintForAllBody :: [OutTyCoVar] -> InType -> LintM () +lintForAllBody :: [OutTyCoVar] -> Type -> LintM () -- Do the checks for the body of a forall-type lintForAllBody tcvs body_ty = do { -- For type variables, check for skolem escape -- See Note [Phantom type variables in kinds] in GHC.Core.Type -- The kind of (forall cv. th) is liftedTypeKind, so no -- need to check for skolem-escape in the CoVar case - body_kind <- substTyM (typeKind body_ty) + let body_kind = typeKind body_ty ; case occCheckExpand tcvs body_kind of Just {} -> return () Nothing -> failWithL $ @@ -2045,7 +1996,7 @@ lintForAllBody tcvs body_ty ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) } ----------------- -lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM () +lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM () -- The TyCon is a type synonym or a type family (not a data family) -- See Note [Linting type synonym applications] -- c.f. GHC.Tc.Validity.check_syn_tc_app @@ -2071,21 +2022,21 @@ lintTySynFamApp report_unsat ty tc tys ----------------- -- Confirms that a kind is really TYPE r or Constraint -checkValueType :: OutKind -> SDoc -> LintM () +checkValueType :: Kind -> SDoc -> LintM () checkValueType kind doc = lintL (isTYPEorCONSTRAINT kind) (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ text "when checking" <+> doc) ----------------- -lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM () +lintArrow :: SDoc -> FunTyFlag -> Type -> Type -> Type -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintArrow what af t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw -- or lintArrow "coercion `blah'" k1 k2 kw - = do { k1 <- substTyM (typeKind t1) - ; k2 <- substTyM (typeKind t2) - ; kw <- substTyM (typeKind tw) + = do { let k1 = typeKind t1 + k2 = typeKind t2 + kw = typeKind tw ; unless (isTYPEorCONSTRAINT k1) (report (text "argument") t1 k1) ; unless (isTYPEorCONSTRAINT k2) (report (text "result") t2 k2) ; unless (isMultiplicityTy kw) (report (text "multiplicity") tw kw) @@ -2111,34 +2062,34 @@ lintTyLit (StrTyLit _) = return () lintTyLit (CharTyLit _) = return () ----------------- -lint_ty_app :: InType -> OutKind -> [InType] -> LintM () +lint_ty_app :: Type -> Kind -> [Type] -> LintM () lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty)) -lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM () +lint_co_app :: HasDebugCallStack => Coercion -> Kind -> [Type] -> LintM () lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co)) -lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM () +lint_tyco_app :: SDoc -> Kind -> [Type] -> LintM () lint_tyco_app msg fun_kind arg_tys -- See Note [Avoiding compiler perf traps when constructing error messages.] - = do { _ <- lintApp msg (\ty -> do { lintType ty; substTyM ty }) - (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) }) - fun_kind arg_tys () + = do { _ <- lintApp msg (\ty -> do { lintType ty; return ty }) + (\ty _ _ -> do { lintType ty; return (typeKind ty,()) }) + fun_kind arg_tys () ; return () } ---------------- -lintApp :: forall in_a acc. Outputable in_a => +lintApp :: forall a acc. Outputable a => SDoc - -> (in_a -> LintM OutType) -- Lint the thing and return its value - -> (in_a -> Mult -> acc -> LintM (OutKind, acc)) -- Lint the thing and return its type - -> OutType - -> [in_a] -- The arguments, always "In" things - -> acc -- Used (only) for UsageEnv in /term/ applications - -> LintM (OutType,acc) + -> (a -> LintM Type) -- Lint the thing and return its value + -> (a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type + -> Type + -> [a] -- The arguments + -> acc -- Used (only) for UsageEnv in /term/ applications + -> LintM (Type,acc) -- lintApp is a performance-critical function, which deals with multiple -- applications such as (/\a./\b./\c. expr) @ta @tb @tc -- When returning the type of this expression we want to avoid substituting a:=ta, -- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge --- perf hole. So we gather all the arguments [in_a], and then gather the +-- perf hole. So we gather all the arguments [a], and then gather the -- substitution incrementally in the `go` loop. -- -- lintApp is used: @@ -2158,7 +2109,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc ; let init_subst = mkEmptySubst in_scope - go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc) + go :: Subst -> Type -> acc -> [a] -> LintM (Type, acc) -- The Subst applies (only) to the fun_ty -- c.f. GHC.Core.Type.piResultTys, which has a similar loop @@ -2202,7 +2153,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc -- explicitly and don't capture them as free variables. Otherwise this binder might -- become a thunk that get's allocated in the hot code path. -- See Note [Avoiding compiler perf traps when constructing error messages.] -lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc +lint_app_fail_msg :: (Outputable a2) => SDoc -> Type -> a2 -> SDoc -> SDoc lint_app_fail_msg msg kfn arg_tys extra = vcat [ hang (text "Application error in") 2 msg , nest 2 (text "Function type =" <+> ppr kfn) @@ -2215,7 +2166,7 @@ lint_app_fail_msg msg kfn arg_tys extra * * ********************************************************************* -} -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () +lintCoreRule :: OutVar -> Type -> CoreRule -> LintM () lintCoreRule _ _ (BuiltinRule {}) = return () -- Don't bother @@ -2223,7 +2174,7 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs , ru_args = args, ru_rhs = rhs }) = noMultiplicityChecks $ -- Skip linearity checking for rules -- See Note [Linting linearity] - lintBinders LambdaBind bndrs $ \ _ -> + lintBinders LambdaBind bndrs $ do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args ; (rhs_ty, _) <- case idJoinPointHood fun of JoinPoint join_arity @@ -2311,10 +2262,10 @@ Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further {- Note [Asymptotic efficiency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting coercions (and types actually) we return a linted -(substituted) coercion. Then we often have to take the coercionKind of -that returned coercion. If we get long chains, that can be asymptotically -inefficient, notably in +When linting coercions we traverse the coercion. Then we often have to take the +coercionKind of that returned coercion. If we get long chains, that can be +asymptotically inefficient, notably in + * TransCo * InstCo * SelCo (cf #9233) @@ -2326,30 +2277,23 @@ the bad perf bites us in practice. A solution would be to return the kind and role of the coercion, as well as the linted coercion. Or perhaps even *only* the kind and role, which is what used to happen. But that proved tricky and error prone -(#17923), so now we return the coercion. +(#17923). -} -- lintStarCoercion lints a coercion, confirming that its lh kind and -- its rh kind are both *; also ensures that the role is Nominal -- Returns the lh kind -lintStarCoercion :: InCoercion -> LintM OutType +lintStarCoercion :: Coercion -> LintM Type lintStarCoercion g = do { lintCoercion g - ; Pair t1 t2 <- substCoKindM g + ; let Pair t1 t2 = coercionKind g ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g) ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g) ; lintRole g Nominal (coercionRole g) ; return t1 } -substCoKindM :: InCoercion -> LintM (Pair OutType) -substCoKindM co - = do { let !(Pair lk rk) = coercionKind co - ; lk' <- substTyM lk - ; rk' <- substTyM rk - ; return (Pair lk' rk') } - -lintCoercion :: HasDebugCallStack => InCoercion -> LintM () +lintCoercion :: HasDebugCallStack => Coercion -> LintM () -- See Note [Linting types and coercions] -- -- If you edit this function, you may need to update the GHC formalism @@ -2361,7 +2305,7 @@ lintCoercion (CoVarCo cv) 2 (text "With offending type:" <+> ppr (varType cv))) | otherwise -- C.f. lintType (TyVarTy tv), which has better docs - = do { _ <- lintVarOcc cv; return () } + = lintVarOcc cv lintCoercion (Refl ty) = lintType ty lintCoercion (GRefl _r ty MRefl) = lintType ty @@ -2369,8 +2313,8 @@ lintCoercion (GRefl _r ty MRefl) = lintType ty lintCoercion (GRefl _r ty (MCo co)) = do { lintType ty ; lintCoercion co - ; tk <- substTyM (typeKind ty) - ; tl <- substTyM (coercionLKind co) + ; let tk = typeKind ty + tl = coercionLKind co ; ensureEqTys tk tl $ hang (text "GRefl coercion kind mis-match:" <+> ppr co) 2 (vcat [ppr ty, ppr tk, ppr tl]) @@ -2403,8 +2347,8 @@ lintCoercion co@(AppCo co1 co2) = do { lintCoercion co1 ; lintCoercion co2 ; let !(Pair lt1 rt1) = coercionKind co1 - ; lk1 <- substTyM (typeKind lt1) - ; rk1 <- substTyM (typeKind rt1) + lk1 = typeKind lt1 + rk1 = typeKind rt1 ; lint_co_app co lk1 [coercionLKind co2] ; lint_co_app co rk1 [coercionRKind co2] @@ -2421,7 +2365,7 @@ lintCoercion co@(ForAllCo {}) = do { _ <- go [] co; return () } where go :: [OutTyCoVar] -- Binders in reverse order - -> InCoercion -> LintM Role + -> Coercion -> LintM Role go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR , fco_kind = kind_mco, fco_body = body_co }) | not (isTyCoVar tcv) @@ -2431,15 +2375,15 @@ lintCoercion co@(ForAllCo {}) = do { mb_lk <- case kind_mco of MRefl -> return Nothing MCo kind_co -> Just <$> lintStarCoercion kind_co - ; lintTyCoBndr tcv $ \tcv' -> + ; lintTyCoBndr tcv $ do { case mb_lk of Nothing -> return () - Just lk -> ensureEqTys (varType tcv') lk $ + Just lk -> ensureEqTys (varType tcv) lk $ text "Kind mis-match in ForallCo" <+> ppr co -- I'm not very sure about this part, because it traverses body_co -- but at least it's on a cold path (a ForallCo for a CoVar) - -- Also it works on InTyCoVar and InCoercion, which is suspect + -- Also it works on InTyCoVar and Coercion, which is suspect ; when (isCoVar tcv) $ do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $ text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co @@ -2448,7 +2392,7 @@ lintCoercion co@(ForAllCo {}) text "Covar can only appear in Refl and GRefl: " <+> ppr co } -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep - ; role <- go (tcv':tcvs) body_co + ; role <- go (tcv:tcvs) body_co ; when (role == Nominal) $ lintL (visL `eqForAllVis` visR) $ @@ -2505,8 +2449,8 @@ lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov -- Check the to and from types ; lintType ty1 ; lintType ty2 - ; tk1 <- substTyM (typeKind ty1) - ; tk2 <- substTyM (typeKind ty2) + ; let tk1 = typeKind ty1 + tk2 = typeKind ty2 ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2) (checkTypes ty1 ty2) @@ -2560,8 +2504,8 @@ lintCoercion (SymCo co) = lintCoercion co lintCoercion co@(TransCo co1 co2) = do { lintCoercion co1 ; lintCoercion co2 - ; rk1 <- substTyM (coercionRKind co1) - ; lk2 <- substTyM (coercionLKind co2) + ; let rk1 = coercionRKind co1 + lk2 = coercionLKind co2 ; ensureEqTys rk1 lk2 (hang (text "Trans coercion mis-match:" <+> ppr co) 2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)])) @@ -2569,7 +2513,7 @@ lintCoercion co@(TransCo co1 co2) lintCoercion the_co@(SelCo cs co) = do { lintCoercion co - ; Pair s t <- substCoKindM co + ; let Pair s t = coercionKind co ; if -- forall (both TyVar and CoVar) | Just _ <- splitForAllTyCoVar_maybe s @@ -2604,7 +2548,7 @@ lintCoercion the_co@(SelCo cs co) lintCoercion the_co@(LRCo _lr co) = do { lintCoercion co - ; Pair s t <- substCoKindM co + ; let Pair s t = coercionKind co ; lintRole co Nominal (coercionRole co) ; case (splitAppTy_maybe s, splitAppTy_maybe t) of (Just {}, Just {}) -> return () @@ -2618,14 +2562,12 @@ lintCoercion orig_co@(InstCo co arg) go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) } go co args = do { lintCoercion co ; let Pair lty rty = coercionKind co - ; lty' <- substTyM lty - ; rty' <- substTyM rty ; in_scope <- getInScope ; let subst = mkEmptySubst in_scope - ; go_args (subst, lty') (subst,rty') args } + ; go_args (subst, lty) (subst,rty) args } ------------- - go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion] + go_args :: (Subst, Type) -> (Subst,Type) -> [Coercion] -> LintM () go_args _ _ [] = return () @@ -2634,11 +2576,11 @@ lintCoercion orig_co@(InstCo co arg) ; go_args lty1 rty1 args } ------------- - go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion - -> LintM ((Subst,OutType), (Subst,OutType)) + go_arg :: (Subst, Type) -> (Subst,Type) -> Coercion + -> LintM ((Subst,Type), (Subst,Type)) go_arg (lsubst,lty) (rsubst,rty) arg = do { lintRole arg Nominal (coercionRole arg) - ; Pair arg_lty arg_rty <- substCoKindM arg + ; let Pair arg_lty arg_rty = coercionKind arg ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of -- forall over tvar @@ -2662,11 +2604,11 @@ lintCoercion orig_co@(InstCo co arg) lintCoercion this_co@(AxiomCo ax cos) = do { mapM_ lintCoercion cos ; lint_roles 0 (coAxiomRuleArgRoles ax) cos - ; prs <- mapM substCoKindM cos + ; let prs = map coercionKind cos ; lint_ax ax prs } where - lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM () + lint_ax :: CoAxiomRule -> [Pair Type] -> LintM () lint_ax (BuiltInFamRew bif) prs = checkL (isJust (bifrw_proves bif prs)) bad_bif lint_ax (BuiltInFamInj bif) prs @@ -2754,8 +2696,8 @@ lintBranch this_co fam_tc branch arg_kinds = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $ (bad_ax this_co (text "lengths")) - ; subst <- getSubst - ; let empty_subst = zapSubst subst + ; in_scope <- getInScope + ; let empty_subst = mkEmptySubst in_scope ; _ <- foldlM check_ki (empty_subst, empty_subst) (zip (ktvs ++ cvs) arg_kinds) @@ -2880,12 +2822,12 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches lint_branch :: TyCon -> CoAxBranch -> LintM () lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , cab_lhs = lhs_args, cab_rhs = rhs }) - = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + = lintBinders LambdaBind (tvs ++ cvs) $ do { let lhs = mkTyConApp ax_tc lhs_args ; lintType lhs ; lintType rhs - ; lhs_kind <- substTyM (typeKind lhs) - ; rhs_kind <- substTyM (typeKind rhs) + ; let lhs_kind = typeKind lhs + rhs_kind = typeKind rhs ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ hang (text "Inhomogeneous axiom") 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ @@ -2969,35 +2911,26 @@ type LintLevel = Int -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: Subst - -- Current substitution, for TyCoVars only. - -- Non-CoVar Ids don't appear in here, not even in the InScopeSet - -- Used for (a) cloning to avoid shadowing of TyCoVars, - -- so that eqType works ok - -- (b) substituting for let-bound tyvars, when we have - -- (let @a = Int -> Int in ...) - - , le_level :: LintLevel - , le_in_vars :: VarEnv (InVar, OutType, LintLevel) - -- Maps an InVar (i.e. its unique) to its binding InVar - -- and to its OutType - -- /All/ in-scope variables are here (term variables, - -- type variables, and coercion variables) - -- Used at an occurrence of the InVar + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + , le_level :: LintLevel + , le_in_scope :: InScopeSet + + , le_vars :: VarEnv (Var, LintLevel) + -- Maps a Var (i.e. its unique) to its binding Var and level + -- /All/ in-scope variables are here (term variables, + -- type variables, and coercion variables) + -- So the domain is the same as the le_in_scope in-scope set + -- Used at an occurrence of the Var , le_joins :: UniqMap Id JoinOcc -- ^ Join points in scope that are valid - -- A subset of the InScopeSet in le_subst -- See Note [Join points] , le_ue_aliases :: NameEnv UsageEnv -- See Note [Linting linearity] -- Assigns usage environments to the alias-like binders, -- as found in non-recursive lets. - -- Domain is OutIds , le_platform :: Platform -- ^ Target platform , le_diagOpts :: DiagOpts -- ^ Target platform @@ -3011,7 +2944,8 @@ data LintFlags , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism] , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals] - , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_beta_joins :: Bool -- ^ See Note [Join points and beta-redexes] } -- See Note [Checking StaticPtrs] @@ -3078,20 +3012,6 @@ top-level bindings. See SimplCore Note [Grand plan for static forms]. The linter checks that no occurrence or `makeStatic` occurs nested. -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - Note [Linting type synonym applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When linting a type-synonym, or type-family, application @@ -3353,12 +3273,12 @@ initL cfg m where vars = l_vars cfg init_level = 0 - env = LE { le_flags = l_flags cfg - , le_subst = mkEmptySubst (mkInScopeSetList vars) - , le_level = init_level - , le_in_vars = mkVarEnv [ (v,(v, varType v, init_level)) | v <- vars ] - , le_joins = emptyUniqMap - , le_loc = [] + env = LE { le_flags = l_flags cfg + , le_level = init_level + , le_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ] + , le_in_scope = mkInScopeSetList vars + , le_joins = emptyUniqMap + , le_loc = [] , le_ue_aliases = emptyNameEnv , le_platform = l_platform cfg , le_diagOpts = l_diagOpts cfg @@ -3421,8 +3341,7 @@ addMsg show_context env msgs msg loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first loc_msgs = map dumpLoc (le_loc env) - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] + cxt_doc = vcat $ reverse $ map snd loc_msgs context | show_context = cxt_doc | otherwise = whenPprDebug cxt_doc @@ -3449,72 +3368,44 @@ inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs is_case_pat (LE { le_loc = CasePat {} : _ }) = True is_case_pat _other = False -addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a +addInScopeId :: Id -> LintM a -> LintM a -- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned -addInScopeId in_id out_ty thing_inside +addInScopeId id thing_inside = LintM $ \ env errs -> - let !(out_id, env') = add env - in unLintM (thing_inside out_id) env' errs - + unLintM thing_inside (add env) errs where - add env@(LE { le_level = level, le_in_vars = id_vars, le_joins = valid_joins - , le_ue_aliases = aliases, le_subst = subst }) - = (out_id, env1) + add env@(LE { le_level = level, le_vars = id_vars, le_joins = valid_joins + , le_ue_aliases = aliases, le_in_scope = in_scope }) + = env { le_level = level1, le_vars = in_vars' + , le_in_scope = in_scope `extendInScopeSet` id + , le_joins = valid_joins', le_ue_aliases = aliases' } where level1 = level + 1 - env1 = env { le_level = level1, le_in_vars = in_vars' - , le_joins = valid_joins', le_ue_aliases = aliases' } - in_vars' = extendVarEnv id_vars in_id (in_id, out_ty, level1) - aliases' = delFromNameEnv aliases (idName in_id) + in_vars' = extendVarEnv id_vars id (id, level1) + aliases' = delFromNameEnv aliases (idName id) -- aliases': when shadowing an alias, we need to make sure the -- Id is no longer classified as such. E.g. -- let x = <e1> in case x of x { _DEFAULT -> <e2> } -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. - -- A very tiny optimisation, not sure if it's really worth it - -- Short-cut when the substitution is a no-op - out_id | isEmptyTCvSubst subst = in_id - | otherwise = setIdType in_id out_ty - valid_joins' - | isJoinId out_id = addToUniqMap valid_joins in_id NormalJoinOcc -- Overwrite with new arity - | otherwise = delFromUniqMap valid_joins in_id -- Remove any existing binding + | isJoinId id = addToUniqMap valid_joins id NormalJoinOcc -- Overwrite with new arity + | otherwise = delFromUniqMap valid_joins id -- Remove any existing binding -addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a +addInScopeTyCoVar :: TyCoVar -> LintM a -> LintM a -- This function clones to avoid shadowing of TyCoVars -addInScopeTyCoVar tcv tcv_type thing_inside - = LintM $ \ env@(LE { le_level = level, le_in_vars = in_vars, le_subst = subst }) errs -> - let (tcv', subst') = subst_bndr subst - level' = level + 1 +addInScopeTyCoVar tcv thing_inside + = LintM $ \ env@(LE { le_level = level, le_vars = in_vars + , le_in_scope = in_scope }) errs -> + let level' = level + 1 env' = env { le_level = level' - , le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type, level') - , le_subst = subst' } - in unLintM (thing_inside tcv') env' errs - where - subst_bndr subst - | isEmptyTCvSubst subst -- No change in kind - , not (tcv `elemInScopeSet` in_scope) -- Not already in scope - = -- Do not extend the substitution, just the in-scope set - (if (varType tcv `eqType` tcv_type) then (\x->x) else - pprTrace "addInScopeTyCoVar" ( - vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv) - , text "tcv_type" <+> ppr tcv_type ])) $ - (tcv, subst `extendSubstInScope` tcv) - - -- Clone, and extend the substitution - | let tcv' = uniqAway in_scope (setVarType tcv tcv_type) - = (tcv', extendTCvSubstWithClone subst tcv tcv') - where - in_scope = substInScopeSet subst - -getInVarEnv :: LintM (VarEnv (InId, OutType, LintLevel)) -getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) + , le_in_scope = in_scope `extendInScopeSet` tcv + , le_vars = extendVarEnv in_vars tcv (tcv, level') } + in unLintM thing_inside env' errs -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a -extendTvSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs +getInVarEnv :: LintM (VarEnv (Id, LintLevel)) +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_vars env), errs)) markAllJoinsBad :: LintM a -> LintM a markAllJoinsBad m @@ -3549,54 +3440,42 @@ markAllJoinsBadIf False m = m getValidJoins :: LintM (UniqMap Id JoinOcc) getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) -getSubst :: LintM Subst -getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) - -substTyM :: InType -> LintM OutType --- Apply the substitution to the type --- The substitution is often empty, in which case it is a no-op -substTyM ty - = do { subst <- getSubst - ; return (substTy subst ty) } - getUEAliases :: LintM (NameEnv UsageEnv) getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs)) +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (le_in_scope env), errs)) -lintVarOcc :: InVar -> LintM OutType +lintVarOcc :: Var -> LintM () -- Used at an occurrence of a variable: term variables, type variables, and coercion variables -- Checks -- - that it is in scope -- - that it is not a GlobalId bound by a LocalId --- - that the InType at the ocurrence matches the InType at the binding site +-- - that the Type at the ocurrence matches the Type at the binding site -- - that the variables free in its type are not shadowed at the occurrence site lintVarOcc v_occ | isGlobalId v_occ - = return (idType v_occ) + = return () | otherwise = do { in_var_env <- getInVarEnv ; case lookupVarEnv in_var_env v_occ of Nothing -> failWithL (text pp_what <+> quotes (ppr v_occ) <+> text "is out of scope") - Just (v_bndr, out_ty, bind_level) + Just (v_bndr, bind_level) -> do { let bndr_ty = idType v_bndr ; check_bad_global v_bndr ; check_occ_type_match bndr_ty - ; check_occ_type_scope in_var_env bndr_ty bind_level - ; return out_ty } - + ; check_occ_type_scope in_var_env bndr_ty bind_level } } where - occ_ty :: InType + occ_ty :: Type occ_ty = idType v_occ pp_what | isTyVar v_occ = "The type variable" | isCoVar v_occ = "The coercion variable" | otherwise = "The value variable" - check_bad_global :: InVar -> LintM () + check_bad_global :: Var -> LintM () -- 'check_bad_global' checks for the case where an /occurrence/ is -- a GlobalId, but there is an enclosing binding for a LocalId. -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, @@ -3616,26 +3495,26 @@ lintVarOcc v_occ | otherwise = return () - check_occ_type_match :: InType -> LintM () + check_occ_type_match :: Type -> LintM () -- Check that the type in /binder/ and the type in the /occurrence/ are the same check_occ_type_match bndr_ty - = ensureEqTys bndr_ty occ_ty $ -- Compares InTypes + = ensureEqTys bndr_ty occ_ty $ -- Compares Types mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty - check_occ_type_scope :: VarEnv (InVar,OutType,LintLevel) -> InType -> LintLevel -> LintM () + check_occ_type_scope :: VarEnv (Var,LintLevel) -> Type -> LintLevel -> LintM () -- Check that the free vars of the binder's type -- are not shadowed at the occurrence site check_occ_type_scope in_var_env bndr_ty bind_level = checkL (null bad_fvs) $ mkBndrOccFreeVarMsg v_occ occ_ty bad_fvs where - bad_fvs :: [InVar] + bad_fvs :: [Var] bad_fvs = filter is_bad (tyCoVarsOfTypeList bndr_ty) - is_bad :: InVar -> Bool + is_bad :: Var -> Bool -- True of a variable bound inside bind_level is_bad v = case lookupVarEnv in_var_env v of - Just (_, _, v_level) -> v_level > bind_level + Just (_, v_level) -> v_level > bind_level Nothing -> True lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc)) @@ -3647,21 +3526,21 @@ lookupJoinId id Just join_occ -> return $ Just (idJoinArity id, join_occ) Nothing -> return Nothing } -addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a addAliasUE id ue thing_inside = LintM $ \ env errs -> let new_ue_aliases = extendNameEnv (le_ue_aliases env) (getName id) ue in unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs -varCallSiteUsage :: OutId -> LintM UsageEnv +varCallSiteUsage :: Id -> LintM UsageEnv varCallSiteUsage id = do m <- getUEAliases return $ case lookupNameEnv m (getName id) of Nothing -> singleUsageUE id Just id_ue -> id_ue -ensureEqTys :: OutType -> OutType -> SDoc -> LintM () +ensureEqTys :: Type -> Type -> SDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied @@ -3885,7 +3764,7 @@ mkLetErr bndr rhs hang (text "Rhs:") 4 (ppr rhs)] -mkTyAppMsg :: OutType -> Type -> SDoc +mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (text "Function type:") @@ -4006,13 +3885,13 @@ mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ , text "Arity at binding site:" <+> ppr join_arity_bndr , text "Arity at occurrence: " <+> ppr join_arity_occ ] -mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc +mkBndrOccTypeMismatchMsg :: Var -> Type -> Type -> SDoc mkBndrOccTypeMismatchMsg var bndr_ty occ_ty = vcat [ text "Mismatch in type between binder and occurrence" , text "Binder: " <+> ppr var <+> dcolon <+> ppr bndr_ty , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] -mkBndrOccFreeVarMsg :: InVar -> InType -> [TyCoVar] -> SDoc +mkBndrOccFreeVarMsg :: Var -> Type -> [TyCoVar] -> SDoc mkBndrOccFreeVarMsg var occ_ty bad_tvs = vcat [ text "Free vars of type are shadowed:" <+> ppr bad_tvs , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] ===================================== compiler/GHC/Core/Lint/SubstTypeLets.hs ===================================== @@ -0,0 +1,140 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +module GHC.Core.Lint.SubstTypeLets( + substTypeLets + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils( mkInScopeSetBndrs ) + +import GHC.Types.Var + +import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- Note [Substituting type-lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When desugaring pattern matching we really, really need non-Lint-acceptable type-lets. +Suppose we have + f (MkT a (Just a (x::a)) (y::a)) = rhs1 + f (MkT b (Nothing b) (z::b)) = rhs2 +where + MkT :: ∀ a. Maybe a -> a -> T + +We desugar this to + f x = case x of + MkT w (v :: Maybe w) (p:w) + -> let { a=w, b=w } + in let { y:a=p, z:b=p } + in case v of + Just a (x:a) -> rhs1 [y::a] + Nothing b -> rhs2 [z::b] + +Look at those type-lets { a=w, b=w }. They make the type variables in the +/two/ separately-typechecked clauses for `f` line up with the /single/ pattern +match on `x`, which binds the type variable `w`. + +Key point: the body of the let is only type-correct /after/ substituting +a:=w, b:=w. Even the next let, { y:a=p } isn't type-correct without that +substitution, because (p:w). + +So the `substTypeLets` pass does this: + - It runs as part of Lint, as a pre-pass before the main Lint + - It runs only when we are Linting the output of the desugarer + - The result of substTypeLets is discarded after linting + +When it finds a nested type-let + let @a = ty in body +it substitutes a:=ty in `body` + +Wrinkles + +(STL1) It only substitutes /nested/ type-lets, not top level. + +(STL2) You might think that we'd run it unconditionally, after desugaring. But actually, + the Simplifier (or SimpleOpt) will deal with these type-lets, so it is just Lint + that we must placate. We don't want to incur the cost of this pass except when + we are Linting. + + TL;DR: we do substTypeLets as a pre-pass to the Lint pass that immediately follows + desugaring. See `GHC.Core.lintPassResult`, and the `lpr_preSubst` field in + `LintPassResultConfig`. + +(STL3) Should `substTypeLets` process (stable) unfoldings? It does not need to + because all unfoldings have `simpleOptExpr` applied to them, so the tricky + type-lets will already be substituted. + + Of course we stil need to apply the current substitution, but that is done + automatically by `substBndr`. +-} + +substTypeLets :: CoreProgram -> CoreProgram +substTypeLets binds = map stl_top binds + where + stl_top (NonRec b r) = NonRec b (stlExpr empty_subst r) + stl_top (Rec prs) = Rec (mapSnd (stlExpr empty_subst) prs) + + empty_subst = mkEmptySubst $ + mkInScopeSetBndrs binds + +---------------------- +stlBind :: Subst -> CoreBind -> (Subst, CoreBind) +stlBind subst (Rec prs) + = assertPpr (not (any isTyVar bndrs)) (ppr prs) $ + (subst', Rec prs') + where + (bndrs,rhss) = unzip prs + (subst', bndrs') = substRecBndrs subst bndrs + -- substRecBndrs: see (STL3) in Note [Substituting type-lets] + rhss' = map (stlExpr subst') rhss + prs' = bndrs' `zip` rhss' + +stlBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (stlExpr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + -- substBndr: see (STL3) in Note [Substituting type-lets] + +---------------------- +stlExpr :: Subst -> CoreExpr -> CoreExpr + +stlExpr subst (Let (NonRec tv (Type ty)) body) + = -- This equation is the main payload of the entire pass! + stlExpr (extendTvSubst subst tv (substTy subst ty)) body + +stlExpr subst (Let bind body) + = Let bind' (stlExpr subst' body) + where + (subst', bind') = stlBind subst bind + +stlExpr subst (Lam bndr body) + = Lam bndr' (stlExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + +stlExpr subst (Case scrut bndr ty alts) + = Case (stlExpr subst scrut) bndr' (substTy subst ty) + (map stl_alt alts) + where + (subst', bndr') = substBndr subst bndr + + stl_alt (Alt con bndrs rhs) + = Alt con bndrs' (stlExpr subst'' rhs) + where + (subst'', bndrs') = substBndrs subst' bndrs + +-- Simple cases +stlExpr _ (Lit l) = Lit l +stlExpr subst (Var v) = lookupIdSubst subst v +stlExpr subst (App e1 e2) = App (stlExpr subst e1) (stlExpr subst e2) +stlExpr subst (Type ty) = Type (substTy subst ty) +stlExpr subst (Tick t e) = Tick (substTickish subst t) (stlExpr subst e) +stlExpr subst (Cast e co) = Cast (stlExpr subst e) (substCo subst co) +stlExpr subst (Coercion co) = Coercion (substCo subst co) ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2676,6 +2676,8 @@ occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> WithUsageDetails CoreExpr -- The `fun` argument is just an accumulating parameter, -- the base for building the application we return +-- +-- We have applied markAllNonTail to the returned usage-details occAnalArgs env fun args one_shots = go emptyDetails fun args one_shots where @@ -2686,7 +2688,9 @@ occAnalArgs env fun args one_shots encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut | otherwise = OccVanilla - go uds fun [] _ = WUD uds fun + go uds fun [] _ = WUD (markAllNonTail uds) fun + -- markAllNonTail: calls in arguments are not tail calls! + go uds fun (arg:args) one_shots = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots' where @@ -2778,8 +2782,7 @@ occAnalApp env (Var fun_id, args, ticks) all_uds = fun_uds `andUDs` final_args_uds - !final_args_uds = markAllNonTail $ - markAllInsideLamIf (isRhsEnv env && is_exp) $ + !final_args_uds = markAllInsideLamIf (isRhsEnv env && is_exp) $ -- isRhsEnv: see Note [OccEncl] args_uds -- We mark the free vars of the argument of a constructor or PAP @@ -2809,20 +2812,27 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = let app_out = mkTicks ticks app' - in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out - + = WUD (fun_uds `andUDs` args_uds) (mkTicks ticks app') where !(WUD args_uds app') = occAnalArgs env fun' args [] - !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexes like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some OneShotLam items - -- onto the context stack. + !(WUD fun_uds fun') = go_fun env fun args + + -- See (A2) in Note [occAnal for applications] + go_fun env (Lam bndr body) (_ : args) + = addInScopeOne env bndr $ \ env' -> + let !(WUD body_uds body') = go_fun env' body args + !bndr' = tagLamBinder body_uds bndr + in WUD body_uds (Lam bndr' body') + go_fun env fun args + | null args + = occAnal env fun + | otherwise + = let !env' = addAppCtxt env args + !(WUD fun_uds fun') = occAnal env' fun + in WUD (markAllNonTail fun_uds) fun' addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +-- See (A3) in Note [occAnal for applications] addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args | n_val_args > 0 = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt @@ -2834,8 +2844,40 @@ addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args where n_val_args = valArgCount args +{- Note [occAnal for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One iteration of the simplifier sometimes leaves behind beta redexes like + (\x y -> e) a1 a2 +This happens particularly in worker/wrapper; see Note [Join points and beta-redexes] +in GHC.Core.Lint. In these cases there are three things we want to take care of +in the occurrence analyser: + +(A1) We don't want to mark variables inside `e` as `InsideLam`; that would just + delay inlining them for another iteration of the Simplifier. + +(A2) If there is a join-point invocation inside `e`, we don't want to complain about + lost join points. See Note [Join points and beta-redexes] in GHC.Core.Lint for + more detail. + +(A3) Suppose we have something like + (case e of (a,b) -> (\x.blah) |> co) arg + which can happen during 'gentle' simplification when we don't do case-of-case, + not push arguments into cases. Then we'd still like to mark that lambda + as one-shot, so that things can get inlined inside it. We can to this + by pushing OneShotLam items onto the context stack. + + Live example: `read_tup4` in test CoOpt_Read. + +How we address these: + +* (A2): we focus narrowly on visible beta-redexes ((\x.e) arg), since that + is what is needed for Note [Join points and beta-redexes]. We do this + via the `go_fun` loop in `occAnalApp`. + +* (A1) and (A3): for visible beta-redexes, the `go_fun` loop does the job. + But for less-visible ones, like in (A3) we push `OneShotLam` items onto + the context stack, in `addAppCtxt`. -{- Note [Sources of one-shot information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The occurrence analyser obtains one-shot-lambda information from two sources: ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -241,10 +241,10 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr = (work_args, work_args, work_marks) call_work work_fn = mkVarApps (Var work_fn) work_call_args - call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args - -- See Note [Join points and beta-redexes] + call_rhs fn_rhs = mkApps fn_rhs fn_args + -- See Note [Join points and beta-redexes] in GHC.Core.Lint wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work - -- See Note [Call-by-value for worker args] + -- See Note [Call-by-value for worker args] work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] @@ -280,14 +280,6 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr arity_ok | isJoinId fun_id = ww_arity <= n_dmds | otherwise = ww_arity == n_dmds --- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. --- PRECONDITION: The arg expressions are not free in any of the lambdas binders. -mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr --- The precondition holds for our call site in mkWwBodies, because all the FVs --- of as are either cloned_arg_vars (and thus fresh) or fresh worker args. -mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as -mkAppsBeta f as = mkApps f as - -- See Note [Limit w/w arity] isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool isWorkerSmallEnough max_worker_args old_n_args vars @@ -525,36 +517,6 @@ Solution is simple: put the void argument /last/: c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr -Note [Join points and beta-redexes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, the worker would invoke the original function by calling it with -arguments, thus producing a beta-redex for the simplifier to munch away: - - \x y z -> e => (\x y z -> e) wx wy wz - -Now that we have special rules about join points, however, this is Not Good if -the original function is itself a join point, as then it may contain invocations -of other join points: - - join j1 x = ... - join j2 y = if y == 0 then 0 else j1 y - - => - - join j1 x = ... - join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy - join j2 y = case y of I# y# -> jump $wj2 y# - -There can't be an intervening lambda between a join point's declaration and its -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: - - ... - let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y - ... - -Hence we simply do the beta-reduction here. (This would be harder if we had to -worry about hygiene, but luckily wy is freshly generated.) - Note [Freshen WW arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we do a worker/wrapper split, we must freshen the arg vars of the original ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -13,7 +13,8 @@ module GHC.Core.Subst ( -- ** Substituting into expressions and related types deShadowBinds, substRuleInfo, substRulesForImportedIds, - substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, + substTy, substTyUnchecked, substCo, + substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, @@ -42,8 +43,7 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils - -- We are defining local versions -import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Type import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr ) import GHC.Core.TyCo.FVs ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -1,7 +1,6 @@ module GHC.Driver.Config.Core.Lint ( endPass , endPassHscEnvIO - , lintCoreBindings , initEndPassConfig , initLintPassResultConfig , initLintConfig @@ -50,16 +49,6 @@ endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules binds rules } --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs -lintCoreBindings dflags coreToDo vars -- binds - = lintCoreBindings' $ LintConfig - { l_diagOpts = initDiagOpts dflags - , l_platform = targetPlatform dflags - , l_flags = perPassFlags dflags coreToDo - , l_vars = vars - } - initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) @@ -104,10 +93,17 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig { lpr_diagOpts = initDiagOpts dflags , lpr_platform = targetPlatform dflags , lpr_makeLintFlags = perPassFlags dflags pass - , lpr_passPpr = ppr pass + , lpr_passPpr = ppr pass + , lpr_preSubst = doPreSubst pass , lpr_localsInScope = extra_vars } +doPreSubst :: CoreToDo -> Bool +doPreSubst CoreDesugar = True -- Output of desugarer, /before/ running any optimisation, + -- not even simpleOpt. See Note Note [Substituting type-lets] + -- in GHC.Core.SubstTypeLets +doPreSubst _ = False + perPassFlags :: DynFlags -> CoreToDo -> LintFlags perPassFlags dflags pass = (defaultLintFlags dflags) @@ -116,7 +112,8 @@ perPassFlags dflags pass , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity , lf_check_rubbish_lits = check_rubbish - , lf_allow_weak_joins = allow_weak_joins } + , lf_allow_weak_joins = allow_weak_joins + , lf_allow_beta_joins = allow_beta_joins } where -- See Note [Checking for global Ids] check_globals = case pass of @@ -158,6 +155,11 @@ perPassFlags dflags pass CorePrep -> True _ -> False + -- See Note [Join points and beta-redexes] in GHC.Core.Lint + allow_beta_joins = case pass of + CoreDoWorkerWrapper -> True + _ -> False + initLintConfig :: DynFlags -> [Var] -> LintConfig initLintConfig dflags vars =LintConfig { l_diagOpts = initDiagOpts dflags @@ -175,4 +177,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False , lf_check_fixed_rep = True , lf_check_rubbish_lits = True , lf_allow_weak_joins = False + , lf_allow_beta_joins = False } ===================================== compiler/ghc.cabal.in ===================================== @@ -361,6 +361,7 @@ Library GHC.Core.InstEnv GHC.Core.Lint GHC.Core.Lint.Interactive + GHC.Core.Lint.SubstTypeLets GHC.Core.LateCC GHC.Core.LateCC.Types GHC.Core.LateCC.TopLevelBinds ===================================== testsuite/tests/corelint/LintEtaExpand.stderr ===================================== @@ -1,32 +1,16 @@ <no location info>: warning: • The first argument of ‘coerce’ does not have a fixed runtime representation: a :: TYPE k - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in coerce BAD 1 <no location info>: warning: • The first argument of ‘coerce’ does not have a fixed runtime representation: ‘q’ is not concrete. - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in coerce BAD 2 <no location info>: warning: • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation: a :: TYPE q - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in catch# BAD 1 <no location info>: warning: • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation: ‘q’ is not concrete. - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in catch# BAD 2 ===================================== testsuite/tests/corelint/T21115b.stderr ===================================== @@ -6,10 +6,6 @@ T21115b.hs:9:1: warning: In the body of lambda with binder ds :: Double# In the body of a let with binder fail :: (# #) -> Int# In the body of a let with binder fail :: (# #) -> Int# - Substitution: <InScope = {} - IdSubst = [] - TvSubst = [] - CvSubst = []> *** Offending Program *** Rec { $trModule = Module (TrNameS "main"#) (TrNameS "T21115b"#) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78434e8c5297ed5bf2bce9a81f09e21… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78434e8c5297ed5bf2bce9a81f09e21… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Marge Bot (＠marge-bot) 18 Apr '26

18 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 9 changed files: - + changelog.d/ghc-pkg-long-path-support - compiler/GHC/Unit/State.hs - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in Changes: ===================================== changelog.d/ghc-pkg-long-path-support ===================================== @@ -0,0 +1,15 @@ +section: ghc-pkg +synopsis: Improve ``ghc-pkg``'s support for long paths on windows. +issues: #26960 +mrs: !15584 + +description: { + ``ghc-pkg`` can't handle working with file paths longer than the MAX_PATH + restrictions on windows as it is not using UNC file paths by default. + + By using UNC file paths whenever possible, we improve ``ghc-pkg`` on windows. + Note, this still requires the user to enable the use of long paths in order to opt-in + this behaviour on older windows machines. +} + + ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -802,7 +802,7 @@ readUnitDatabase logger cfg conf_file = do if cache_exists then do debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) + readPackageDbForGhc filename else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -68,6 +68,8 @@ module GHC.Unit.Database -- * Misc , mkMungePathUrl , mungeUnitInfoPaths + , writeFileAtomic + , unsafeDecodeUtf ) where @@ -86,18 +88,23 @@ import Data.Binary.Get as Bin import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) -import System.FilePath as FilePath +import qualified System.FilePath as FilePath #if !defined(mingw32_HOST_OS) import Data.Bits ((.|.)) -import System.Posix.Files +import System.Posix.Files.PosixString import System.Posix.Types (FileMode) +import System.OsString.Internal.Types (getOsString) #endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) import qualified GHC.Data.ShortText as ST import GHC.IO.Handle.Lock -import System.Directory +import GHC.Stack.Types (HasCallStack) +import System.OsPath +import qualified System.Directory.OsPath as OsPath +import qualified System.Directory.Internal as OsPath.Internal +import qualified System.File.OsPath as FileIO -- | @ghc-boot@'s UnitInfo, serialized to the database. type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule @@ -314,13 +321,13 @@ data DbInstUnitId newtype PackageDbLock = PackageDbLock Handle -- | Acquire an exclusive lock related to package DB under given location. -lockPackageDb :: FilePath -> IO PackageDbLock +lockPackageDb :: OsPath -> IO PackageDbLock -- | Release the lock related to package DB. unlockPackageDb :: PackageDbLock -> IO () -- | Acquire a lock of given type related to package DB under given location. -lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock +lockPackageDbWith :: LockMode -> OsPath -> IO PackageDbLock lockPackageDbWith mode file = do -- We are trying to open the lock file and then lock it. Thus the lock file -- needs to either exist or we need to be able to create it. Ideally we @@ -350,10 +357,10 @@ lockPackageDbWith mode file = do (lockFileOpenIn ReadWriteMode) (const $ lockFileOpenIn ReadMode) where - lock = file <.> "lock" + lock = file <.> OsPath.Internal.os "lock" lockFileOpenIn io_mode = bracketOnError - (openBinaryFile lock io_mode) + (FileIO.openBinaryFile lock io_mode) hClose -- If file locking support is not available, ignore the error and proceed -- normally. Without it the only thing we lose on non-Windows platforms is @@ -387,7 +394,7 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] +readPackageDbForGhc :: OsPath -> IO [DbUnitInfo] readPackageDbForGhc file = decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case (pkgs, DbOpenReadOnly) -> return pkgs @@ -409,7 +416,7 @@ readPackageDbForGhc file = -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> +readPackageDbForGhcPkg :: Binary pkgs => OsPath -> DbOpenMode mode t -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg @@ -425,7 +432,7 @@ readPackageDbForGhcPkg file mode = -- | Write the whole of the package DB, both parts. -- -writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO () +writePackageDb :: Binary pkgs => OsPath -> [DbUnitInfo] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = do writeFileAtomic file (runPut putDbForGhcPkg) #if !defined(mingw32_HOST_OS) @@ -446,10 +453,10 @@ writePackageDb file ghcPkgs ghcPkgPart = do ghcPart = encode ghcPkgs #if !defined(mingw32_HOST_OS) -addFileMode :: FilePath -> FileMode -> IO () +addFileMode :: OsPath -> FileMode -> IO () addFileMode file m = do - o <- fileMode <$> getFileStatus file - setFileMode file (m .|. o) + o <- fileMode <$> getFileStatus (getOsString file) + setFileMode (getOsString file) (m .|. o) #endif getHeader :: Get (Word32, Word32) @@ -496,7 +503,7 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0" -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> +decodeFromFile :: OsPath -> DbOpenMode mode t -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do @@ -517,7 +524,7 @@ decodeFromFile file mode decoder = case mode of bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do (, DbOpenReadWrite lock) <$> decodeFileContents where - decodeFileContents = withBinaryFile file ReadMode $ \hnd -> + decodeFileContents = FileIO.withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize @@ -527,21 +534,21 @@ decodeFromFile file mode decoder = case mode of feed _ (Done _ _ res) = return res feed _ (Fail _ _ msg) = ioError err where - err = mkIOError InappropriateType loc Nothing (Just file) + err = mkIOError InappropriateType loc Nothing (Just $ unsafeDecodeUtf file) `ioeSetErrorString` msg loc = "GHC.Unit.Database.readPackageDb" -- Copied from Cabal's Distribution.Simple.Utils. -writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () +writeFileAtomic :: OsPath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> OsPath.Internal.os "tmp") + (\(tmpPath, handle) -> hClose handle >> OsPath.removeFile tmpPath) (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle - renameFile tmpPath targetPath) + OsPath.renameFile tmpPath targetPath) instance Binary DbUnitInfo where put (GenericUnitInfo @@ -711,7 +718,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case ST.stripPrefix var path of Just "" -> Just "" - Just cs | isPathSeparator (ST.head cs) -> Just cs + Just cs | FilePath.isPathSeparator (ST.head cs) -> Just cs _ -> Nothing @@ -742,3 +749,8 @@ mungeUnitInfoPaths top_dir pkgroot pkg = munge_paths = map munge_path munge_urls = map munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf = OsPath.Internal.so ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -82,6 +82,8 @@ Library containers >= 0.5 && < 0.9, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.6, + file-io >= 0.1.6 && < 0.3, + os-string >= 2.0.1 && < 2.1, deepseq >= 1.4 && < 1.6, ghc-platform >= 0.1, ghc-toolchain >= 0.1 ===================================== testsuite/tests/cabal/Makefile ===================================== @@ -79,6 +79,25 @@ ghcpkg04 : @: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now '$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true +PKGCONF20=local20.package.conf +LOCAL_GHC_PKG20 = '$(GHC_PKG)' --no-user-package-db + +DIR1=asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf +DIR2=zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv +DIR3=uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop +DIR4=qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer +WDIR=$(DIR1)/$(DIR2)/$(DIR3)/$(DIR4) +.PHONY: ghcpkg10 +ghcpkg10 : + @mkdir -p $(WDIR) + @rm -rf $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) init $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) list + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) register --force test.pkg 2>/dev/null + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg-1.2.3.4 | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) field testpkg-1.2.3.4 import-dirs + # Test stacking of package.confs (also #2441) PKGCONF05a=local05a.package.conf PKGCONF05b=local05b.package.conf ===================================== testsuite/tests/cabal/all.T ===================================== @@ -5,6 +5,7 @@ def ignore_warnings(str): return re.sub(r'Warning:.*\n', '', str) test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) +test('ghcpkg10', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO): # warning: haddock-interfaces .. doesn't exist or isn't a file ===================================== testsuite/tests/cabal/ghcpkg10.stdout ===================================== @@ -0,0 +1,50 @@ +asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf/zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv/uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop/qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer/local20.package.conf + (no packages) +Reading package info from "test.pkg" ... done. +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -47,12 +47,19 @@ import Distribution.Types.UnqualComponentName import Distribution.Types.LibraryName import Distribution.Types.MungedPackageName import Distribution.Types.MungedPackageId -import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File) +import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS) import qualified Data.Version as Version -import System.FilePath as FilePath +import System.OsPath as OsPath +import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, - getModificationTime, XdgDirectory ( XdgData ) ) +import System.Directory.OsPath + ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, + getModificationTime, XdgDirectory ( XdgData ), + doesDirectoryExist, getDirectoryContents, + doesFileExist, removeFile, + getCurrentDirectory ) +import System.Directory.Internal (os) +import qualified System.File.OsPath as FileIO import Text.Printf import Prelude hiding (Foldable(..)) @@ -65,15 +72,13 @@ import Data.Bifunctor import Data.Char ( toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, removeFile, - getCurrentDirectory ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error -import GHC.IO ( catchException ) +import GHC.IO ( catchException, unsafePerformIO ) import GHC.IO.Exception (IOErrorType(InappropriateType)) +import GHC.Stack.Types (HasCallStack) import Data.List ( group, sort, sortBy, nub, partition, find , intercalate, intersperse, unfoldr , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix ) @@ -429,8 +434,9 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif - ["init", filename] -> - initPackageDB filename verbosity cli + ["init", filename] -> do + filenameOs <- encodeFS filename + initPackageDB filenameOs verbosity cli ["register", filename] -> registerPackage filename verbosity cli multi_instance @@ -538,7 +544,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str data PackageDB (mode :: GhcPkg.DbMode) = PackageDB { - location, locationAbsolute :: !FilePath, + location, locationAbsolute :: !OsPath, -- We need both possibly-relative and definitely-absolute package -- db locations. This is because the relative location is used as -- an identifier for the db, so it is important we do not modify it. @@ -570,14 +576,14 @@ allPackagesInStack = concatMap packages -- specified package DB can depend on, since dependencies can only extend -- down the stack, not up (e.g. global packages cannot depend on user -- packages). -stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack +stackUpTo :: OsPath -> PackageDBStack -> PackageDBStack stackUpTo to_modify = dropWhile ((/= to_modify) . location) -readFromSettingsFile :: FilePath - -> (FilePath -> RawSettings -> Either String b) +readFromSettingsFile :: OsPath + -> (OsPath -> RawSettings -> Either String b) -> IO (Either String b) readFromSettingsFile settingsFile f = do - settingsStr <- readFile settingsFile + settingsStr <- readUtf8File settingsFile pure $ do mySettings <- case maybeReadFuzzy settingsStr of Just s -> pure $ Map.fromList s @@ -586,11 +592,11 @@ readFromSettingsFile settingsFile f = do Nothing -> Left $ "Can't parse settings file " ++ show settingsFile f settingsFile mySettings -readFromTargetFile :: FilePath +readFromTargetFile :: OsPath -> (Target -> b) -> IO (Either String b) readFromTargetFile targetFile f = do - targetStr <- readFile targetFile + targetStr <- readUtf8File targetFile pure $ do target <- case maybeReadFuzzy targetStr of Just t -> Right t @@ -626,33 +632,35 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do case [ f | FlagGlobalConfig f <- my_flags ] of -- See Note [Base Dir] for more information on the base dir / top dir. [] -> do mb_dir <- getBaseDir - case mb_dir of + mb_dir_os <- traverse encodeFS mb_dir + case mb_dir_os of Nothing -> die err_msg Just dir -> do -- Look for where it is given in the settings file, if marked there. -- See Note [Settings file] about this file, and why we need GHC to share it with us. - let settingsFile = dir </> "settings" + let settingsFile = dir </> os "settings" exists_settings_file <- doesFileExist settingsFile erel_db <- if exists_settings_file - then readFromSettingsFile settingsFile getGlobalPackageDb - else pure (Left ("Settings file doesn't exist: " ++ settingsFile)) + then do + readFromSettingsFile settingsFile (\ settings -> getGlobalPackageDb (unsafeDecodeUtf settings)) + else pure (Left ("Settings file doesn't exist: " ++ showOsPath settingsFile)) case erel_db of - Right rel_db -> return (dir, dir </> rel_db) + Right rel_db -> return (dir, dir </> unsafeEncodeUtf rel_db) -- If the version of GHC doesn't have this field or the settings file -- doesn't exist for some reason, look in the libdir. Left err -> do r <- lookForPackageDBIn dir case r of - Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)]) + Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ showOsPath dir)]) Just path -> return (dir, path) fs -> do -- The value of the $topdir variable used in some package descriptions -- Note that the way we calculate this is slightly different to how it -- is done in ghc itself. We rely on the convention that the global -- package db lives in ghc's libdir. - let pkg_db = last fs + let pkg_db = unsafeEncodeUtf $ last fs top_dir <- absolutePath (takeDirectory pkg_db) return (top_dir, pkg_db) @@ -662,10 +670,10 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- getXdgDirectory can fail (e.g. if $HOME isn't set) mb_user_conf <- - case [ f | FlagUserConfig f <- my_flags ] of + case [ unsafeEncodeUtf f | FlagUserConfig f <- my_flags ] of _ | no_user_db -> return Nothing [] -> do - let targetFile = top_dir </> "targets" </> "default.target" + let targetFile = top_dir </> os "targets" </> os "default.target" exists_settings_file <- doesFileExist targetFile targetArchOS <- case exists_settings_file of False -> do @@ -694,15 +702,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR -- -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version - m_appdir <- getFirstSuccess $ map (fmap (</> subdir)) - [ getAppUserDataDirectory "ghc" -- this is ~/.ghc/ - , getXdgDirectory XdgData "ghc" -- this is $XDG_DATA_HOME/ + m_appdir <- getFirstSuccess $ map (fmap (</> unsafeEncodeUtf subdir)) + [ getAppUserDataDirectory $ os "ghc" -- this is ~/.ghc/ + , getXdgDirectory XdgData $ os "ghc" -- this is $XDG_DATA_HOME/ ] case m_appdir of Nothing -> return Nothing Just dir -> do lookForPackageDBIn dir >>= \case - Nothing -> return (Just (dir </> "package.conf.d", False)) + Nothing -> return (Just (dir </> os "package.conf.d", False)) Just f -> return (Just (f, True)) fs -> return (Just (last fs, True)) @@ -716,11 +724,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = - case e_pkg_path of + case fmap unsafeEncodeUtf e_pkg_path of Left _ -> sys_databases Right path - | not (null path) && isSearchPathSeparator (last path) - -> splitSearchPath (init path) ++ sys_databases + | hasTrailingPathSeparator path + -> splitSearchPath (dropTrailingPathSeparator path) <> sys_databases | otherwise -> splitSearchPath path @@ -733,7 +741,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf - is_db_flag (FlagConfig f) = Just f + is_db_flag (FlagConfig f) = Just $ unsafeEncodeUtf f is_db_flag _ = Nothing let flag_db_names | null db_flags = env_stack @@ -748,7 +756,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- stack, unless any of them are present in the stack -- already. let final_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] + [ unsafeEncodeUtf f | FlagConfig f <- reverse my_flags ] ++ env_stack top_db = if null db_flags @@ -764,7 +772,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do when (verbosity > Normal) $ do infoLn ("db stack: " ++ show (map location db_stack)) F.forM_ db_to_operate_on $ \db -> - infoLn ("modifying: " ++ (location db)) + infoLn ("modifying: " ++ showOsPath (location db)) infoLn ("flag db stack: " ++ show (map location flag_db_stack)) return (db_stack, db_to_operate_on, flag_db_stack) @@ -843,17 +851,19 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do return (db_stack, GhcPkg.DbOpenReadWrite to_modify) where - couldntOpenDbForModification :: FilePath -> IOError -> IO a + couldntOpenDbForModification :: OsPath -> IOError -> IO a couldntOpenDbForModification db_path e = die $ "Couldn't open database " - ++ db_path ++ " for modification: " ++ show e + ++ showOsPath db_path ++ " for modification: " ++ show e -- Parse package db in read-only mode. - readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly) + readDatabase :: OsPath -> IO (PackageDB 'GhcPkg.DbReadOnly) readDatabase db_path = do db <- readParseDatabase verbosity mb_user_conf GhcPkg.DbOpenReadOnly use_cache db_path if expand_vars - then return $ mungePackageDBPaths top_dir db + then do + top_dir_filepath <- decodeFS top_dir + return $ mungePackageDBPaths top_dir_filepath db else return db stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) @@ -863,20 +873,20 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do (as, s'') <- stateSequence s' ms return (a : as, s'') -lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn :: OsPath -> IO (Maybe OsPath) lookForPackageDBIn dir = do - let path_dir = dir </> "package.conf.d" + let path_dir = dir </> os "package.conf.d" exists_dir <- doesDirectoryExist path_dir if exists_dir then return (Just path_dir) else do - let path_file = dir </> "package.conf" + let path_file = dir </> os "package.conf" exists_file <- doesFileExist path_file if exists_file then return (Just path_file) else return Nothing readParseDatabase :: forall mode t. Verbosity - -> Maybe (FilePath,Bool) + -> Maybe (OsPath,Bool) -> GhcPkg.DbOpenMode mode t -> Bool -- use cache - -> FilePath + -> OsPath -> IO (PackageDB mode) readParseDatabase verbosity mb_user_conf mode use_cache path -- the user database (only) is allowed to be non-existent @@ -898,7 +908,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path Just db -> return db Nothing -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath path ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." | otherwise -> ioError err @@ -914,7 +924,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path -- It's fine if the cache is not there as long as the -- database is empty. when (not $ null confs) $ do - warn ("WARNING: cache does not exist: " ++ cache) + warn ("WARNING: cache does not exist: " ++ showOsPath cache) warn ("ghc will fail to read this package db. " ++ recacheAdvice) else do @@ -923,7 +933,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path ignore_cache (const $ return ()) Right tcache -> do when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + warn ("Timestamp " ++ show tcache ++ " for " ++ showOsPath cache) -- If any of the .conf files is newer than package.cache, we -- assume that cache is out of date. cache_outdated <- (`anyM` confs) $ \conf -> @@ -931,12 +941,12 @@ readParseDatabase verbosity mb_user_conf mode use_cache path if not cache_outdated then do when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) + infoLn ("using cache: " ++ showOsPath cache) GhcPkg.readPackageDbForGhcPkg cache mode >>= uncurry mkPackageDB else do whenReportCacheErrors $ do - warn ("WARNING: cache is out of date: " ++ cache) + warn ("WARNING: cache is out of date: " ++ showOsPath cache) warn ("ghc will see an old view of this " ++ "package db. " ++ recacheAdvice) ignore_cache $ \file -> do @@ -947,11 +957,11 @@ readParseDatabase verbosity mb_user_conf mode use_cache path GT -> " (older than cache)" EQ -> " (same as cache)" warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) + ++ " for " ++ showOsPath file ++ rel) where - confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs + confs = map (path </>) $ filter (os ".conf" `OsPath.isExtensionOf`) fs - ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) + ignore_cache :: (OsPath -> IO ()) -> IO (PackageDB mode) ignore_cache checkTime = do -- If we're opening for modification, we need to acquire a -- lock even if we don't open the cache now, because we are @@ -987,17 +997,18 @@ readParseDatabase verbosity mb_user_conf mode use_cache path packages = pkgs } -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf :: Verbosity -> OsPath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do - when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) - BS.readFile file >>= fmap fst . parsePackageInfo + when (verbosity > Normal) $ infoLn ("reading package config: " ++ showOsPath file) + FileIO.readFile file >>= fmap fst . parsePackageInfo . BS.toStrict + -cachefilename :: FilePath -cachefilename = "package.cache" +cachefilename :: OsPath +cachefilename = os "package.cache" mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = - db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + db { packages = map (mungePackagePaths top_dir (unsafeDecodeUtf pkgroot)) pkgs } where pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db) -- It so happens that for both styles of package db ("package.conf" @@ -1044,12 +1055,13 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p + toUrlPath :: FilePath -> FilePath -> FilePath toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : -- We need to drop a leading "/" or "\\" -- if there is one: - dropWhile (all isPathSeparator) + dropWhile (all FilePath.isPathSeparator) (FilePath.splitDirectories p)) -- We could drop the separator here, and then use </> above. However, @@ -1057,7 +1069,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case stripPrefix var path of Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs + Just cs@(c : _) | FilePath.isPathSeparator c -> Just cs _ -> Nothing -- ----------------------------------------------------------------------------- @@ -1074,18 +1086,18 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- ghc itself also cooperates in this workaround -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) - -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath +tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (OsPath, Bool) + -> GhcPkg.DbOpenMode mode t -> Bool -> OsPath -> IO (Maybe (PackageDB mode)) tryReadParseOldFileStyleDatabase verbosity mb_user_conf mode use_cache path = do -- assumes we've already established that path exists and is not a dir - content <- readFile path `catchIO` \_ -> return "" + content <- readUtf8File path `catchIO` \_ -> return "" if take 2 content == "[]" then do path_abs <- absolutePath path let path_dir = adjustOldDatabasePath path - warn $ "Warning: ignoring old file-style db and trying " ++ path_dir + warn $ "Warning: ignoring old file-style db and trying " ++ showOsPath path_dir direxists <- doesDirectoryExist path_dir if direxists then do @@ -1112,7 +1124,7 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) adjustOldFileStylePackageDB db = do -- assumes we have not yet established if it's an old style or not - mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing + mcontent <- liftM Just (readUtf8File (location db)) `catchIO` \_ -> return Nothing case fmap (take 2) mcontent of -- it is an old style and empty db, so look for a dir kind in location.d/ Just "[]" -> return db { @@ -1121,20 +1133,20 @@ adjustOldFileStylePackageDB db = do } -- it is old style but not empty, we have to bail Just _ -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath (location db) ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." -- probably not old style, carry on as normal Nothing -> return db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") +adjustOldDatabasePath :: OsPath -> OsPath +adjustOldDatabasePath = (<.> os "d") -- ----------------------------------------------------------------------------- -- Creating a new package DB -initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB :: OsPath -> Verbosity -> [Flag] -> IO () initPackageDB filename verbosity _flags = do - let eexist = die ("cannot create: " ++ filename ++ " already exists") + let eexist = die ("cannot create: " ++ showOsPath filename ++ " already exists") b1 <- doesFileExist filename when b1 eexist b2 <- doesDirectoryExist filename @@ -1183,7 +1195,8 @@ registerPackage input verbosity my_flags multi_instance f -> do when (verbosity >= Normal) $ info ("Reading package info from " ++ show f ++ " ... ") - readUTF8File f + fs <- encodeFS f + readUtf8File fs expanded <- if expand_env_vars then expandEnvVars s force else return s @@ -1199,7 +1212,11 @@ registerPackage input verbosity my_flags multi_instance -- validate the expanded pkg, but register the unexpanded pkgroot <- absolutePath (takeDirectory to_modify) let top_dir = takeDirectory (location (last db_stack)) - pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + top_dir_filepath <- decodeFS top_dir + pkgroot_filepath <- decodeFS pkgroot + let + pkg_expanded = mungePackagePaths top_dir_filepath pkgroot_filepath pkg let truncated_stack = stackUpTo to_modify db_stack -- truncate the stack for validation, because we don't allow @@ -1274,13 +1291,13 @@ changeDBDir verbosity cmds db db_stack = do updateDBCache verbosity db db_stack where do_cmd (RemovePackage p) = do - let file = location db </> display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("removing " ++ file) + let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ showOsPath file) removeFileSafe file do_cmd (AddPackage p) = do - let file = location db </> display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("writing " ++ file) - writeUTF8File file (showInstalledPackageInfo p) + let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ showOsPath file) + writeUtf8File file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -1338,13 +1355,13 @@ updateDBCache verbosity db db_stack = do warn $ " " ++ pkg when (verbosity > Normal) $ - infoLn ("writing cache " ++ filename) + infoLn ("writing cache " ++ showOsPath filename) let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat GhcPkg.writePackageDb filename d pkgsCabalFormat `catchIO` \e -> if isPermissionError e - then die $ filename ++ ": you don't have permission to modify this file" + then die $ showOsPath filename ++ ": you don't have permission to modify this file" else ioError e case packageDbLock db of @@ -1583,7 +1600,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do broken = map installedUnitId (brokenPackages pkg_map) show_normal PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1610,7 +1627,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do #else let show_colour PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1698,7 +1715,7 @@ dumpUnits verbosity my_flags expand_pkgroot = do doDump expand_pkgroot [ (pkg, locationAbsolute db) | db <- flag_db_stack, pkg <- packages db ] -doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump :: Bool -> [(InstalledPackageInfo, OsPath)] -> IO () doDump expand_pkgroot pkgs = do -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 @@ -1731,7 +1748,7 @@ findPackagesByDB db_stack pkgarg cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg - ++ maybe "" (\db -> " in " ++ location db) mdb + ++ maybe "" (\db -> " in " ++ showOsPath (location db)) mdb where pkg_msg (Id pkgid) = displayGlobPkgId pkgid pkg_msg (IUId ipid) = display ipid @@ -1944,7 +1961,7 @@ checkPackageConfig pkg verbosity db_stack checkExposedModules db_stack pkg checkOtherModules pkg let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg))) - when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) + when has_code $ mapM_ (checkHSLib verbosity (fmap unsafeEncodeUtf $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -2011,20 +2028,20 @@ checkPath url_ok is_dir warn_only thisfield d || "https://" `isPrefixOf` d) = return () | url_ok - , Just d' <- stripPrefix "file://" d - = checkPath False is_dir warn_only thisfield d' + , Just f <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield f -- Note: we don't check for $topdir/${pkgroot} here. We rely on these -- variables having been expanded already, see mungePackagePaths. - | isRelative d = verror ForceFiles $ + | isRelative d' = verror ForceFiles $ thisfield ++ ": " ++ d ++ " is a relative path which " ++ "makes no sense (as there is nothing for it to be " ++ "relative to). You can make paths relative to the " ++ "package database itself by using ${pkgroot}." -- relative paths don't make any sense; #4134 | otherwise = do - there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d + there <- liftIO $ if is_dir then doesDirectoryExist d' else doesFileExist d' when (not there) $ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " ++ if is_dir then "directory" else "file" @@ -2032,6 +2049,8 @@ checkPath url_ok is_dir warn_only thisfield d if warn_only then vwarn msg else verror ForceFiles msg + where + d' = unsafeEncodeUtf d checkDep :: PackageDBStack -> UnitId -> Validate () checkDep db_stack pkgid @@ -2050,24 +2069,25 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: Verbosity -> [String] -> String -> Validate () +checkHSLib :: Verbosity -> [OsPath] -> String -> Validate () checkHSLib _verbosity dirs lib = do - let filenames = ["lib" ++ lib ++ ".a", - "lib" ++ lib ++ "_p.a", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ ".bytecodelib" - ] + let filenames = fmap OsPath.unsafeEncodeUtf + [ "lib" ++ lib ++ ".a" + , "lib" ++ lib ++ "_p.a" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ ".bytecodelib" + ] b <- liftIO $ doesFileExistOnPath filenames dirs when (not b) $ verror ForceFiles ("cannot find any of " ++ show filenames ++ " on library path") -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool +doesFileExistOnPath :: [OsPath] -> [OsPath] -> IO Bool doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames where fullFilenames = [ path </> filename | filename <- filenames @@ -2096,9 +2116,9 @@ checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () checkModuleFile pkg modl = -- there's no interface file for GHC.Prim unless (modl == ModuleName.fromString "GHC.Prim") $ do - let files = [ ModuleName.toFilePath modl <.> extension - | extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] - b <- liftIO $ doesFileExistOnPath files (importDirs pkg) + let files = [ unsafeEncodeUtf (ModuleName.toFilePath modl) <.> extension + | extension <- fmap os ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] + b <- liftIO $ doesFileExistOnPath files (fmap unsafeEncodeUtf $ importDirs pkg) when (not b) $ verror ForceFiles ("cannot find any of " ++ show files) @@ -2273,19 +2293,45 @@ installSignalHandlers = do return () #endif +-- ------------------------------------------------ +-- OsPath Utils + +-- | Show an 'OsPath', throwing an exception if we fail to decode it. +showOsPath :: HasCallStack => OsPath -> FilePath +showOsPath = unsafePerformIO . decodeFS + +-- | Turn a path relative to the current directory into a (normalised) +-- absolute path. +absolutePath :: OsPath -> IO OsPath +absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory + +-- ------------------------------------------------ + catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = catchException tryIO :: IO a -> IO (Either Exception.IOException a) tryIO = Exception.try --- removeFileSave doesn't throw an exceptions, if the file is already deleted -removeFileSafe :: FilePath -> IO () +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +-- | 'removeFileSave' doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: OsPath -> IO () removeFileSafe fn = removeFile fn `catchIO` \ e -> when (not $ isDoesNotExistError e) $ ioError e --- | Turn a path relative to the current directory into a (normalised) --- absolute path. -absolutePath :: FilePath -> IO FilePath -absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory +-- | Read a file using UTF-8 encoding +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656d… +-- and adapted to 'OsPath'. +writeUtf8File :: OsPath -> String -> IO () +writeUtf8File file contents = writeFileAtomic file (toUTF8LBS contents) + +-- | Read a file and interpret its content to be UTF-8 encoded. +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656d… +-- and adapted to 'OsPath'. +readUtf8File :: OsPath -> IO String +readUtf8File file = (ignoreBOM . fromUTF8LBS) <$> FileIO.readFile file ===================================== utils/ghc-pkg/ghc-pkg.cabal.in ===================================== @@ -25,6 +25,7 @@ Executable ghc-pkg process >= 1 && < 1.7, containers, filepath, + file-io, Cabal, Cabal-syntax, binary, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7666f4a981eda798e4fbe88e97db8f3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7666f4a981eda798e4fbe88e97db8f3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Onward!
by Simon Peyton Jones (＠simonpj) 18 Apr '26

18 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 6876e314 by Simon Peyton Jones at 2026-04-18T01:02:06+01:00 Onward! Some renaming, immprove docs More more things out of known-key into known-occ - - - - - 51 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/Core.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Unit/External.hs - libraries/base/base.cabal.in - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/base/src/System/IO/OS.hs - libraries/base/src/System/IO/Unsafe.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs - libraries/ghc-prim/Dummy.hs - libraries/ghc-prim/ghc-prim.cabal The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6876e3140d039f5a1b591bf9faf4043… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6876e3140d039f5a1b591bf9faf4043… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Marge Bot (＠marge-bot) 17 Apr '26

17 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 14b72145 by Fendor at 2026-04-17T17:26:31-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 91aee7ae by Simon Peyton Jones at 2026-04-17T17:26:32-04:00 Kill off the substitution in Lint Now that we have invariant (NoTypeShadowing) we no longer need Lint to carry an ambient substitution. This makes it simpler and faster. A really worthwhile refactor. There are some knock-on effects * Linting join points after worker/wrapper. See Note [Join points and beta redexes] * Running a type substitution after the desugarer. See Note [Substituting type-lets] in the new module GHC.Core.SubstTypeLets Implements #27078 Most perf tests don't use Lint so we won't see a perf incresae. But T1969, which uses -O0 and Lint, gets 1.3% worse because it has to run the SubstTypeLets pass which is a somewhat expensive no-op Overall though compile-time allocations are down 0.1%. Metric Increase: T1969 - - - - - 36a66041 by mangoiv at 2026-04-17T17:26:32-04:00 testsuite: inline elemCoreTest Some weird (probably python scoping) rule caused elemCoreTest, a regex being out of scope on ubuntu, presumably because of a newer python version. This patch just inlines the regex, which fixes the issue. Fixes #27193 - - - - - 19 changed files: - + changelog.d/ghc-pkg-long-path-support - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/Lint/SubstTypeLets.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - libraries/base/tests/perf/all.T - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - testsuite/tests/corelint/LintEtaExpand.stderr - testsuite/tests/corelint/T21115b.stderr - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in Changes: ===================================== changelog.d/ghc-pkg-long-path-support ===================================== @@ -0,0 +1,15 @@ +section: ghc-pkg +synopsis: Improve ``ghc-pkg``'s support for long paths on windows. +issues: #26960 +mrs: !15584 + +description: { + ``ghc-pkg`` can't handle working with file paths longer than the MAX_PATH + restrictions on windows as it is not using UNC file paths by default. + + By using UNC file paths whenever possible, we improve ``ghc-pkg`` on windows. + Note, this still requires the user to enable the use of long paths in order to opt-in + this behaviour on older windows machines. +} + + ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -18,7 +18,7 @@ module GHC.Core.Lint ( LintConfig (..), WarnsAndErrs, - lintCoreBindings', lintUnfolding, + lintCoreBindings, lintUnfolding, lintPassResult, lintExpr, lintAnnots, lintAxioms, @@ -46,6 +46,7 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) import GHC.Core.DataCon +import GHC.Core.Lint.SubstTypeLets( substTypeLets ) import GHC.Core.Ppr import GHC.Core.Coercion import GHC.Core.Type as Type @@ -178,65 +179,7 @@ Note [Linting function types] All saturated applications of funTyCon are represented with the FunTy constructor. See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim - We check this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Bool in - let x::a = True in <body> -That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". -One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] -in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). - -* Hence when linting <body> we need to remember that a=Int, else we - might reject a correct program. So we carry a type substitution (in - this example [a -> Bool]) and apply this substitution before - comparing types. In effect, in Lint, type equality is always - equality-modulo-le-subst. This is in the le_subst field of - LintEnv. But nota bene: - - (SI1) The le_subst substitution is applied to types and coercions only - - (SI2) The result of that substitution is used only to check for type - equality, to check well-typed-ness, /but is then discarded/. - The result of substitution does not outlive the CoreLint pass. - - (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. - -* The function - lintInTy :: Type -> LintM (Type, Kind) - returns a substituted type. - -* When we encounter a binder (like x::a) we must apply the substitution - to the type of the binding variable. lintBinders does this. - -* Clearly we need to clone tyvar binders as we go. - -* But take care (#17590)! We must also clone CoVar binders: - let a = TYPE (ty |> cv) - in \cv -> blah - blindly substituting for `a` might capture `cv`. - -* Alas, when cloning a coercion variable we might choose a unique - that happens to clash with an inner Id, thus - \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` because it's already in scope. Fine, - choose a new unique. Aha, X7 looks good. So we check the lambda - body with le_subst of [cv_66 :-> cv_X7] - - This is all fine, even though we use the same unique as wild_X7. - As (SI2) says, we do /not/ return a new lambda - (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst substitution in types/coercions only, when - checking for equality. - -* We still need to check that Id occurrences are bound by some - enclosing binding. We do /not/ use the InScopeSet for the le_subst - for this purpose -- it contains only TyCoVars. Instead we have a separate - le_ids for the in-scope Id binders. - -Sigh. We might want to explore getting rid of type-let! +We check this invariant in lintType. Note [Bad unsafe coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -311,6 +254,7 @@ path does not result in allocation in the hot path. This can be surprisingly impactful. Changing `lint_app` reduced allocations for one test program I was looking at by ~4%. + ************************************************************************ * * Beginning and ending passes @@ -407,26 +351,37 @@ data LintPassResultConfig = LintPassResultConfig , lpr_platform :: !Platform , lpr_makeLintFlags :: !LintFlags , lpr_passPpr :: !SDoc + , lpr_preSubst :: !Bool -- True <=> run substTypeLets before linting + -- See Note [Substituting type-lets] , lpr_localsInScope :: ![Var] } lintPassResult :: Logger -> LintPassResultConfig -> CoreProgram -> IO () lintPassResult logger cfg binds - = do { let warns_and_errs = lintCoreBindings' - (LintConfig + = do { let lint_config = LintConfig { l_diagOpts = lpr_diagOpts cfg , l_platform = lpr_platform cfg , l_flags = lpr_makeLintFlags cfg , l_vars = lpr_localsInScope cfg - }) - binds + } + + -- Do the pre-substitution if necessary + -- See Note [Substituting type-lets] in GHC.Core.SubstTypeLets + -- especially wrinkle (STL2) + ; let binds1 | lpr_preSubst cfg = substTypeLets binds + | otherwise = binds + + -- Do the main Lint pass itself + ; let warns_and_errs = lintCoreBindings lint_config binds1 + + -- Report the results ; Err.showPass logger $ "Core Linted result of " ++ renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger (lpr_passPpr cfg) - (pprCoreBindings binds) warns_and_errs + (pprCoreBindings binds1) warns_and_errs } displayLintResults :: Logger @@ -456,11 +411,11 @@ lint_banner string pass = text "*** Core Lint" <+> text string <+> text "***" -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs +lintCoreBindings :: LintConfig -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreBindings' cfg binds +lintCoreBindings cfg binds = initL cfg $ addLoc TopLevelBindings $ do { -- Check that all top-level binders are distinct @@ -472,8 +427,7 @@ lintCoreBindings' cfg binds ; checkL (null ext_dups) (dupExtVars ext_dups) -- Typecheck the bindings - ; lintRecBindings TopLevel all_pairs $ \_ -> - return () } + ; lintRecBindings TopLevel all_pairs $ return () } where all_pairs = flattenBinds binds -- Put all the top-level binders in scope at the start @@ -555,28 +509,28 @@ Check a core binding, returning the list of variables bound. -- Let lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv]) + -> LintM a -> LintM (a, [UsageEnv]) lintRecBindings top_lvl pairs thing_inside - = lintIdBndrs top_lvl bndrs $ \ bndrs' -> - do { ues <- zipWithM lint_pair bndrs' rhss - ; a <- thing_inside bndrs' + = lintIdBndrs top_lvl bndrs $ + do { ues <- zipWithM lint_pair bndrs rhss + ; a <- thing_inside ; return (a, ues) } where (bndrs, rhss) = unzip pairs - lint_pair bndr' rhs - = addLoc (RhsOf bndr') $ - do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + lint_pair bndr rhs + = addLoc (RhsOf bndr) $ + do { (rhs_ty, ue) <- lintRhs bndr rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr rhs rhs_ty ; return ue } -lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv) +lintLetBody :: LintLocInfo -> [Id] -> CoreExpr -> LintM (Type, UsageEnv) lintLetBody loc bndrs body = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body) ; mapM_ (lintJoinBndrType body_ty) bndrs ; return (body_ty, body_ue) } -lintLetBind :: TopLevelFlag -> RecFlag -> OutId - -> CoreExpr -> OutType -> LintM () +lintLetBind :: TopLevelFlag -> RecFlag -> Id + -> CoreExpr -> Type -> LintM () -- Binder's type, and the RHS, have already been linted -- This function checks other invariants lintLetBind top_lvl rec_flag binder rhs rhs_ty @@ -651,14 +605,17 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty _ -> return () - ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint any RULES + ; addLoc (RuleOf binder) $ + mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint the unfolding + -- Do this here, not in lintIdBinder, so that all the + -- binders of the letrec group are in scope ; addLoc (UnfoldingOf binder) $ lintIdUnfolding binder binder_ty (idUnfolding binder) - ; return () } - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. + ; return () } -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' -- in that it doesn't reject occurrences of the function 'makeStatic' when they @@ -667,7 +624,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- join point. -- -- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintRhs :: Id -> CoreExpr -> LintM (Type, UsageEnv) -- NB: the Id can be Linted or not -- it's only used for -- its OccInfo and join-pointer-hood lintRhs bndr rhs @@ -682,7 +639,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go where -- Allow occurrences of 'makeStatic' at the top-level but produce errors -- otherwise. - go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go :: StaticPtrCheck -> LintM (Type, UsageEnv) go AllowAtTopLevel | (binders0, rhs') <- collectTyBinders rhs , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' @@ -699,7 +656,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go -- | Lint the RHS of a join point with expected join arity of @n@ (see Note -- [Join points] in "GHC.Core"). -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (Type, UsageEnv) lintJoinLams join_arity enforce rhs = go join_arity rhs where @@ -715,17 +672,22 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf | isStableUnfolding uf , Just rhs <- maybeUnfoldingTemplate uf - = noMultiplicityChecks $ -- Skip linearity checking for unfoldings - -- See Note [Linting linearity] - do { ty <- fst <$> (if isCompulsoryUnfolding uf - then noFixedRuntimeRepChecks $ lintRhs bndr rhs - -- ^^^^^^^^^^^^^^^^^^^^^^^ - -- See Note [Checking for representation polymorphism] - else lintRhs bndr rhs) - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + = suppress_rr_checks $ + noMultiplicityChecks $ -- Skip linearity checking for unfoldings + -- See Note [Linting linearity] + do { (unf_ty, _unf_ue) <- lintRhs bndr rhs + ; ensureEqTys bndr_ty unf_ty (mkRhsMsg bndr (text "unfolding") unf_ty) } + + | otherwise + = -- Do not Lint the body of an unstable unfolding, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + return () + + where + -- See Note [Checking for representation polymorphism] + suppress_rr_checks thing_inside + | isCompulsoryUnfolding uf = noFixedRuntimeRepChecks thing_inside + | otherwise = thing_inside {- Note [Checking for INLINE loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -887,13 +849,8 @@ suspicious and worth investigating if you have a seg-fault or bizarre behaviour. ************************************************************************ -} -lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv) --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - +lintCoreExpr :: CoreExpr -> LintM (Type, UsageEnv) +-- The returned type is the type of the expression -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -920,7 +877,7 @@ lintCoreExpr (Cast expr co) ; lintCoercion co ; lintRole co Representational (coercionRole co) - ; Pair from_ty to_ty <- substCoKindM co + ; let Pair from_ty to_ty = coercionKind co ; checkValueType (typeKind to_ty) $ text "target of cast" <+> quotes (ppr co) ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty) @@ -934,27 +891,22 @@ lintCoreExpr (Tick tickish expr) lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- lintTypeAndSubst ty - ; lintTyCoBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendTvSubstL tv ty' $ - addLoc (BodyOfLet tv) $ - lintCoreExpr body } } + = do { lintType ty + ; lintTyCoBndr tv $ + do { addLoc (RhsOf tv) $ lintTyKind tv ty + ; addLoc (BodyOfLet tv) $ lintCoreExpr body } } lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr = do { -- First Lint the RHS, before bringing the binder into scope (rhs_ty, let_ue) <- lintRhs bndr rhs - -- See Note [Multiplicity of let binders] in Var + -- See Note [Multiplicity of let binders] in Var -- Now lint the binder - ; lintBinder LetBind bndr $ \bndr' -> - do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; addAliasUE bndr' let_ue $ - lintLetBody (BodyOfLet bndr') [bndr'] body } } + ; lintBinder LetBind bndr $ + do { lintLetBind NotTopLevel NonRecursive bndr rhs rhs_ty + ; addAliasUE bndr let_ue $ + lintLetBody (BodyOfLet bndr) [bndr] body } } | otherwise = failWithL (mkLetErr bndr rhs) -- Not quite accurate @@ -973,8 +925,8 @@ lintCoreExpr e@(Let (Rec pairs) body) -- See Note [Multiplicity of let binders] in Var ; ((body_type, body_ue), ues) <- - lintRecBindings NotTopLevel pairs $ \ bndrs' -> - lintLetBody (BodyOfLetRec bndrs') bndrs' body + lintRecBindings NotTopLevel pairs $ + lintLetBody (BodyOfLetRec bndrs) bndrs body ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) } where bndrs = map fst pairs @@ -986,7 +938,7 @@ lintCoreExpr e@(App _ _) -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y , ty_arg1 : ty_arg2 : cont_arg : rest <- args - = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) + = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (Type, UsageEnv) lint_rw_cont expr@(Lam _ _) mult fun_ue = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) @@ -1036,74 +988,73 @@ lintCoreExpr (Type ty) lintCoreExpr (Coercion co) -- See Note [Coercions in terms] = do { addLoc (InCo co) $ lintCoercion co - ; ty <- substTyM (coercionType co) + ; let ty = coercionType co ; return (ty, zeroUE) } ---------------------- -lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed - -> LintM (OutType, UsageEnv) -- returns type of the *variable* -lintIdOcc in_id nargs - = addLoc (OccOf in_id) $ - do { checkL (isNonCoVarId in_id) - (text "Non term variable" <+> ppr in_id) +lintIdOcc :: Id -> Int -- Number of arguments (type or value) being passed + -> LintM (Type, UsageEnv) -- returns type of the *variable* +lintIdOcc id nargs + = addLoc (OccOf id) $ + do { checkL (isNonCoVarId id) + (text "Non term variable" <+> ppr id) -- See GHC.Core Note [Variable occurrences in Core] - -- Check that the type of the occurrence is the same - -- as the type of the binding site. The inScopeIds are - -- /un-substituted/, so this checks that the occurrence type - -- is identical to the binder type. - -- This makes things much easier for things like: - -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... - -- The "::Maybe a" on the occurrence is referring to the /outer/ a. - -- If we compared /substituted/ types we'd risk comparing - -- (Maybe a) from the binding site with bogus (Maybe a1) from - -- the occurrence site. Comparing un-substituted types finesses - -- this altogether - ; out_ty <- lintVarOcc in_id + ; lintVarOcc id -- Check for a nested occurrence of the StaticPtr constructor. -- See Note [Checking StaticPtrs]. ; when (nargs /= 0) $ - checkL (idName in_id /= makeStaticName) $ + checkL (idName id /= makeStaticName) $ text "Found makeStatic nested in an expression" - ; checkDeadIdOcc in_id + ; checkDeadIdOcc id - ; case isDataConId_maybe in_id of + ; case isDataConId_maybe id of Nothing -> return () Just dc -> checkTypeDataConOcc "expression" dc - ; checkJoinOcc in_id nargs - ; usage <- varCallSiteUsage in_id - - ; return (out_ty, usage) } + ; checkJoinOcc id nargs + ; usage <- varCallSiteUsage id + ; return (idType id, usage) } +------------------ lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM (OutType, UsageEnv) -- Returns type of the *function* + -> Int -- Number of arguments (type or val) being passed + -> LintM (Type, UsageEnv) -- Returns type of the *function* lintCoreFun (Var var) nargs = lintIdOcc var nargs lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; - -- See Note [Beta redexes] + -- Act like lintCoreExpr of Lam, but *don't* necessarily call markAllJoinsBad; + -- See Note [Join points and beta-redexes] | nargs /= 0 = lintLambda var $ lintCoreFun body (nargs - 1) lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr + = do { mark_bad_joins + <- if nargs == 0 + then -- Saturated lambda + -- See Note [Join points and beta-redexes] + do { flags <- getLintFlags + ; return (not (lf_allow_beta_joins flags)) } + else -- Something else + -- See Note [Join points are less general than the paper] + return True + + ; markAllJoinsBadIf mark_bad_joins $ + lintCoreExpr expr } + ------------------ lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) lintLambda var lintBody = addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> + lintBinder LambdaBind var $ do { (body_ty, ue) <- lintBody - ; ue' <- checkLinearity ue var' - ; return (mkLamType var' body_ty, ue') } + ; ue' <- checkLinearity ue var + ; return (mkLamType var body_ty, ue') } ------------------ checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -1117,8 +1068,8 @@ checkDeadIdOcc id = return () ------------------ -lintJoinBndrType :: OutType -- Type of the body - -> OutId -- Possibly a join Id +lintJoinBndrType :: Type -- Type of the body + -> Id -- Possibly a join Id -> LintM () -- Checks that the return type of a join Id matches the body -- E.g. join j x = rhs in body @@ -1337,8 +1288,55 @@ checkLinearity body_ue lam_var = return body_ue' Nothing -> return body_ue -- A type variable -{- Note [Linting join points with casts or ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Join points and beta-redexes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the worker/wrapper pass, the worker invokes the original function by calling +it with arguments, thus producing a beta-redex for the simplifier to munch away: + + \x y z -> e => (\x y z -> e) wx wy wz + +But we need to take care if `e` invokes a join point. For example: + + join j1 x = ... + join j2 y = if y == 0 then 0 else j1 y +=> + join j1 x = ... + join $wj2 y# = (\y -> if y == 0 then 0 else jump j1 y) (I# y#) + join j2 y = case y of I# y# -> jump $wj2 y# + +Now the jump to `j1` is inside a lambda and inside an application. That is ill-typed +from Lint's point of view. And yet, after one round of simplification it'll all be +fine. + +You might wonder if we could use a `let` instead of a lambda for the worker: + + join $wj2 y# = let y = I# y# + in if y == 0 then 0 else jump j1 y + +That would solve the join-point problem, but it really doesn't work because + 1. The lets shadow each other + 2. In particular the invariant (NoTypeShadowing) is easily broken. + (We might have type lambdas of course.) + +In short, te lambda arguments should not "see" any of the lambda-bound +variables. + +So our solution is this: + +* Use straightforward applicaion in the worker-wrapper pass, creating a beta-redex. + See the call to `mkApps` in GHC.Core.Opt.WorkWrap.Utils.mkWwBodies. + +* Tell Lint not to complain about a join-point invocation hidden under a + saturated beta-redex. The code is rather simple: see `lintCoreFun`. + + We guard this with a Lint flag `lf_allow_beta_joins`. + +* Teach occurrence analysis that `j1` is still a join point, despite its + call being nested inside the beta-redex. See Note [occAnal for applications] + in GHC.Core.Opt.OccurAnal. + +Note [Linting join points with casts or ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful when a cast or tick occurs in between a join point binding and a corresponding join point occurrence. @@ -1409,33 +1407,6 @@ lose track of why an expression is bottom, so we shouldn't make too much fuss when that happens. -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in GHC.Core). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - ************************************************************************ * * \subsection[lintCoreArgs]{lintCoreArgs} @@ -1449,23 +1420,23 @@ subtype of the required type, as one would expect. -- Takes the functions type and arguments as argument. -- Returns the *result* of applying the function to arguments. -- e.g. f :: Int -> Bool -> Int would return `Int` as result type. -lintCoreArgs :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv) +lintCoreArgs :: (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv) lintCoreArgs (fun_ty, fun_ue) args - = lintApp (text "expression") - lintTyArg lintValArg fun_ty args fun_ue + = lintApp (text "expression") lintTyArg lintValArg fun_ty args fun_ue -lintTyArg :: InExpr -> LintM OutType +lintTyArg :: CoreExpr -> LintM Type -- Type argument lintTyArg (Type arg_ty) = do { checkL (not (isCoercionTy arg_ty)) (text "Unnecessary coercion-to-type injection:" <+> ppr arg_ty) - ; lintTypeAndSubst arg_ty } + ; lintType arg_ty + ; return arg_ty } lintTyArg arg = failWithL (hang (text "Expected type argument but found") 2 (ppr arg)) -lintValArg :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) +lintValArg :: CoreExpr -> Mult -> UsageEnv -> LintM (Type, UsageEnv) lintValArg arg mult fun_ue = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg -- See Note [Representation polymorphism invariants] in GHC.Core @@ -1484,9 +1455,9 @@ lintValArg arg mult fun_ue ----------------- lintAltBinders :: UsageEnv - -> Var -- Case binder - -> OutType -- Scrutinee type - -> OutType -- Constructor type + -> Var -- Case binder + -> Type -- Scrutinee type + -> Type -- Constructor type -> [(Mult, OutVar)] -- Binders -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism @@ -1505,6 +1476,7 @@ lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + -- | Implements the case rules for linearity checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv checkCaseLinearity ue case_bndr var_w bndr = do @@ -1529,7 +1501,7 @@ checkCaseLinearity ue case_bndr var_w bndr = do ----------------- -lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp :: Type -> Type -> LintM Type lintTyApp fun_ty arg_ty | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty = do { lintTyKind tv arg_ty @@ -1547,8 +1519,8 @@ lintTyApp fun_ty arg_ty -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the -- application. -lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv - -> LintM (OutType, UsageEnv) +lintValApp :: CoreExpr -> Type -> Type -> UsageEnv -> UsageEnv + -> LintM (Type, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) @@ -1559,9 +1531,7 @@ lintValApp arg fun_ty arg_ty fun_ue arg_ue where err2 = mkNonFunAppMsg fun_ty arg_ty arg -lintTyKind :: OutTyVar -> OutType -> LintM () --- Both args have had substitution applied - +lintTyKind :: OutTyVar -> Type -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintTyKind tyvar arg_ty @@ -1579,36 +1549,36 @@ lintTyKind tyvar arg_ty ************************************************************************ -} -lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv) +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (Type, UsageEnv) lintCaseExpr scrut case_bndr alt_ty alts = do { let e = Case scrut case_bndr alt_ty alts -- Just for error messages -- Check the scrutinee - ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut -- See Note [Join points are less general than the paper] -- in GHC.Core - ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty + ; addLoc (CaseTy scrut) $ lintValueType alt_ty - ; checkCaseAlts e scrut scrut_ty' alts + ; checkCaseAlts e scrut scrut_ty alts -- Lint the case-binder. Must do this after linting the scrutinee -- because the case-binder isn't in scope in the scrutineex - ; lintBinder CaseBind case_bndr $ \case_bndr' -> + ; lintBinder CaseBind case_bndr $ -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate - do { let case_bndr_ty' = idType case_bndr' - scrut_mult = idMult case_bndr' + do { let case_bndr_ty = idType case_bndr + scrut_mult = idMult case_bndr - ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty') + ; ensureEqTys case_bndr_ty scrut_ty (mkScrutMsg case_bndr case_bndr_ty scrut_ty) -- See GHC.Core Note [Case expression invariants] item (7) ; -- Check the alternatives - ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts + ; alt_ues <- mapM (lintCoreAlt case_bndr scrut_ty scrut_mult alt_ty) alts ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues - ; return (alt_ty', case_ue) } } + ; return (alt_ty, case_ue) } } -checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM () +checkCaseAlts :: CoreExpr -> CoreExpr -> Type -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty -- b1) Check that the DEFAULT comes first, if it exists -- b2) Check that the others are in increasing order @@ -1683,17 +1653,17 @@ checkCaseAlts e scrut scrut_ty alts is_lit_alt (Alt (LitAlt _) _ _) = True is_lit_alt _ = False -lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv +lintAltExpr :: CoreExpr -> Type -> LintM UsageEnv lintAltExpr expr ann_ty = do { (actual_ty, ue) <- lintCoreExpr expr ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) ; return ue } -- See GHC.Core Note [Case expression invariants] item (6) -lintCoreAlt :: OutId -- Case binder - -> OutType -- Type of scrutinee +lintCoreAlt :: Id -- Case binder + -> Type -- Type of scrutinee -> Mult -- Multiplicity of scrutinee - -> OutType -- Type of the alternative + -> Type -- Type of the alternative -> CoreAlt -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism @@ -1738,11 +1708,11 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do + ; lintBinders CasePatBind args $ do { rhs_ue <- lintAltExpr rhs alt_ty ; rhs_ue' <- addLoc (CasePat alt) $ lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty - (zipEqual multiplicities args') + (zipEqual multiplicities args) ; return $ deleteUE rhs_ue' case_bndr } } @@ -1784,54 +1754,52 @@ lintLinearBinder doc actual_usage described_usage -} -- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') +-- 1. Lint var types or kinds +-- 2. Add the binder to the in scope set +lintBinders :: HasDebugCallStack => BindingSite -> [Var] -> LintM a -> LintM a +lintBinders _ [] linterF = linterF +lintBinders site (var:vars) linterF = lintBinder site var $ + lintBinders site vars $ + linterF -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a +lintBinder :: HasDebugCallStack => BindingSite -> Var -> LintM a -> LintM a lintBinder site var linterF | isTyCoVar var = lintTyCoBndr var linterF | otherwise = lintIdBndr NotTopLevel site var linterF -lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr :: HasDebugCallStack => TyCoVar -> LintM a -> LintM a lintTyCoBndr tcv thing_inside - = do { tcv_type' <- lintTypeAndSubst (varType tcv) - ; let tcv_kind' = typeKind tcv_type' + = do { let tcv_type = varType tcv + tcv_kind = typeKind tcv_type + ; lintType (varType tcv) -- See (FORALL1) and (FORALL2) in GHC.Core.Type ; if (isTyVar tcv) then -- Check that in (forall (a:ki). blah) we have ki:Type - lintL (isLiftedTypeKind tcv_kind') $ + lintL (isLiftedTypeKind tcv_kind) $ hang (text "TyVar whose kind does not have kind Type:") - 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') + 2 (ppr tcv <+> dcolon <+> ppr tcv_type <+> dcolon <+> ppr tcv_kind) else -- Check that in (forall (cv::ty). blah), -- then ty looks like (t1 ~# t2) - lintL (isCoVarType tcv_type') $ + lintL (isCoVarType tcv_type) $ text "CoVar with non-coercion type:" <+> pprTyVar tcv - ; addInScopeTyCoVar tcv tcv_type' thing_inside } + ; addInScopeTyCoVar tcv thing_inside } -lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a +lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> LintM a -> LintM a lintIdBndrs top_lvl ids thing_inside = go ids thing_inside where - go :: [Id] -> ([Id] -> LintM a) -> LintM a - go [] thing_inside = thing_inside [] - go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> - go ids $ \ids' -> - thing_inside (id' : ids') + go :: [Id] -> LintM a -> LintM a + go [] thing_inside = thing_inside + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ + go ids $ + thing_inside lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument + -> Var -> LintM a -> LintM a -- ToDo: lint its rules lintIdBndr top_lvl bind_site id thing_inside = assertPpr (isId id) (ppr id) $ @@ -1864,14 +1832,16 @@ lintIdBndr top_lvl bind_site id thing_inside ; lintL (not (isCoVarType id_ty)) (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - -- Check that the lambda binder has no value or OtherCon unfolding. + -- Check that lambda-bound Ids have no unfolding; not even OtherCon -- See #21496 - ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") + ; let unf = idUnfolding id + ; checkL (not (bind_site == LambdaBind && hasSomeUnfolding unf)) $ + hang (text "Lambda binder" <+> quotes (ppr id) <+> text "has an unfolding") + 2 (ppr unf) - ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) + ; addLoc (IdTy id) (lintValueType id_ty) - ; addInScopeId id out_ty thing_inside } + ; addInScopeId id thing_inside } where id_ty = idType id @@ -1891,62 +1861,44 @@ lintIdBndr top_lvl bind_site id thing_inside {- Note [Linting types and coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that - lintType :: InType -> LintM () - lintCoercion :: InCoercion -> LintM () + lintType :: Type -> LintM () + lintCoercion :: Coercion -> LintM () Neither returns anything. -If you need the kind of the type, then do `typeKind` and then apply -the ambient substitution using `substTyM`. Note that the substitution -empty unless there is shadowing or type-lets; and if the substitution is -empty, the `substTyM` is a no-op. - -It is better to take the kind and then substitute, rather than substitute -and then take the kind, becaues the kind is usually smaller. - -Note: you might wonder if we should apply the same logic to expressions. -Why do we have - lintExpr :: InExpr -> LintM OutType -Partly inertia; but also taking the type of an expresison involve looking -down a deep chain of let's, whereas that is not true of taking the kind -of a type. It'd be worth an experiment though. - -Historical note: in the olden days we had - lintType :: InType -> LintM OutType -but that burned a huge amount of allocation building an OutType that was -often discarded, or used only to get its kind. - -I also experimented with - lintType :: InType -> LintM OutKind -but that too was slower. It is also much simpler to return ()! If we -return the kind we have to duplicate the logic in `typeKind`; and it is -much worse for coercions. +Note: you might wonder why we have + lintExpr :: CoreExpr -> LintM Type + lintType :: Type -> LintM () + +That is, linting an expression yields its type, but linting a type does not +yield its kind. Partly inertia; but: + +* Taking the type of an expresison involves looking down a deep chain of let's, + whereas that is not true of taking the kind of a type. It'd be worth an + experiment though. + +* I did experiment with + lintType :: Type -> LintM Kind + but that too was slower. It is also much simpler to return ()! If we return + the kind we have to duplicate the logic in `typeKind`; and it is much worse + for coercions. -} -lintValueType :: Type -> LintM OutType +lintValueType :: Type -> LintM () -- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] lintValueType ty = addLoc (InType ty) $ - do { ty' <- lintTypeAndSubst ty - ; let sk = typeKind ty' + do { lintType ty + ; let sk = typeKind ty ; lintL (isTYPEorCONSTRAINT sk) $ hang (text "Ill-kinded type:" <+> ppr ty) - 2 (text "has kind:" <+> ppr sk) - ; return ty' } + 2 (text "has kind:" <+> ppr sk)} checkTyCon :: TyCon -> LintM () checkTyCon tc = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) ------------------- -lintTypeAndSubst :: InType -> LintM OutType -lintTypeAndSubst ty = do { lintType ty; substTyM ty } - -- In GHCi we may lint an expression with a free - -- type variable. Then it won't be in the - -- substitution, but it should be in scope - -lintType :: InType -> LintM () +lintType :: Type -> LintM () -- See Note [Linting types and coercions] -- -- If you edit this function, you may need to update the GHC formalism @@ -1956,8 +1908,7 @@ lintType (TyVarTy tv) = failWithL (mkBadTyVarMsg tv) | otherwise - = do { _ <- lintVarOcc tv - ; return () } + = lintVarOcc tv lintType ty@(AppTy t1 t2) | TyConApp {} <- t1 @@ -1965,7 +1916,7 @@ lintType ty@(AppTy t1 t2) | otherwise = do { let (fun_ty, arg_tys) = collect t1 [t2] ; lintType fun_ty - ; fun_kind <- substTyM (typeKind fun_ty) + ; let fun_kind = typeKind fun_ty ; lint_ty_app ty fun_kind arg_tys } where collect (AppTy f a) as = collect f (a:as) @@ -1997,21 +1948,21 @@ lintType ty@(FunTy af tw t1 t2) lintType ty@(ForAllTy {}) = go [] ty where - go :: [OutTyCoVar] -> InType -> LintM () + go :: [OutTyCoVar] -> Type -> LintM () -- Loop, collecting the forall-binders go tcvs ty@(ForAllTy (Bndr tcv _) body_ty) | not (isTyCoVar tcv) = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty) | otherwise - = lintTyCoBndr tcv $ \tcv' -> + = lintTyCoBndr tcv $ do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] -- Suspicious because it works on InTyCoVar; c.f. ForAllCo when (isCoVar tcv) $ lintL (anyFreeVarsOfType (== tcv) body_ty) $ text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) - ; go (tcv' : tcvs) body_ty } + ; go (tcv : tcvs) body_ty } go tcvs body_ty = do { lintType body_ty @@ -2019,7 +1970,7 @@ lintType ty@(ForAllTy {}) lintType (CastTy ty co) = do { lintType ty - ; ty_kind <- substTyM (typeKind ty) + ; let ty_kind = typeKind ty ; co_lk <- lintStarCoercion co ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) } @@ -2027,14 +1978,14 @@ lintType (LitTy l) = lintTyLit l lintType (CoercionTy co) = lintCoercion co ----------------- -lintForAllBody :: [OutTyCoVar] -> InType -> LintM () +lintForAllBody :: [OutTyCoVar] -> Type -> LintM () -- Do the checks for the body of a forall-type lintForAllBody tcvs body_ty = do { -- For type variables, check for skolem escape -- See Note [Phantom type variables in kinds] in GHC.Core.Type -- The kind of (forall cv. th) is liftedTypeKind, so no -- need to check for skolem-escape in the CoVar case - body_kind <- substTyM (typeKind body_ty) + let body_kind = typeKind body_ty ; case occCheckExpand tcvs body_kind of Just {} -> return () Nothing -> failWithL $ @@ -2045,7 +1996,7 @@ lintForAllBody tcvs body_ty ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) } ----------------- -lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM () +lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM () -- The TyCon is a type synonym or a type family (not a data family) -- See Note [Linting type synonym applications] -- c.f. GHC.Tc.Validity.check_syn_tc_app @@ -2071,21 +2022,21 @@ lintTySynFamApp report_unsat ty tc tys ----------------- -- Confirms that a kind is really TYPE r or Constraint -checkValueType :: OutKind -> SDoc -> LintM () +checkValueType :: Kind -> SDoc -> LintM () checkValueType kind doc = lintL (isTYPEorCONSTRAINT kind) (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ text "when checking" <+> doc) ----------------- -lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM () +lintArrow :: SDoc -> FunTyFlag -> Type -> Type -> Type -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintArrow what af t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw -- or lintArrow "coercion `blah'" k1 k2 kw - = do { k1 <- substTyM (typeKind t1) - ; k2 <- substTyM (typeKind t2) - ; kw <- substTyM (typeKind tw) + = do { let k1 = typeKind t1 + k2 = typeKind t2 + kw = typeKind tw ; unless (isTYPEorCONSTRAINT k1) (report (text "argument") t1 k1) ; unless (isTYPEorCONSTRAINT k2) (report (text "result") t2 k2) ; unless (isMultiplicityTy kw) (report (text "multiplicity") tw kw) @@ -2111,34 +2062,34 @@ lintTyLit (StrTyLit _) = return () lintTyLit (CharTyLit _) = return () ----------------- -lint_ty_app :: InType -> OutKind -> [InType] -> LintM () +lint_ty_app :: Type -> Kind -> [Type] -> LintM () lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty)) -lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM () +lint_co_app :: HasDebugCallStack => Coercion -> Kind -> [Type] -> LintM () lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co)) -lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM () +lint_tyco_app :: SDoc -> Kind -> [Type] -> LintM () lint_tyco_app msg fun_kind arg_tys -- See Note [Avoiding compiler perf traps when constructing error messages.] - = do { _ <- lintApp msg (\ty -> do { lintType ty; substTyM ty }) - (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) }) - fun_kind arg_tys () + = do { _ <- lintApp msg (\ty -> do { lintType ty; return ty }) + (\ty _ _ -> do { lintType ty; return (typeKind ty,()) }) + fun_kind arg_tys () ; return () } ---------------- -lintApp :: forall in_a acc. Outputable in_a => +lintApp :: forall a acc. Outputable a => SDoc - -> (in_a -> LintM OutType) -- Lint the thing and return its value - -> (in_a -> Mult -> acc -> LintM (OutKind, acc)) -- Lint the thing and return its type - -> OutType - -> [in_a] -- The arguments, always "In" things - -> acc -- Used (only) for UsageEnv in /term/ applications - -> LintM (OutType,acc) + -> (a -> LintM Type) -- Lint the thing and return its value + -> (a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type + -> Type + -> [a] -- The arguments + -> acc -- Used (only) for UsageEnv in /term/ applications + -> LintM (Type,acc) -- lintApp is a performance-critical function, which deals with multiple -- applications such as (/\a./\b./\c. expr) @ta @tb @tc -- When returning the type of this expression we want to avoid substituting a:=ta, -- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge --- perf hole. So we gather all the arguments [in_a], and then gather the +-- perf hole. So we gather all the arguments [a], and then gather the -- substitution incrementally in the `go` loop. -- -- lintApp is used: @@ -2158,7 +2109,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc ; let init_subst = mkEmptySubst in_scope - go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc) + go :: Subst -> Type -> acc -> [a] -> LintM (Type, acc) -- The Subst applies (only) to the fun_ty -- c.f. GHC.Core.Type.piResultTys, which has a similar loop @@ -2202,7 +2153,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc -- explicitly and don't capture them as free variables. Otherwise this binder might -- become a thunk that get's allocated in the hot code path. -- See Note [Avoiding compiler perf traps when constructing error messages.] -lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc +lint_app_fail_msg :: (Outputable a2) => SDoc -> Type -> a2 -> SDoc -> SDoc lint_app_fail_msg msg kfn arg_tys extra = vcat [ hang (text "Application error in") 2 msg , nest 2 (text "Function type =" <+> ppr kfn) @@ -2215,7 +2166,7 @@ lint_app_fail_msg msg kfn arg_tys extra * * ********************************************************************* -} -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () +lintCoreRule :: OutVar -> Type -> CoreRule -> LintM () lintCoreRule _ _ (BuiltinRule {}) = return () -- Don't bother @@ -2223,7 +2174,7 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs , ru_args = args, ru_rhs = rhs }) = noMultiplicityChecks $ -- Skip linearity checking for rules -- See Note [Linting linearity] - lintBinders LambdaBind bndrs $ \ _ -> + lintBinders LambdaBind bndrs $ do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args ; (rhs_ty, _) <- case idJoinPointHood fun of JoinPoint join_arity @@ -2311,10 +2262,10 @@ Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further {- Note [Asymptotic efficiency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting coercions (and types actually) we return a linted -(substituted) coercion. Then we often have to take the coercionKind of -that returned coercion. If we get long chains, that can be asymptotically -inefficient, notably in +When linting coercions we traverse the coercion. Then we often have to take the +coercionKind of that returned coercion. If we get long chains, that can be +asymptotically inefficient, notably in + * TransCo * InstCo * SelCo (cf #9233) @@ -2326,30 +2277,23 @@ the bad perf bites us in practice. A solution would be to return the kind and role of the coercion, as well as the linted coercion. Or perhaps even *only* the kind and role, which is what used to happen. But that proved tricky and error prone -(#17923), so now we return the coercion. +(#17923). -} -- lintStarCoercion lints a coercion, confirming that its lh kind and -- its rh kind are both *; also ensures that the role is Nominal -- Returns the lh kind -lintStarCoercion :: InCoercion -> LintM OutType +lintStarCoercion :: Coercion -> LintM Type lintStarCoercion g = do { lintCoercion g - ; Pair t1 t2 <- substCoKindM g + ; let Pair t1 t2 = coercionKind g ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g) ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g) ; lintRole g Nominal (coercionRole g) ; return t1 } -substCoKindM :: InCoercion -> LintM (Pair OutType) -substCoKindM co - = do { let !(Pair lk rk) = coercionKind co - ; lk' <- substTyM lk - ; rk' <- substTyM rk - ; return (Pair lk' rk') } - -lintCoercion :: HasDebugCallStack => InCoercion -> LintM () +lintCoercion :: HasDebugCallStack => Coercion -> LintM () -- See Note [Linting types and coercions] -- -- If you edit this function, you may need to update the GHC formalism @@ -2361,7 +2305,7 @@ lintCoercion (CoVarCo cv) 2 (text "With offending type:" <+> ppr (varType cv))) | otherwise -- C.f. lintType (TyVarTy tv), which has better docs - = do { _ <- lintVarOcc cv; return () } + = lintVarOcc cv lintCoercion (Refl ty) = lintType ty lintCoercion (GRefl _r ty MRefl) = lintType ty @@ -2369,8 +2313,8 @@ lintCoercion (GRefl _r ty MRefl) = lintType ty lintCoercion (GRefl _r ty (MCo co)) = do { lintType ty ; lintCoercion co - ; tk <- substTyM (typeKind ty) - ; tl <- substTyM (coercionLKind co) + ; let tk = typeKind ty + tl = coercionLKind co ; ensureEqTys tk tl $ hang (text "GRefl coercion kind mis-match:" <+> ppr co) 2 (vcat [ppr ty, ppr tk, ppr tl]) @@ -2403,8 +2347,8 @@ lintCoercion co@(AppCo co1 co2) = do { lintCoercion co1 ; lintCoercion co2 ; let !(Pair lt1 rt1) = coercionKind co1 - ; lk1 <- substTyM (typeKind lt1) - ; rk1 <- substTyM (typeKind rt1) + lk1 = typeKind lt1 + rk1 = typeKind rt1 ; lint_co_app co lk1 [coercionLKind co2] ; lint_co_app co rk1 [coercionRKind co2] @@ -2421,7 +2365,7 @@ lintCoercion co@(ForAllCo {}) = do { _ <- go [] co; return () } where go :: [OutTyCoVar] -- Binders in reverse order - -> InCoercion -> LintM Role + -> Coercion -> LintM Role go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR , fco_kind = kind_mco, fco_body = body_co }) | not (isTyCoVar tcv) @@ -2431,15 +2375,15 @@ lintCoercion co@(ForAllCo {}) = do { mb_lk <- case kind_mco of MRefl -> return Nothing MCo kind_co -> Just <$> lintStarCoercion kind_co - ; lintTyCoBndr tcv $ \tcv' -> + ; lintTyCoBndr tcv $ do { case mb_lk of Nothing -> return () - Just lk -> ensureEqTys (varType tcv') lk $ + Just lk -> ensureEqTys (varType tcv) lk $ text "Kind mis-match in ForallCo" <+> ppr co -- I'm not very sure about this part, because it traverses body_co -- but at least it's on a cold path (a ForallCo for a CoVar) - -- Also it works on InTyCoVar and InCoercion, which is suspect + -- Also it works on InTyCoVar and Coercion, which is suspect ; when (isCoVar tcv) $ do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $ text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co @@ -2448,7 +2392,7 @@ lintCoercion co@(ForAllCo {}) text "Covar can only appear in Refl and GRefl: " <+> ppr co } -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep - ; role <- go (tcv':tcvs) body_co + ; role <- go (tcv:tcvs) body_co ; when (role == Nominal) $ lintL (visL `eqForAllVis` visR) $ @@ -2505,8 +2449,8 @@ lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov -- Check the to and from types ; lintType ty1 ; lintType ty2 - ; tk1 <- substTyM (typeKind ty1) - ; tk2 <- substTyM (typeKind ty2) + ; let tk1 = typeKind ty1 + tk2 = typeKind ty2 ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2) (checkTypes ty1 ty2) @@ -2560,8 +2504,8 @@ lintCoercion (SymCo co) = lintCoercion co lintCoercion co@(TransCo co1 co2) = do { lintCoercion co1 ; lintCoercion co2 - ; rk1 <- substTyM (coercionRKind co1) - ; lk2 <- substTyM (coercionLKind co2) + ; let rk1 = coercionRKind co1 + lk2 = coercionLKind co2 ; ensureEqTys rk1 lk2 (hang (text "Trans coercion mis-match:" <+> ppr co) 2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)])) @@ -2569,7 +2513,7 @@ lintCoercion co@(TransCo co1 co2) lintCoercion the_co@(SelCo cs co) = do { lintCoercion co - ; Pair s t <- substCoKindM co + ; let Pair s t = coercionKind co ; if -- forall (both TyVar and CoVar) | Just _ <- splitForAllTyCoVar_maybe s @@ -2604,7 +2548,7 @@ lintCoercion the_co@(SelCo cs co) lintCoercion the_co@(LRCo _lr co) = do { lintCoercion co - ; Pair s t <- substCoKindM co + ; let Pair s t = coercionKind co ; lintRole co Nominal (coercionRole co) ; case (splitAppTy_maybe s, splitAppTy_maybe t) of (Just {}, Just {}) -> return () @@ -2618,14 +2562,12 @@ lintCoercion orig_co@(InstCo co arg) go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) } go co args = do { lintCoercion co ; let Pair lty rty = coercionKind co - ; lty' <- substTyM lty - ; rty' <- substTyM rty ; in_scope <- getInScope ; let subst = mkEmptySubst in_scope - ; go_args (subst, lty') (subst,rty') args } + ; go_args (subst, lty) (subst,rty) args } ------------- - go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion] + go_args :: (Subst, Type) -> (Subst,Type) -> [Coercion] -> LintM () go_args _ _ [] = return () @@ -2634,11 +2576,11 @@ lintCoercion orig_co@(InstCo co arg) ; go_args lty1 rty1 args } ------------- - go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion - -> LintM ((Subst,OutType), (Subst,OutType)) + go_arg :: (Subst, Type) -> (Subst,Type) -> Coercion + -> LintM ((Subst,Type), (Subst,Type)) go_arg (lsubst,lty) (rsubst,rty) arg = do { lintRole arg Nominal (coercionRole arg) - ; Pair arg_lty arg_rty <- substCoKindM arg + ; let Pair arg_lty arg_rty = coercionKind arg ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of -- forall over tvar @@ -2662,11 +2604,11 @@ lintCoercion orig_co@(InstCo co arg) lintCoercion this_co@(AxiomCo ax cos) = do { mapM_ lintCoercion cos ; lint_roles 0 (coAxiomRuleArgRoles ax) cos - ; prs <- mapM substCoKindM cos + ; let prs = map coercionKind cos ; lint_ax ax prs } where - lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM () + lint_ax :: CoAxiomRule -> [Pair Type] -> LintM () lint_ax (BuiltInFamRew bif) prs = checkL (isJust (bifrw_proves bif prs)) bad_bif lint_ax (BuiltInFamInj bif) prs @@ -2754,8 +2696,8 @@ lintBranch this_co fam_tc branch arg_kinds = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $ (bad_ax this_co (text "lengths")) - ; subst <- getSubst - ; let empty_subst = zapSubst subst + ; in_scope <- getInScope + ; let empty_subst = mkEmptySubst in_scope ; _ <- foldlM check_ki (empty_subst, empty_subst) (zip (ktvs ++ cvs) arg_kinds) @@ -2880,12 +2822,12 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches lint_branch :: TyCon -> CoAxBranch -> LintM () lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , cab_lhs = lhs_args, cab_rhs = rhs }) - = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + = lintBinders LambdaBind (tvs ++ cvs) $ do { let lhs = mkTyConApp ax_tc lhs_args ; lintType lhs ; lintType rhs - ; lhs_kind <- substTyM (typeKind lhs) - ; rhs_kind <- substTyM (typeKind rhs) + ; let lhs_kind = typeKind lhs + rhs_kind = typeKind rhs ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ hang (text "Inhomogeneous axiom") 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ @@ -2969,35 +2911,26 @@ type LintLevel = Int -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: Subst - -- Current substitution, for TyCoVars only. - -- Non-CoVar Ids don't appear in here, not even in the InScopeSet - -- Used for (a) cloning to avoid shadowing of TyCoVars, - -- so that eqType works ok - -- (b) substituting for let-bound tyvars, when we have - -- (let @a = Int -> Int in ...) - - , le_level :: LintLevel - , le_in_vars :: VarEnv (InVar, OutType, LintLevel) - -- Maps an InVar (i.e. its unique) to its binding InVar - -- and to its OutType - -- /All/ in-scope variables are here (term variables, - -- type variables, and coercion variables) - -- Used at an occurrence of the InVar + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + , le_level :: LintLevel + , le_in_scope :: InScopeSet + + , le_vars :: VarEnv (Var, LintLevel) + -- Maps a Var (i.e. its unique) to its binding Var and level + -- /All/ in-scope variables are here (term variables, + -- type variables, and coercion variables) + -- So the domain is the same as the le_in_scope in-scope set + -- Used at an occurrence of the Var , le_joins :: UniqMap Id JoinOcc -- ^ Join points in scope that are valid - -- A subset of the InScopeSet in le_subst -- See Note [Join points] , le_ue_aliases :: NameEnv UsageEnv -- See Note [Linting linearity] -- Assigns usage environments to the alias-like binders, -- as found in non-recursive lets. - -- Domain is OutIds , le_platform :: Platform -- ^ Target platform , le_diagOpts :: DiagOpts -- ^ Target platform @@ -3011,7 +2944,8 @@ data LintFlags , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism] , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals] - , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_beta_joins :: Bool -- ^ See Note [Join points and beta-redexes] } -- See Note [Checking StaticPtrs] @@ -3078,20 +3012,6 @@ top-level bindings. See SimplCore Note [Grand plan for static forms]. The linter checks that no occurrence or `makeStatic` occurs nested. -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - Note [Linting type synonym applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When linting a type-synonym, or type-family, application @@ -3353,12 +3273,12 @@ initL cfg m where vars = l_vars cfg init_level = 0 - env = LE { le_flags = l_flags cfg - , le_subst = mkEmptySubst (mkInScopeSetList vars) - , le_level = init_level - , le_in_vars = mkVarEnv [ (v,(v, varType v, init_level)) | v <- vars ] - , le_joins = emptyUniqMap - , le_loc = [] + env = LE { le_flags = l_flags cfg + , le_level = init_level + , le_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ] + , le_in_scope = mkInScopeSetList vars + , le_joins = emptyUniqMap + , le_loc = [] , le_ue_aliases = emptyNameEnv , le_platform = l_platform cfg , le_diagOpts = l_diagOpts cfg @@ -3421,8 +3341,7 @@ addMsg show_context env msgs msg loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first loc_msgs = map dumpLoc (le_loc env) - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] + cxt_doc = vcat $ reverse $ map snd loc_msgs context | show_context = cxt_doc | otherwise = whenPprDebug cxt_doc @@ -3449,72 +3368,44 @@ inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs is_case_pat (LE { le_loc = CasePat {} : _ }) = True is_case_pat _other = False -addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a +addInScopeId :: Id -> LintM a -> LintM a -- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned -addInScopeId in_id out_ty thing_inside +addInScopeId id thing_inside = LintM $ \ env errs -> - let !(out_id, env') = add env - in unLintM (thing_inside out_id) env' errs - + unLintM thing_inside (add env) errs where - add env@(LE { le_level = level, le_in_vars = id_vars, le_joins = valid_joins - , le_ue_aliases = aliases, le_subst = subst }) - = (out_id, env1) + add env@(LE { le_level = level, le_vars = id_vars, le_joins = valid_joins + , le_ue_aliases = aliases, le_in_scope = in_scope }) + = env { le_level = level1, le_vars = in_vars' + , le_in_scope = in_scope `extendInScopeSet` id + , le_joins = valid_joins', le_ue_aliases = aliases' } where level1 = level + 1 - env1 = env { le_level = level1, le_in_vars = in_vars' - , le_joins = valid_joins', le_ue_aliases = aliases' } - in_vars' = extendVarEnv id_vars in_id (in_id, out_ty, level1) - aliases' = delFromNameEnv aliases (idName in_id) + in_vars' = extendVarEnv id_vars id (id, level1) + aliases' = delFromNameEnv aliases (idName id) -- aliases': when shadowing an alias, we need to make sure the -- Id is no longer classified as such. E.g. -- let x = <e1> in case x of x { _DEFAULT -> <e2> } -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. - -- A very tiny optimisation, not sure if it's really worth it - -- Short-cut when the substitution is a no-op - out_id | isEmptyTCvSubst subst = in_id - | otherwise = setIdType in_id out_ty - valid_joins' - | isJoinId out_id = addToUniqMap valid_joins in_id NormalJoinOcc -- Overwrite with new arity - | otherwise = delFromUniqMap valid_joins in_id -- Remove any existing binding + | isJoinId id = addToUniqMap valid_joins id NormalJoinOcc -- Overwrite with new arity + | otherwise = delFromUniqMap valid_joins id -- Remove any existing binding -addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a +addInScopeTyCoVar :: TyCoVar -> LintM a -> LintM a -- This function clones to avoid shadowing of TyCoVars -addInScopeTyCoVar tcv tcv_type thing_inside - = LintM $ \ env@(LE { le_level = level, le_in_vars = in_vars, le_subst = subst }) errs -> - let (tcv', subst') = subst_bndr subst - level' = level + 1 +addInScopeTyCoVar tcv thing_inside + = LintM $ \ env@(LE { le_level = level, le_vars = in_vars + , le_in_scope = in_scope }) errs -> + let level' = level + 1 env' = env { le_level = level' - , le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type, level') - , le_subst = subst' } - in unLintM (thing_inside tcv') env' errs - where - subst_bndr subst - | isEmptyTCvSubst subst -- No change in kind - , not (tcv `elemInScopeSet` in_scope) -- Not already in scope - = -- Do not extend the substitution, just the in-scope set - (if (varType tcv `eqType` tcv_type) then (\x->x) else - pprTrace "addInScopeTyCoVar" ( - vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv) - , text "tcv_type" <+> ppr tcv_type ])) $ - (tcv, subst `extendSubstInScope` tcv) - - -- Clone, and extend the substitution - | let tcv' = uniqAway in_scope (setVarType tcv tcv_type) - = (tcv', extendTCvSubstWithClone subst tcv tcv') - where - in_scope = substInScopeSet subst - -getInVarEnv :: LintM (VarEnv (InId, OutType, LintLevel)) -getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) + , le_in_scope = in_scope `extendInScopeSet` tcv + , le_vars = extendVarEnv in_vars tcv (tcv, level') } + in unLintM thing_inside env' errs -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a -extendTvSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs +getInVarEnv :: LintM (VarEnv (Id, LintLevel)) +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_vars env), errs)) markAllJoinsBad :: LintM a -> LintM a markAllJoinsBad m @@ -3549,54 +3440,42 @@ markAllJoinsBadIf False m = m getValidJoins :: LintM (UniqMap Id JoinOcc) getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) -getSubst :: LintM Subst -getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) - -substTyM :: InType -> LintM OutType --- Apply the substitution to the type --- The substitution is often empty, in which case it is a no-op -substTyM ty - = do { subst <- getSubst - ; return (substTy subst ty) } - getUEAliases :: LintM (NameEnv UsageEnv) getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs)) +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (le_in_scope env), errs)) -lintVarOcc :: InVar -> LintM OutType +lintVarOcc :: Var -> LintM () -- Used at an occurrence of a variable: term variables, type variables, and coercion variables -- Checks -- - that it is in scope -- - that it is not a GlobalId bound by a LocalId --- - that the InType at the ocurrence matches the InType at the binding site +-- - that the Type at the ocurrence matches the Type at the binding site -- - that the variables free in its type are not shadowed at the occurrence site lintVarOcc v_occ | isGlobalId v_occ - = return (idType v_occ) + = return () | otherwise = do { in_var_env <- getInVarEnv ; case lookupVarEnv in_var_env v_occ of Nothing -> failWithL (text pp_what <+> quotes (ppr v_occ) <+> text "is out of scope") - Just (v_bndr, out_ty, bind_level) + Just (v_bndr, bind_level) -> do { let bndr_ty = idType v_bndr ; check_bad_global v_bndr ; check_occ_type_match bndr_ty - ; check_occ_type_scope in_var_env bndr_ty bind_level - ; return out_ty } - + ; check_occ_type_scope in_var_env bndr_ty bind_level } } where - occ_ty :: InType + occ_ty :: Type occ_ty = idType v_occ pp_what | isTyVar v_occ = "The type variable" | isCoVar v_occ = "The coercion variable" | otherwise = "The value variable" - check_bad_global :: InVar -> LintM () + check_bad_global :: Var -> LintM () -- 'check_bad_global' checks for the case where an /occurrence/ is -- a GlobalId, but there is an enclosing binding for a LocalId. -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, @@ -3616,26 +3495,26 @@ lintVarOcc v_occ | otherwise = return () - check_occ_type_match :: InType -> LintM () + check_occ_type_match :: Type -> LintM () -- Check that the type in /binder/ and the type in the /occurrence/ are the same check_occ_type_match bndr_ty - = ensureEqTys bndr_ty occ_ty $ -- Compares InTypes + = ensureEqTys bndr_ty occ_ty $ -- Compares Types mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty - check_occ_type_scope :: VarEnv (InVar,OutType,LintLevel) -> InType -> LintLevel -> LintM () + check_occ_type_scope :: VarEnv (Var,LintLevel) -> Type -> LintLevel -> LintM () -- Check that the free vars of the binder's type -- are not shadowed at the occurrence site check_occ_type_scope in_var_env bndr_ty bind_level = checkL (null bad_fvs) $ mkBndrOccFreeVarMsg v_occ occ_ty bad_fvs where - bad_fvs :: [InVar] + bad_fvs :: [Var] bad_fvs = filter is_bad (tyCoVarsOfTypeList bndr_ty) - is_bad :: InVar -> Bool + is_bad :: Var -> Bool -- True of a variable bound inside bind_level is_bad v = case lookupVarEnv in_var_env v of - Just (_, _, v_level) -> v_level > bind_level + Just (_, v_level) -> v_level > bind_level Nothing -> True lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc)) @@ -3647,21 +3526,21 @@ lookupJoinId id Just join_occ -> return $ Just (idJoinArity id, join_occ) Nothing -> return Nothing } -addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a addAliasUE id ue thing_inside = LintM $ \ env errs -> let new_ue_aliases = extendNameEnv (le_ue_aliases env) (getName id) ue in unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs -varCallSiteUsage :: OutId -> LintM UsageEnv +varCallSiteUsage :: Id -> LintM UsageEnv varCallSiteUsage id = do m <- getUEAliases return $ case lookupNameEnv m (getName id) of Nothing -> singleUsageUE id Just id_ue -> id_ue -ensureEqTys :: OutType -> OutType -> SDoc -> LintM () +ensureEqTys :: Type -> Type -> SDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied @@ -3885,7 +3764,7 @@ mkLetErr bndr rhs hang (text "Rhs:") 4 (ppr rhs)] -mkTyAppMsg :: OutType -> Type -> SDoc +mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (text "Function type:") @@ -4006,13 +3885,13 @@ mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ , text "Arity at binding site:" <+> ppr join_arity_bndr , text "Arity at occurrence: " <+> ppr join_arity_occ ] -mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc +mkBndrOccTypeMismatchMsg :: Var -> Type -> Type -> SDoc mkBndrOccTypeMismatchMsg var bndr_ty occ_ty = vcat [ text "Mismatch in type between binder and occurrence" , text "Binder: " <+> ppr var <+> dcolon <+> ppr bndr_ty , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] -mkBndrOccFreeVarMsg :: InVar -> InType -> [TyCoVar] -> SDoc +mkBndrOccFreeVarMsg :: Var -> Type -> [TyCoVar] -> SDoc mkBndrOccFreeVarMsg var occ_ty bad_tvs = vcat [ text "Free vars of type are shadowed:" <+> ppr bad_tvs , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] ===================================== compiler/GHC/Core/Lint/SubstTypeLets.hs ===================================== @@ -0,0 +1,140 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +module GHC.Core.Lint.SubstTypeLets( + substTypeLets + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils( mkInScopeSetBndrs ) + +import GHC.Types.Var + +import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- Note [Substituting type-lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When desugaring pattern matching we really, really need non-Lint-acceptable type-lets. +Suppose we have + f (MkT a (Just a (x::a)) (y::a)) = rhs1 + f (MkT b (Nothing b) (z::b)) = rhs2 +where + MkT :: ∀ a. Maybe a -> a -> T + +We desugar this to + f x = case x of + MkT w (v :: Maybe w) (p:w) + -> let { a=w, b=w } + in let { y:a=p, z:b=p } + in case v of + Just a (x:a) -> rhs1 [y::a] + Nothing b -> rhs2 [z::b] + +Look at those type-lets { a=w, b=w }. They make the type variables in the +/two/ separately-typechecked clauses for `f` line up with the /single/ pattern +match on `x`, which binds the type variable `w`. + +Key point: the body of the let is only type-correct /after/ substituting +a:=w, b:=w. Even the next let, { y:a=p } isn't type-correct without that +substitution, because (p:w). + +So the `substTypeLets` pass does this: + - It runs as part of Lint, as a pre-pass before the main Lint + - It runs only when we are Linting the output of the desugarer + - The result of substTypeLets is discarded after linting + +When it finds a nested type-let + let @a = ty in body +it substitutes a:=ty in `body` + +Wrinkles + +(STL1) It only substitutes /nested/ type-lets, not top level. + +(STL2) You might think that we'd run it unconditionally, after desugaring. But actually, + the Simplifier (or SimpleOpt) will deal with these type-lets, so it is just Lint + that we must placate. We don't want to incur the cost of this pass except when + we are Linting. + + TL;DR: we do substTypeLets as a pre-pass to the Lint pass that immediately follows + desugaring. See `GHC.Core.lintPassResult`, and the `lpr_preSubst` field in + `LintPassResultConfig`. + +(STL3) Should `substTypeLets` process (stable) unfoldings? It does not need to + because all unfoldings have `simpleOptExpr` applied to them, so the tricky + type-lets will already be substituted. + + Of course we stil need to apply the current substitution, but that is done + automatically by `substBndr`. +-} + +substTypeLets :: CoreProgram -> CoreProgram +substTypeLets binds = map stl_top binds + where + stl_top (NonRec b r) = NonRec b (stlExpr empty_subst r) + stl_top (Rec prs) = Rec (mapSnd (stlExpr empty_subst) prs) + + empty_subst = mkEmptySubst $ + mkInScopeSetBndrs binds + +---------------------- +stlBind :: Subst -> CoreBind -> (Subst, CoreBind) +stlBind subst (Rec prs) + = assertPpr (not (any isTyVar bndrs)) (ppr prs) $ + (subst', Rec prs') + where + (bndrs,rhss) = unzip prs + (subst', bndrs') = substRecBndrs subst bndrs + -- substRecBndrs: see (STL3) in Note [Substituting type-lets] + rhss' = map (stlExpr subst') rhss + prs' = bndrs' `zip` rhss' + +stlBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (stlExpr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + -- substBndr: see (STL3) in Note [Substituting type-lets] + +---------------------- +stlExpr :: Subst -> CoreExpr -> CoreExpr + +stlExpr subst (Let (NonRec tv (Type ty)) body) + = -- This equation is the main payload of the entire pass! + stlExpr (extendTvSubst subst tv (substTy subst ty)) body + +stlExpr subst (Let bind body) + = Let bind' (stlExpr subst' body) + where + (subst', bind') = stlBind subst bind + +stlExpr subst (Lam bndr body) + = Lam bndr' (stlExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + +stlExpr subst (Case scrut bndr ty alts) + = Case (stlExpr subst scrut) bndr' (substTy subst ty) + (map stl_alt alts) + where + (subst', bndr') = substBndr subst bndr + + stl_alt (Alt con bndrs rhs) + = Alt con bndrs' (stlExpr subst'' rhs) + where + (subst'', bndrs') = substBndrs subst' bndrs + +-- Simple cases +stlExpr _ (Lit l) = Lit l +stlExpr subst (Var v) = lookupIdSubst subst v +stlExpr subst (App e1 e2) = App (stlExpr subst e1) (stlExpr subst e2) +stlExpr subst (Type ty) = Type (substTy subst ty) +stlExpr subst (Tick t e) = Tick (substTickish subst t) (stlExpr subst e) +stlExpr subst (Cast e co) = Cast (stlExpr subst e) (substCo subst co) +stlExpr subst (Coercion co) = Coercion (substCo subst co) ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2676,6 +2676,8 @@ occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> WithUsageDetails CoreExpr -- The `fun` argument is just an accumulating parameter, -- the base for building the application we return +-- +-- We have applied markAllNonTail to the returned usage-details occAnalArgs env fun args one_shots = go emptyDetails fun args one_shots where @@ -2686,7 +2688,9 @@ occAnalArgs env fun args one_shots encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut | otherwise = OccVanilla - go uds fun [] _ = WUD uds fun + go uds fun [] _ = WUD (markAllNonTail uds) fun + -- markAllNonTail: calls in arguments are not tail calls! + go uds fun (arg:args) one_shots = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots' where @@ -2778,8 +2782,7 @@ occAnalApp env (Var fun_id, args, ticks) all_uds = fun_uds `andUDs` final_args_uds - !final_args_uds = markAllNonTail $ - markAllInsideLamIf (isRhsEnv env && is_exp) $ + !final_args_uds = markAllInsideLamIf (isRhsEnv env && is_exp) $ -- isRhsEnv: see Note [OccEncl] args_uds -- We mark the free vars of the argument of a constructor or PAP @@ -2809,20 +2812,27 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = let app_out = mkTicks ticks app' - in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out - + = WUD (fun_uds `andUDs` args_uds) (mkTicks ticks app') where !(WUD args_uds app') = occAnalArgs env fun' args [] - !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexes like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some OneShotLam items - -- onto the context stack. + !(WUD fun_uds fun') = go_fun env fun args + + -- See (A2) in Note [occAnal for applications] + go_fun env (Lam bndr body) (_ : args) + = addInScopeOne env bndr $ \ env' -> + let !(WUD body_uds body') = go_fun env' body args + !bndr' = tagLamBinder body_uds bndr + in WUD body_uds (Lam bndr' body') + go_fun env fun args + | null args + = occAnal env fun + | otherwise + = let !env' = addAppCtxt env args + !(WUD fun_uds fun') = occAnal env' fun + in WUD (markAllNonTail fun_uds) fun' addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +-- See (A3) in Note [occAnal for applications] addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args | n_val_args > 0 = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt @@ -2834,8 +2844,40 @@ addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args where n_val_args = valArgCount args +{- Note [occAnal for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One iteration of the simplifier sometimes leaves behind beta redexes like + (\x y -> e) a1 a2 +This happens particularly in worker/wrapper; see Note [Join points and beta-redexes] +in GHC.Core.Lint. In these cases there are three things we want to take care of +in the occurrence analyser: + +(A1) We don't want to mark variables inside `e` as `InsideLam`; that would just + delay inlining them for another iteration of the Simplifier. + +(A2) If there is a join-point invocation inside `e`, we don't want to complain about + lost join points. See Note [Join points and beta-redexes] in GHC.Core.Lint for + more detail. + +(A3) Suppose we have something like + (case e of (a,b) -> (\x.blah) |> co) arg + which can happen during 'gentle' simplification when we don't do case-of-case, + not push arguments into cases. Then we'd still like to mark that lambda + as one-shot, so that things can get inlined inside it. We can to this + by pushing OneShotLam items onto the context stack. + + Live example: `read_tup4` in test CoOpt_Read. + +How we address these: + +* (A2): we focus narrowly on visible beta-redexes ((\x.e) arg), since that + is what is needed for Note [Join points and beta-redexes]. We do this + via the `go_fun` loop in `occAnalApp`. + +* (A1) and (A3): for visible beta-redexes, the `go_fun` loop does the job. + But for less-visible ones, like in (A3) we push `OneShotLam` items onto + the context stack, in `addAppCtxt`. -{- Note [Sources of one-shot information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The occurrence analyser obtains one-shot-lambda information from two sources: ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -241,10 +241,10 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr = (work_args, work_args, work_marks) call_work work_fn = mkVarApps (Var work_fn) work_call_args - call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args - -- See Note [Join points and beta-redexes] + call_rhs fn_rhs = mkApps fn_rhs fn_args + -- See Note [Join points and beta-redexes] in GHC.Core.Lint wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work - -- See Note [Call-by-value for worker args] + -- See Note [Call-by-value for worker args] work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] @@ -280,14 +280,6 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr arity_ok | isJoinId fun_id = ww_arity <= n_dmds | otherwise = ww_arity == n_dmds --- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. --- PRECONDITION: The arg expressions are not free in any of the lambdas binders. -mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr --- The precondition holds for our call site in mkWwBodies, because all the FVs --- of as are either cloned_arg_vars (and thus fresh) or fresh worker args. -mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as -mkAppsBeta f as = mkApps f as - -- See Note [Limit w/w arity] isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool isWorkerSmallEnough max_worker_args old_n_args vars @@ -525,36 +517,6 @@ Solution is simple: put the void argument /last/: c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr -Note [Join points and beta-redexes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, the worker would invoke the original function by calling it with -arguments, thus producing a beta-redex for the simplifier to munch away: - - \x y z -> e => (\x y z -> e) wx wy wz - -Now that we have special rules about join points, however, this is Not Good if -the original function is itself a join point, as then it may contain invocations -of other join points: - - join j1 x = ... - join j2 y = if y == 0 then 0 else j1 y - - => - - join j1 x = ... - join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy - join j2 y = case y of I# y# -> jump $wj2 y# - -There can't be an intervening lambda between a join point's declaration and its -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: - - ... - let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y - ... - -Hence we simply do the beta-reduction here. (This would be harder if we had to -worry about hygiene, but luckily wy is freshly generated.) - Note [Freshen WW arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we do a worker/wrapper split, we must freshen the arg vars of the original ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -13,7 +13,8 @@ module GHC.Core.Subst ( -- ** Substituting into expressions and related types deShadowBinds, substRuleInfo, substRulesForImportedIds, - substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, + substTy, substTyUnchecked, substCo, + substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, @@ -42,8 +43,7 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils - -- We are defining local versions -import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Type import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr ) import GHC.Core.TyCo.FVs ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -1,7 +1,6 @@ module GHC.Driver.Config.Core.Lint ( endPass , endPassHscEnvIO - , lintCoreBindings , initEndPassConfig , initLintPassResultConfig , initLintConfig @@ -50,16 +49,6 @@ endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules binds rules } --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs -lintCoreBindings dflags coreToDo vars -- binds - = lintCoreBindings' $ LintConfig - { l_diagOpts = initDiagOpts dflags - , l_platform = targetPlatform dflags - , l_flags = perPassFlags dflags coreToDo - , l_vars = vars - } - initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) @@ -104,10 +93,17 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig { lpr_diagOpts = initDiagOpts dflags , lpr_platform = targetPlatform dflags , lpr_makeLintFlags = perPassFlags dflags pass - , lpr_passPpr = ppr pass + , lpr_passPpr = ppr pass + , lpr_preSubst = doPreSubst pass , lpr_localsInScope = extra_vars } +doPreSubst :: CoreToDo -> Bool +doPreSubst CoreDesugar = True -- Output of desugarer, /before/ running any optimisation, + -- not even simpleOpt. See Note Note [Substituting type-lets] + -- in GHC.Core.SubstTypeLets +doPreSubst _ = False + perPassFlags :: DynFlags -> CoreToDo -> LintFlags perPassFlags dflags pass = (defaultLintFlags dflags) @@ -116,7 +112,8 @@ perPassFlags dflags pass , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity , lf_check_rubbish_lits = check_rubbish - , lf_allow_weak_joins = allow_weak_joins } + , lf_allow_weak_joins = allow_weak_joins + , lf_allow_beta_joins = allow_beta_joins } where -- See Note [Checking for global Ids] check_globals = case pass of @@ -158,6 +155,11 @@ perPassFlags dflags pass CorePrep -> True _ -> False + -- See Note [Join points and beta-redexes] in GHC.Core.Lint + allow_beta_joins = case pass of + CoreDoWorkerWrapper -> True + _ -> False + initLintConfig :: DynFlags -> [Var] -> LintConfig initLintConfig dflags vars =LintConfig { l_diagOpts = initDiagOpts dflags @@ -175,4 +177,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False , lf_check_fixed_rep = True , lf_check_rubbish_lits = True , lf_allow_weak_joins = False + , lf_allow_beta_joins = False } ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -802,7 +802,7 @@ readUnitDatabase logger cfg conf_file = do if cache_exists then do debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) + readPackageDbForGhc filename else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it ===================================== compiler/ghc.cabal.in ===================================== @@ -361,6 +361,7 @@ Library GHC.Core.InstEnv GHC.Core.Lint GHC.Core.Lint.Interactive + GHC.Core.Lint.SubstTypeLets GHC.Core.LateCC GHC.Core.LateCC.Types GHC.Core.LateCC.TopLevelBinds ===================================== libraries/base/tests/perf/all.T ===================================== @@ -5,15 +5,13 @@ setTestOpts(js_skip) # Check optimization of `elem` #-------------------------------------- -elemCoreFilter = "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'" - def elemCoreTest(test_name, module_name, opt): test(test_name, [only_ways(['normal']), extra_files([module_name + '.hs'])], multimod_compile_filter, [module_name, f'{opt} -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds', - elemCoreFilter]) + "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'"]) elemCoreTest('T17752_O1', 'T17752', '-O1') elemCoreTest('T17752_O2', 'T17752', '-O2') ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -68,6 +68,8 @@ module GHC.Unit.Database -- * Misc , mkMungePathUrl , mungeUnitInfoPaths + , writeFileAtomic + , unsafeDecodeUtf ) where @@ -86,18 +88,23 @@ import Data.Binary.Get as Bin import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) -import System.FilePath as FilePath +import qualified System.FilePath as FilePath #if !defined(mingw32_HOST_OS) import Data.Bits ((.|.)) -import System.Posix.Files +import System.Posix.Files.PosixString import System.Posix.Types (FileMode) +import System.OsString.Internal.Types (getOsString) #endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) import qualified GHC.Data.ShortText as ST import GHC.IO.Handle.Lock -import System.Directory +import GHC.Stack.Types (HasCallStack) +import System.OsPath +import qualified System.Directory.OsPath as OsPath +import qualified System.Directory.Internal as OsPath.Internal +import qualified System.File.OsPath as FileIO -- | @ghc-boot@'s UnitInfo, serialized to the database. type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule @@ -314,13 +321,13 @@ data DbInstUnitId newtype PackageDbLock = PackageDbLock Handle -- | Acquire an exclusive lock related to package DB under given location. -lockPackageDb :: FilePath -> IO PackageDbLock +lockPackageDb :: OsPath -> IO PackageDbLock -- | Release the lock related to package DB. unlockPackageDb :: PackageDbLock -> IO () -- | Acquire a lock of given type related to package DB under given location. -lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock +lockPackageDbWith :: LockMode -> OsPath -> IO PackageDbLock lockPackageDbWith mode file = do -- We are trying to open the lock file and then lock it. Thus the lock file -- needs to either exist or we need to be able to create it. Ideally we @@ -350,10 +357,10 @@ lockPackageDbWith mode file = do (lockFileOpenIn ReadWriteMode) (const $ lockFileOpenIn ReadMode) where - lock = file <.> "lock" + lock = file <.> OsPath.Internal.os "lock" lockFileOpenIn io_mode = bracketOnError - (openBinaryFile lock io_mode) + (FileIO.openBinaryFile lock io_mode) hClose -- If file locking support is not available, ignore the error and proceed -- normally. Without it the only thing we lose on non-Windows platforms is @@ -387,7 +394,7 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- -readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] +readPackageDbForGhc :: OsPath -> IO [DbUnitInfo] readPackageDbForGhc file = decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case (pkgs, DbOpenReadOnly) -> return pkgs @@ -409,7 +416,7 @@ readPackageDbForGhc file = -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> +readPackageDbForGhcPkg :: Binary pkgs => OsPath -> DbOpenMode mode t -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg @@ -425,7 +432,7 @@ readPackageDbForGhcPkg file mode = -- | Write the whole of the package DB, both parts. -- -writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO () +writePackageDb :: Binary pkgs => OsPath -> [DbUnitInfo] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = do writeFileAtomic file (runPut putDbForGhcPkg) #if !defined(mingw32_HOST_OS) @@ -446,10 +453,10 @@ writePackageDb file ghcPkgs ghcPkgPart = do ghcPart = encode ghcPkgs #if !defined(mingw32_HOST_OS) -addFileMode :: FilePath -> FileMode -> IO () +addFileMode :: OsPath -> FileMode -> IO () addFileMode file m = do - o <- fileMode <$> getFileStatus file - setFileMode file (m .|. o) + o <- fileMode <$> getFileStatus (getOsString file) + setFileMode (getOsString file) (m .|. o) #endif getHeader :: Get (Word32, Word32) @@ -496,7 +503,7 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0" -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> +decodeFromFile :: OsPath -> DbOpenMode mode t -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do @@ -517,7 +524,7 @@ decodeFromFile file mode decoder = case mode of bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do (, DbOpenReadWrite lock) <$> decodeFileContents where - decodeFileContents = withBinaryFile file ReadMode $ \hnd -> + decodeFileContents = FileIO.withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize @@ -527,21 +534,21 @@ decodeFromFile file mode decoder = case mode of feed _ (Done _ _ res) = return res feed _ (Fail _ _ msg) = ioError err where - err = mkIOError InappropriateType loc Nothing (Just file) + err = mkIOError InappropriateType loc Nothing (Just $ unsafeDecodeUtf file) `ioeSetErrorString` msg loc = "GHC.Unit.Database.readPackageDb" -- Copied from Cabal's Distribution.Simple.Utils. -writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () +writeFileAtomic :: OsPath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> OsPath.Internal.os "tmp") + (\(tmpPath, handle) -> hClose handle >> OsPath.removeFile tmpPath) (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle - renameFile tmpPath targetPath) + OsPath.renameFile tmpPath targetPath) instance Binary DbUnitInfo where put (GenericUnitInfo @@ -711,7 +718,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case ST.stripPrefix var path of Just "" -> Just "" - Just cs | isPathSeparator (ST.head cs) -> Just cs + Just cs | FilePath.isPathSeparator (ST.head cs) -> Just cs _ -> Nothing @@ -742,3 +749,8 @@ mungeUnitInfoPaths top_dir pkgroot pkg = munge_paths = map munge_path munge_urls = map munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf = OsPath.Internal.so ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -82,6 +82,8 @@ Library containers >= 0.5 && < 0.9, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.6, + file-io >= 0.1.6 && < 0.3, + os-string >= 2.0.1 && < 2.1, deepseq >= 1.4 && < 1.6, ghc-platform >= 0.1, ghc-toolchain >= 0.1 ===================================== testsuite/tests/cabal/Makefile ===================================== @@ -79,6 +79,25 @@ ghcpkg04 : @: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now '$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true +PKGCONF20=local20.package.conf +LOCAL_GHC_PKG20 = '$(GHC_PKG)' --no-user-package-db + +DIR1=asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf +DIR2=zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv +DIR3=uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop +DIR4=qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer +WDIR=$(DIR1)/$(DIR2)/$(DIR3)/$(DIR4) +.PHONY: ghcpkg10 +ghcpkg10 : + @mkdir -p $(WDIR) + @rm -rf $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) init $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) list + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) register --force test.pkg 2>/dev/null + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg-1.2.3.4 | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) field testpkg-1.2.3.4 import-dirs + # Test stacking of package.confs (also #2441) PKGCONF05a=local05a.package.conf PKGCONF05b=local05b.package.conf ===================================== testsuite/tests/cabal/all.T ===================================== @@ -5,6 +5,7 @@ def ignore_warnings(str): return re.sub(r'Warning:.*\n', '', str) test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) +test('ghcpkg10', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO): # warning: haddock-interfaces .. doesn't exist or isn't a file ===================================== testsuite/tests/cabal/ghcpkg10.stdout ===================================== @@ -0,0 +1,50 @@ +asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf/zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv/uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop/qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer/local20.package.conf + (no packages) +Reading package info from "test.pkg" ... done. +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" ===================================== testsuite/tests/corelint/LintEtaExpand.stderr ===================================== @@ -1,32 +1,16 @@ <no location info>: warning: • The first argument of ‘coerce’ does not have a fixed runtime representation: a :: TYPE k - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in coerce BAD 1 <no location info>: warning: • The first argument of ‘coerce’ does not have a fixed runtime representation: ‘q’ is not concrete. - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in coerce BAD 2 <no location info>: warning: • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation: a :: TYPE q - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in catch# BAD 1 <no location info>: warning: • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation: ‘q’ is not concrete. - Substitution: <InScope = {a q} - IdSubst = [] - TvSubst = [] - CvSubst = []> in catch# BAD 2 ===================================== testsuite/tests/corelint/T21115b.stderr ===================================== @@ -6,10 +6,6 @@ T21115b.hs:9:1: warning: In the body of lambda with binder ds :: Double# In the body of a let with binder fail :: (# #) -> Int# In the body of a let with binder fail :: (# #) -> Int# - Substitution: <InScope = {} - IdSubst = [] - TvSubst = [] - CvSubst = []> *** Offending Program *** Rec { $trModule = Module (TrNameS "main"#) (TrNameS "T21115b"#) ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -47,12 +47,19 @@ import Distribution.Types.UnqualComponentName import Distribution.Types.LibraryName import Distribution.Types.MungedPackageName import Distribution.Types.MungedPackageId -import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File) +import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS) import qualified Data.Version as Version -import System.FilePath as FilePath +import System.OsPath as OsPath +import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, - getModificationTime, XdgDirectory ( XdgData ) ) +import System.Directory.OsPath + ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory, + getModificationTime, XdgDirectory ( XdgData ), + doesDirectoryExist, getDirectoryContents, + doesFileExist, removeFile, + getCurrentDirectory ) +import System.Directory.Internal (os) +import qualified System.File.OsPath as FileIO import Text.Printf import Prelude hiding (Foldable(..)) @@ -65,15 +72,13 @@ import Data.Bifunctor import Data.Char ( toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, removeFile, - getCurrentDirectory ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error -import GHC.IO ( catchException ) +import GHC.IO ( catchException, unsafePerformIO ) import GHC.IO.Exception (IOErrorType(InappropriateType)) +import GHC.Stack.Types (HasCallStack) import Data.List ( group, sort, sortBy, nub, partition, find , intercalate, intersperse, unfoldr , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix ) @@ -429,8 +434,9 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif - ["init", filename] -> - initPackageDB filename verbosity cli + ["init", filename] -> do + filenameOs <- encodeFS filename + initPackageDB filenameOs verbosity cli ["register", filename] -> registerPackage filename verbosity cli multi_instance @@ -538,7 +544,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str data PackageDB (mode :: GhcPkg.DbMode) = PackageDB { - location, locationAbsolute :: !FilePath, + location, locationAbsolute :: !OsPath, -- We need both possibly-relative and definitely-absolute package -- db locations. This is because the relative location is used as -- an identifier for the db, so it is important we do not modify it. @@ -570,14 +576,14 @@ allPackagesInStack = concatMap packages -- specified package DB can depend on, since dependencies can only extend -- down the stack, not up (e.g. global packages cannot depend on user -- packages). -stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack +stackUpTo :: OsPath -> PackageDBStack -> PackageDBStack stackUpTo to_modify = dropWhile ((/= to_modify) . location) -readFromSettingsFile :: FilePath - -> (FilePath -> RawSettings -> Either String b) +readFromSettingsFile :: OsPath + -> (OsPath -> RawSettings -> Either String b) -> IO (Either String b) readFromSettingsFile settingsFile f = do - settingsStr <- readFile settingsFile + settingsStr <- readUtf8File settingsFile pure $ do mySettings <- case maybeReadFuzzy settingsStr of Just s -> pure $ Map.fromList s @@ -586,11 +592,11 @@ readFromSettingsFile settingsFile f = do Nothing -> Left $ "Can't parse settings file " ++ show settingsFile f settingsFile mySettings -readFromTargetFile :: FilePath +readFromTargetFile :: OsPath -> (Target -> b) -> IO (Either String b) readFromTargetFile targetFile f = do - targetStr <- readFile targetFile + targetStr <- readUtf8File targetFile pure $ do target <- case maybeReadFuzzy targetStr of Just t -> Right t @@ -626,33 +632,35 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do case [ f | FlagGlobalConfig f <- my_flags ] of -- See Note [Base Dir] for more information on the base dir / top dir. [] -> do mb_dir <- getBaseDir - case mb_dir of + mb_dir_os <- traverse encodeFS mb_dir + case mb_dir_os of Nothing -> die err_msg Just dir -> do -- Look for where it is given in the settings file, if marked there. -- See Note [Settings file] about this file, and why we need GHC to share it with us. - let settingsFile = dir </> "settings" + let settingsFile = dir </> os "settings" exists_settings_file <- doesFileExist settingsFile erel_db <- if exists_settings_file - then readFromSettingsFile settingsFile getGlobalPackageDb - else pure (Left ("Settings file doesn't exist: " ++ settingsFile)) + then do + readFromSettingsFile settingsFile (\ settings -> getGlobalPackageDb (unsafeDecodeUtf settings)) + else pure (Left ("Settings file doesn't exist: " ++ showOsPath settingsFile)) case erel_db of - Right rel_db -> return (dir, dir </> rel_db) + Right rel_db -> return (dir, dir </> unsafeEncodeUtf rel_db) -- If the version of GHC doesn't have this field or the settings file -- doesn't exist for some reason, look in the libdir. Left err -> do r <- lookForPackageDBIn dir case r of - Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)]) + Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ showOsPath dir)]) Just path -> return (dir, path) fs -> do -- The value of the $topdir variable used in some package descriptions -- Note that the way we calculate this is slightly different to how it -- is done in ghc itself. We rely on the convention that the global -- package db lives in ghc's libdir. - let pkg_db = last fs + let pkg_db = unsafeEncodeUtf $ last fs top_dir <- absolutePath (takeDirectory pkg_db) return (top_dir, pkg_db) @@ -662,10 +670,10 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- getXdgDirectory can fail (e.g. if $HOME isn't set) mb_user_conf <- - case [ f | FlagUserConfig f <- my_flags ] of + case [ unsafeEncodeUtf f | FlagUserConfig f <- my_flags ] of _ | no_user_db -> return Nothing [] -> do - let targetFile = top_dir </> "targets" </> "default.target" + let targetFile = top_dir </> os "targets" </> os "default.target" exists_settings_file <- doesFileExist targetFile targetArchOS <- case exists_settings_file of False -> do @@ -694,15 +702,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR -- -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version - m_appdir <- getFirstSuccess $ map (fmap (</> subdir)) - [ getAppUserDataDirectory "ghc" -- this is ~/.ghc/ - , getXdgDirectory XdgData "ghc" -- this is $XDG_DATA_HOME/ + m_appdir <- getFirstSuccess $ map (fmap (</> unsafeEncodeUtf subdir)) + [ getAppUserDataDirectory $ os "ghc" -- this is ~/.ghc/ + , getXdgDirectory XdgData $ os "ghc" -- this is $XDG_DATA_HOME/ ] case m_appdir of Nothing -> return Nothing Just dir -> do lookForPackageDBIn dir >>= \case - Nothing -> return (Just (dir </> "package.conf.d", False)) + Nothing -> return (Just (dir </> os "package.conf.d", False)) Just f -> return (Just (f, True)) fs -> return (Just (last fs, True)) @@ -716,11 +724,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = - case e_pkg_path of + case fmap unsafeEncodeUtf e_pkg_path of Left _ -> sys_databases Right path - | not (null path) && isSearchPathSeparator (last path) - -> splitSearchPath (init path) ++ sys_databases + | hasTrailingPathSeparator path + -> splitSearchPath (dropTrailingPathSeparator path) <> sys_databases | otherwise -> splitSearchPath path @@ -733,7 +741,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf - is_db_flag (FlagConfig f) = Just f + is_db_flag (FlagConfig f) = Just $ unsafeEncodeUtf f is_db_flag _ = Nothing let flag_db_names | null db_flags = env_stack @@ -748,7 +756,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do -- stack, unless any of them are present in the stack -- already. let final_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] + [ unsafeEncodeUtf f | FlagConfig f <- reverse my_flags ] ++ env_stack top_db = if null db_flags @@ -764,7 +772,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do when (verbosity > Normal) $ do infoLn ("db stack: " ++ show (map location db_stack)) F.forM_ db_to_operate_on $ \db -> - infoLn ("modifying: " ++ (location db)) + infoLn ("modifying: " ++ showOsPath (location db)) infoLn ("flag db stack: " ++ show (map location flag_db_stack)) return (db_stack, db_to_operate_on, flag_db_stack) @@ -843,17 +851,19 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do return (db_stack, GhcPkg.DbOpenReadWrite to_modify) where - couldntOpenDbForModification :: FilePath -> IOError -> IO a + couldntOpenDbForModification :: OsPath -> IOError -> IO a couldntOpenDbForModification db_path e = die $ "Couldn't open database " - ++ db_path ++ " for modification: " ++ show e + ++ showOsPath db_path ++ " for modification: " ++ show e -- Parse package db in read-only mode. - readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly) + readDatabase :: OsPath -> IO (PackageDB 'GhcPkg.DbReadOnly) readDatabase db_path = do db <- readParseDatabase verbosity mb_user_conf GhcPkg.DbOpenReadOnly use_cache db_path if expand_vars - then return $ mungePackageDBPaths top_dir db + then do + top_dir_filepath <- decodeFS top_dir + return $ mungePackageDBPaths top_dir_filepath db else return db stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) @@ -863,20 +873,20 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do (as, s'') <- stateSequence s' ms return (a : as, s'') -lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn :: OsPath -> IO (Maybe OsPath) lookForPackageDBIn dir = do - let path_dir = dir </> "package.conf.d" + let path_dir = dir </> os "package.conf.d" exists_dir <- doesDirectoryExist path_dir if exists_dir then return (Just path_dir) else do - let path_file = dir </> "package.conf" + let path_file = dir </> os "package.conf" exists_file <- doesFileExist path_file if exists_file then return (Just path_file) else return Nothing readParseDatabase :: forall mode t. Verbosity - -> Maybe (FilePath,Bool) + -> Maybe (OsPath,Bool) -> GhcPkg.DbOpenMode mode t -> Bool -- use cache - -> FilePath + -> OsPath -> IO (PackageDB mode) readParseDatabase verbosity mb_user_conf mode use_cache path -- the user database (only) is allowed to be non-existent @@ -898,7 +908,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path Just db -> return db Nothing -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath path ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." | otherwise -> ioError err @@ -914,7 +924,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path -- It's fine if the cache is not there as long as the -- database is empty. when (not $ null confs) $ do - warn ("WARNING: cache does not exist: " ++ cache) + warn ("WARNING: cache does not exist: " ++ showOsPath cache) warn ("ghc will fail to read this package db. " ++ recacheAdvice) else do @@ -923,7 +933,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path ignore_cache (const $ return ()) Right tcache -> do when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + warn ("Timestamp " ++ show tcache ++ " for " ++ showOsPath cache) -- If any of the .conf files is newer than package.cache, we -- assume that cache is out of date. cache_outdated <- (`anyM` confs) $ \conf -> @@ -931,12 +941,12 @@ readParseDatabase verbosity mb_user_conf mode use_cache path if not cache_outdated then do when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) + infoLn ("using cache: " ++ showOsPath cache) GhcPkg.readPackageDbForGhcPkg cache mode >>= uncurry mkPackageDB else do whenReportCacheErrors $ do - warn ("WARNING: cache is out of date: " ++ cache) + warn ("WARNING: cache is out of date: " ++ showOsPath cache) warn ("ghc will see an old view of this " ++ "package db. " ++ recacheAdvice) ignore_cache $ \file -> do @@ -947,11 +957,11 @@ readParseDatabase verbosity mb_user_conf mode use_cache path GT -> " (older than cache)" EQ -> " (same as cache)" warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) + ++ " for " ++ showOsPath file ++ rel) where - confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs + confs = map (path </>) $ filter (os ".conf" `OsPath.isExtensionOf`) fs - ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) + ignore_cache :: (OsPath -> IO ()) -> IO (PackageDB mode) ignore_cache checkTime = do -- If we're opening for modification, we need to acquire a -- lock even if we don't open the cache now, because we are @@ -987,17 +997,18 @@ readParseDatabase verbosity mb_user_conf mode use_cache path packages = pkgs } -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf :: Verbosity -> OsPath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do - when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) - BS.readFile file >>= fmap fst . parsePackageInfo + when (verbosity > Normal) $ infoLn ("reading package config: " ++ showOsPath file) + FileIO.readFile file >>= fmap fst . parsePackageInfo . BS.toStrict + -cachefilename :: FilePath -cachefilename = "package.cache" +cachefilename :: OsPath +cachefilename = os "package.cache" mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = - db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + db { packages = map (mungePackagePaths top_dir (unsafeDecodeUtf pkgroot)) pkgs } where pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db) -- It so happens that for both styles of package db ("package.conf" @@ -1044,12 +1055,13 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p + toUrlPath :: FilePath -> FilePath -> FilePath toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : -- We need to drop a leading "/" or "\\" -- if there is one: - dropWhile (all isPathSeparator) + dropWhile (all FilePath.isPathSeparator) (FilePath.splitDirectories p)) -- We could drop the separator here, and then use </> above. However, @@ -1057,7 +1069,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case stripPrefix var path of Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs + Just cs@(c : _) | FilePath.isPathSeparator c -> Just cs _ -> Nothing -- ----------------------------------------------------------------------------- @@ -1074,18 +1086,18 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) -- ghc itself also cooperates in this workaround -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) - -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath +tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (OsPath, Bool) + -> GhcPkg.DbOpenMode mode t -> Bool -> OsPath -> IO (Maybe (PackageDB mode)) tryReadParseOldFileStyleDatabase verbosity mb_user_conf mode use_cache path = do -- assumes we've already established that path exists and is not a dir - content <- readFile path `catchIO` \_ -> return "" + content <- readUtf8File path `catchIO` \_ -> return "" if take 2 content == "[]" then do path_abs <- absolutePath path let path_dir = adjustOldDatabasePath path - warn $ "Warning: ignoring old file-style db and trying " ++ path_dir + warn $ "Warning: ignoring old file-style db and trying " ++ showOsPath path_dir direxists <- doesDirectoryExist path_dir if direxists then do @@ -1112,7 +1124,7 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) adjustOldFileStylePackageDB db = do -- assumes we have not yet established if it's an old style or not - mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing + mcontent <- liftM Just (readUtf8File (location db)) `catchIO` \_ -> return Nothing case fmap (take 2) mcontent of -- it is an old style and empty db, so look for a dir kind in location.d/ Just "[]" -> return db { @@ -1121,20 +1133,20 @@ adjustOldFileStylePackageDB db = do } -- it is old style but not empty, we have to bail Just _ -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" + ++ "databases (" ++ showOsPath (location db) ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." -- probably not old style, carry on as normal Nothing -> return db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") +adjustOldDatabasePath :: OsPath -> OsPath +adjustOldDatabasePath = (<.> os "d") -- ----------------------------------------------------------------------------- -- Creating a new package DB -initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB :: OsPath -> Verbosity -> [Flag] -> IO () initPackageDB filename verbosity _flags = do - let eexist = die ("cannot create: " ++ filename ++ " already exists") + let eexist = die ("cannot create: " ++ showOsPath filename ++ " already exists") b1 <- doesFileExist filename when b1 eexist b2 <- doesDirectoryExist filename @@ -1183,7 +1195,8 @@ registerPackage input verbosity my_flags multi_instance f -> do when (verbosity >= Normal) $ info ("Reading package info from " ++ show f ++ " ... ") - readUTF8File f + fs <- encodeFS f + readUtf8File fs expanded <- if expand_env_vars then expandEnvVars s force else return s @@ -1199,7 +1212,11 @@ registerPackage input verbosity my_flags multi_instance -- validate the expanded pkg, but register the unexpanded pkgroot <- absolutePath (takeDirectory to_modify) let top_dir = takeDirectory (location (last db_stack)) - pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + top_dir_filepath <- decodeFS top_dir + pkgroot_filepath <- decodeFS pkgroot + let + pkg_expanded = mungePackagePaths top_dir_filepath pkgroot_filepath pkg let truncated_stack = stackUpTo to_modify db_stack -- truncate the stack for validation, because we don't allow @@ -1274,13 +1291,13 @@ changeDBDir verbosity cmds db db_stack = do updateDBCache verbosity db db_stack where do_cmd (RemovePackage p) = do - let file = location db </> display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("removing " ++ file) + let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ showOsPath file) removeFileSafe file do_cmd (AddPackage p) = do - let file = location db </> display (installedUnitId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("writing " ++ file) - writeUTF8File file (showInstalledPackageInfo p) + let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ showOsPath file) + writeUtf8File file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -1338,13 +1355,13 @@ updateDBCache verbosity db db_stack = do warn $ " " ++ pkg when (verbosity > Normal) $ - infoLn ("writing cache " ++ filename) + infoLn ("writing cache " ++ showOsPath filename) let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat GhcPkg.writePackageDb filename d pkgsCabalFormat `catchIO` \e -> if isPermissionError e - then die $ filename ++ ": you don't have permission to modify this file" + then die $ showOsPath filename ++ ": you don't have permission to modify this file" else ioError e case packageDbLock db of @@ -1583,7 +1600,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do broken = map installedUnitId (brokenPackages pkg_map) show_normal PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1610,7 +1627,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do #else let show_colour PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout db_name + do hPutStrLn stdout (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1698,7 +1715,7 @@ dumpUnits verbosity my_flags expand_pkgroot = do doDump expand_pkgroot [ (pkg, locationAbsolute db) | db <- flag_db_stack, pkg <- packages db ] -doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump :: Bool -> [(InstalledPackageInfo, OsPath)] -> IO () doDump expand_pkgroot pkgs = do -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 @@ -1731,7 +1748,7 @@ findPackagesByDB db_stack pkgarg cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg - ++ maybe "" (\db -> " in " ++ location db) mdb + ++ maybe "" (\db -> " in " ++ showOsPath (location db)) mdb where pkg_msg (Id pkgid) = displayGlobPkgId pkgid pkg_msg (IUId ipid) = display ipid @@ -1944,7 +1961,7 @@ checkPackageConfig pkg verbosity db_stack checkExposedModules db_stack pkg checkOtherModules pkg let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg))) - when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) + when has_code $ mapM_ (checkHSLib verbosity (fmap unsafeEncodeUtf $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -2011,20 +2028,20 @@ checkPath url_ok is_dir warn_only thisfield d || "https://" `isPrefixOf` d) = return () | url_ok - , Just d' <- stripPrefix "file://" d - = checkPath False is_dir warn_only thisfield d' + , Just f <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield f -- Note: we don't check for $topdir/${pkgroot} here. We rely on these -- variables having been expanded already, see mungePackagePaths. - | isRelative d = verror ForceFiles $ + | isRelative d' = verror ForceFiles $ thisfield ++ ": " ++ d ++ " is a relative path which " ++ "makes no sense (as there is nothing for it to be " ++ "relative to). You can make paths relative to the " ++ "package database itself by using ${pkgroot}." -- relative paths don't make any sense; #4134 | otherwise = do - there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d + there <- liftIO $ if is_dir then doesDirectoryExist d' else doesFileExist d' when (not there) $ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " ++ if is_dir then "directory" else "file" @@ -2032,6 +2049,8 @@ checkPath url_ok is_dir warn_only thisfield d if warn_only then vwarn msg else verror ForceFiles msg + where + d' = unsafeEncodeUtf d checkDep :: PackageDBStack -> UnitId -> Validate () checkDep db_stack pkgid @@ -2050,24 +2069,25 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: Verbosity -> [String] -> String -> Validate () +checkHSLib :: Verbosity -> [OsPath] -> String -> Validate () checkHSLib _verbosity dirs lib = do - let filenames = ["lib" ++ lib ++ ".a", - "lib" ++ lib ++ "_p.a", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", - "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", - lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ ".bytecodelib" - ] + let filenames = fmap OsPath.unsafeEncodeUtf + [ "lib" ++ lib ++ ".a" + , "lib" ++ lib ++ "_p.a" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so" + , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib" + , lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + , lib ++ ".bytecodelib" + ] b <- liftIO $ doesFileExistOnPath filenames dirs when (not b) $ verror ForceFiles ("cannot find any of " ++ show filenames ++ " on library path") -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool +doesFileExistOnPath :: [OsPath] -> [OsPath] -> IO Bool doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames where fullFilenames = [ path </> filename | filename <- filenames @@ -2096,9 +2116,9 @@ checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () checkModuleFile pkg modl = -- there's no interface file for GHC.Prim unless (modl == ModuleName.fromString "GHC.Prim") $ do - let files = [ ModuleName.toFilePath modl <.> extension - | extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] - b <- liftIO $ doesFileExistOnPath files (importDirs pkg) + let files = [ unsafeEncodeUtf (ModuleName.toFilePath modl) <.> extension + | extension <- fmap os ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] + b <- liftIO $ doesFileExistOnPath files (fmap unsafeEncodeUtf $ importDirs pkg) when (not b) $ verror ForceFiles ("cannot find any of " ++ show files) @@ -2273,19 +2293,45 @@ installSignalHandlers = do return () #endif +-- ------------------------------------------------ +-- OsPath Utils + +-- | Show an 'OsPath', throwing an exception if we fail to decode it. +showOsPath :: HasCallStack => OsPath -> FilePath +showOsPath = unsafePerformIO . decodeFS + +-- | Turn a path relative to the current directory into a (normalised) +-- absolute path. +absolutePath :: OsPath -> IO OsPath +absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory + +-- ------------------------------------------------ + catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = catchException tryIO :: IO a -> IO (Either Exception.IOException a) tryIO = Exception.try --- removeFileSave doesn't throw an exceptions, if the file is already deleted -removeFileSafe :: FilePath -> IO () +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +-- | 'removeFileSave' doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: OsPath -> IO () removeFileSafe fn = removeFile fn `catchIO` \ e -> when (not $ isDoesNotExistError e) $ ioError e --- | Turn a path relative to the current directory into a (normalised) --- absolute path. -absolutePath :: FilePath -> IO FilePath -absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory +-- | Read a file using UTF-8 encoding +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656d… +-- and adapted to 'OsPath'. +writeUtf8File :: OsPath -> String -> IO () +writeUtf8File file contents = writeFileAtomic file (toUTF8LBS contents) + +-- | Read a file and interpret its content to be UTF-8 encoded. +-- +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656d… +-- and adapted to 'OsPath'. +readUtf8File :: OsPath -> IO String +readUtf8File file = (ignoreBOM . fromUTF8LBS) <$> FileIO.readFile file ===================================== utils/ghc-pkg/ghc-pkg.cabal.in ===================================== @@ -25,6 +25,7 @@ Executable ghc-pkg process >= 1 && < 1.7, containers, filepath, + file-io, Cabal, Cabal-syntax, binary, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db7c03e14314adcd049e283cc1ad8f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db7c03e14314adcd049e283cc1ad8f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/T27156] 31 commits: Bump directory submodule to 1.3.11.0 (unreleased)
by Apoorv Ingle (＠ani) 17 Apr '26

17 Apr '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: b135a87d by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump directory submodule to 1.3.11.0 (unreleased) - - - - - 3a291d07 by Zubin Duggal at 2026-04-09T19:36:50+05:30 Bump file-io submodule to 0.2.0 - - - - - e0ab606d by Zubin Duggal at 2026-04-10T18:40:20+05:30 Release notes for GHC 10.0 - - - - - e08b9b34 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump ghc-prim version to 0.14.0 - - - - - a92aac6e by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump template-haskell to 2.25.0.0; update submodule exceptions for TH 2.25 - - - - - f254d9e8 by Zubin Duggal at 2026-04-10T18:40:20+05:30 Bump GHC version to 10.0 - - - - - 6ce0368a by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump base to 4.23.0.0; update submodules for base 4.24 upper bound - - - - - 702fb8a5 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Bump GHC version to 10.1; update submodules template-haskell-lift and template-haskell-quasiquoter for ghc-internal 10.200 - - - - - 75df1ca4 by Zubin Duggal at 2026-04-10T18:40:28+05:30 Use changelog.d for release notes (#26002) GHC now uses a fragment-based changelog workflow using a custom script adapted from https://codeberg.org/fgaz/changelog-d. Contributors add a file in changelog.d/ for each user-facing change. At release time, these are assembled into release notes for sphinx (in RST) format, using the tool. New hadrian `changelog` target to generate changelogs CI job to validate changelog entries for MRs unless skipped with ~"no-changelog" label Teach sphinx about ghc-mr: extlink to link to MRs Remove `ghc-package-list` from sphinx, and implement it in changelog-d instead (Fixes #26476). (cherry picked from commit 989c07249978f418dfde1353abfad453f024d61a) - - - - - 585d7450 by Luite Stegeman at 2026-04-11T02:17:13-04:00 tc: discard warnings in tcUserStmt Plan C We typecheck let_stmt twice, but we don't want the warnings twice! see #26233 - - - - - 2df604e9 by Sylvain Henry at 2026-04-11T02:19:30-04:00 Introduce TargetInt to represent target's Int (#15973) GHC was using host 'Int' in several places to represent values that live in the target machine's 'Int' type. This is silently wrong when cross-compiling from a 32-bit host to a 64-bit target: the host Int is 32 bits while the target Int is 64 bits. See Note [TargetInt] in GHC.Platform. Also used the opportunity to make DynTag = Word8. Fixes #15973 Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - d419e972 by Luite Stegeman at 2026-04-13T15:16:04-04:00 Suppress desugaring warnings in the pattern match checker Avoid duplicating warnings from the actual desugaring pass. fixes #25996 - - - - - c5b80dd0 by Phil de Joux at 2026-04-13T15:16:51-04:00 Typo ~/ghc/arch-os-version/environments - - - - - 71462fff by Luite Stegeman at 2026-04-13T15:17:38-04:00 add changelog entry for #26233 - - - - - d1ddfd4b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add test for #25636 The existing test behaviour of "T23146_liftedeq" changed because the simplifier now does a bit more inlining. We can restore the previous bad behavior by using an OPAQUE pragma. This test doubles as a test for #25636 when run in ghci, so we add it as such. - - - - - b9df40ee by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: protoBCOName is always a Name Simplifies the code by removing the unnecessary type argument to ProtoBCO which was always 'Name' - - - - - 5c2a179e by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Allocate static constructors for bytecode This commit adds support for static constructors when compiling and linking ByteCode objects. Top-level StgRhsCon get lowered to ProtoStaticCons rather than to ProtoBCOs. A ProtoStaticCon gets allocated directly as a data con application on the heap (using the new primop newConApp#). Previously, we would allocate a ProtoBCO which, when evaluated, would PACK and return the constructor. A few more details are given in Note [Static constructors in Bytecode]. Secondly, this commit also fixes issue #25636 which was caused by linking *unlifted* constructors in BCO instructions as - (1) a thunk indexing the array of BCOs in a module - (2) which evaluated to a BCO which still had to be evaluated to return the unlifted constructor proper. The (2) issue has been resolved by allocating the static constructors directly. The (1) issue can be resolved by ensuring that we allocate all unlifted top-level constructors eagerly, and leave the knot-tying for the lifted BCOs and top-level constructors only. The top-level unlifted constructors are never mutually recursive, so we can allocate them all in one go as long as we do it in topological order. Lifted fields of unlifted constructors can still be filled by the knot-tied lifted variables since in those fields it is fine to keep those thunks. See Note [Tying the knot in createBCOs] for more details. Fixes #25636 ------------------------- Metric Decrease: LinkableUsage01 ------------------------- - - - - - cde47053 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Revert "StgToByteCode: Assert that PUSH_G'd values are lifted" This reverts commit ec26c54d818e0cd328276196930313f66b780905. Ever since f7a22c0f4e9ae0dc767115d4c53fddbd8372b777, we now do support and will link top-level unlifted constructors into evaluated and properly tagged values which we can reference with PUSH_G. This assertion is no longer true and triggered a failure in T25636 - - - - - c7a7e5b8 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: Tag more remote Ptrs as RemotePtr Pure refactor which improves the API of - GHC.ByteCode.Linker - GHC.Runtime.Interpreter - GHC.Runtime.Interpreter.Types.SymbolCache by using `RemotePtr` for more functions which used to return `Ptr`s that could potentially be in a foreign process. E.g. `lookupIE`, `lookupStaticPtr`, etc... - - - - - fc59494c by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add float# and subword tests for #25636 These tests cover that static constructors in bytecode work correctly for Float# and subword values (Word8#, Word16#) - - - - - 477f521b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 test: Validate topoSort logic in createBCOs This test validates that the topological sorting and ordering of the unlifted constructors and lifted constructors in `createBCOs` is correct. See `Note [Tying the knot in createBCOs]` for why tying the knot for the created BCOs is slightly difficult and why the topological sorting is necessary. This test fails when `let topoSortedObjs = topSortObjs objs` is substituted by `let topoSortedObjs = zip [0..] objs`, thus witnessing the toposort logic is correct and necessary. The test calls the ghci `createBCOs` directly because it is currently impossible to construct in Source Haskell a situation where a top-level static unlifted constructor depends on another (we don't have top-level unlifted constructors except for nullary constructors like `Leaf :: (UTree :: UnliftedType)`). This is another test for fix for #25636 - - - - - 2d9c30be by Simon Jakobi at 2026-04-14T18:42:00-04:00 Improve tests for `elem` ...in order to simplify the work on #27096. * Improve T17752 by including the Core output in golden files, checking both -O1 and -O2. * Add tests for fusion and no-fusion cases. Fixes #27101. - - - - - 2dadf3b0 by sheaf at 2026-04-16T13:28:39-04:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. The most important change is that we revert the logic (added in 85b0aae2) that allowed ticks to be placed around coercions, which caused serious issues (e.g. #27121). It was just a mistake, as it doesn't make sense to put a tick around a coercion. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - a0d6f1f4 by Simon Jakobi at 2026-04-16T13:29:28-04:00 Add regression test for #9074 Closes #9074. - - - - - d178ee89 by Sylvain Henry at 2026-04-16T13:30:25-04:00 Add changelog for #15973 - - - - - e8a196c6 by sheaf at 2026-04-16T13:31:19-04:00 Deal with 'noSpec' in 'coreExprToPmLit' This commit makes two separate changes relating to 'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit': 1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical, which led to the introduction of 'nospec' wrappers in the generated Core. This reverts that accident by declaring deferred errors as being canonical, avoiding spurious 'nospec' wrapping. 2. Look through magic identity-like Ids such as 'nospec', 'inline' and 'lazy' in 'coreExprAsPmLit', just like Core Prep does. There might genuinely be incoherent evidence, but that shouldn't obstruct the pattern match checker. See test T27124a. Fixes #25926 #27124 ------------------------- Metric Decrease: T3294 ------------------------- - - - - - 8cb99552 by Sylvain Henry at 2026-04-16T19:22:43-04:00 hadrian: warn when package index is missing (#16484) Since cabal-install 3.0 we can query the path of remote-repo-cache and check if hackage package index is present. Fixes #16484 - - - - - d6ce7477 by Richard Eisenberg at 2026-04-16T19:23:25-04:00 Teach hadrian to --skip-test. Fixes #27188. This adds the --skip-test flag to `hadrian build`, as documented in the patch. - - - - - 3c058fca by Apoorv Ingle at 2026-04-17T13:32:36-05:00 move SectionL and SectionR into tcExpand Work on #27156 - - - - - d942413f by Apoorv Ingle at 2026-04-17T13:32:36-05:00 move Record dot syntax expansion from renamer to Expand - - - - - 5e5b9c73 by Apoorv Ingle at 2026-04-17T14:20:31-05:00 tcExpr to do expansion first, then type checking - - - - - 209 changed files: - .gitlab-ci.yml - .gitlab/issue_templates/release_tracking.md - .gitlab/merge_request_templates/Default.md - + changelog.d/T15973 - + changelog.d/T25636 - + changelog.d/T27121.md - + changelog.d/T27124.md - + changelog.d/changelog-entries - + changelog.d/config - + changelog.d/fix-duplicate-pmc-warnings - + changelog.d/fix-ghci-duplicate-warnings-26233 - + changelog.d/hadrian-warn-missing-package-index-16484 - + changelog.d/skip-test - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Liveness.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Platform.hs - compiler/GHC/Platform/Tag.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Prof.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Types/Tickish.hs - compiler/ghc.cabal.in - configure.ac - − docs/users_guide/10.0.1-notes.rst - + docs/users_guide/10.2.1-notes.rst - − docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/ghc_config.py.in - − docs/users_guide/ghc_packages.py - docs/users_guide/packages.rst - docs/users_guide/release-notes.rst - ghc/ghc-bin.cabal.in - hadrian/build-cabal - hadrian/build-cabal.bat - hadrian/doc/make.md - hadrian/doc/testsuite.md - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Packages.hs - + hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Default.hs - libraries/array - libraries/base/base.cabal.in - + libraries/base/tests/perf/ElemFusionUnknownList.hs - + libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - + libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - + libraries/base/tests/perf/ElemNoFusion.hs - + libraries/base/tests/perf/ElemNoFusion_O1.stderr - + libraries/base/tests/perf/ElemNoFusion_O2.stderr - − libraries/base/tests/perf/Makefile - libraries/base/tests/perf/T17752.hs - − libraries/base/tests/perf/T17752.stdout - + libraries/base/tests/perf/T17752_O1.stderr - + libraries/base/tests/perf/T17752_O2.stderr - libraries/base/tests/perf/all.T - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/file-io - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-heap/tests/tso_and_stack_closures.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell-lift - libraries/template-haskell-quasiquoter - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/unix - m4/fp_setup_project_version.m4 - m4/fptools_ghc_version.m4 - rts/Interpreter.c - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/include/Rts.h - rts/include/rts/storage/ClosureMacros.h - rts/include/stg/MiscClosures.h - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - testsuite/tests/codeGen/should_run/T23146/T23146_liftedeq.hs - + testsuite/tests/codeGen/should_run/T23146/T25636.script - + testsuite/tests/codeGen/should_run/T23146/T25636.stdout - testsuite/tests/codeGen/should_run/T23146/all.T - + testsuite/tests/codeGen/should_run/T25636a/T25636a.script - + testsuite/tests/codeGen/should_run/T25636a/T25636a.stdout - + testsuite/tests/codeGen/should_run/T25636a/all.T - + testsuite/tests/codeGen/should_run/T25636b/T25636b.script - + testsuite/tests/codeGen/should_run/T25636b/T25636b.stdout - + testsuite/tests/codeGen/should_run/T25636b/all.T - + testsuite/tests/codeGen/should_run/T25636c/T25636c.script - + testsuite/tests/codeGen/should_run/T25636c/T25636c.stdout - + testsuite/tests/codeGen/should_run/T25636c/all.T - + testsuite/tests/codeGen/should_run/T25636d/T25636d.script - + testsuite/tests/codeGen/should_run/T25636d/T25636d.stdout - + testsuite/tests/codeGen/should_run/T25636d/all.T - + testsuite/tests/codeGen/should_run/T25636e/T25636e.script - + testsuite/tests/codeGen/should_run/T25636e/T25636e.stdout - + testsuite/tests/codeGen/should_run/T25636e/all.T - + testsuite/tests/deSugar/should_compile/T25996.hs - + testsuite/tests/deSugar/should_compile/T25996.stderr - testsuite/tests/deSugar/should_compile/all.T - testsuite/tests/ghci.debugger/scripts/print034.stdout - + testsuite/tests/ghci/T9074/Makefile - + testsuite/tests/ghci/T9074/T9074.hs - + testsuite/tests/ghci/T9074/T9074.stdout - + testsuite/tests/ghci/T9074/T9074a.c - + testsuite/tests/ghci/T9074/T9074b.c - + testsuite/tests/ghci/T9074/all.T - + testsuite/tests/ghci/scripts/T26233.script - + testsuite/tests/ghci/scripts/T26233.stderr - + testsuite/tests/ghci/scripts/T26233.stdout - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/should_run/T25636f.hs - + testsuite/tests/ghci/should_run/T25636f.stdout - testsuite/tests/ghci/should_run/all.T - 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/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/linters/Makefile - testsuite/tests/linters/all.T - + testsuite/tests/linters/changelog-d.stdout - + testsuite/tests/overloadedstrings/should_fail/T25926.hs - + testsuite/tests/overloadedstrings/should_fail/T25926.stderr - + testsuite/tests/overloadedstrings/should_fail/T27124.hs - + testsuite/tests/overloadedstrings/should_fail/T27124.stderr - + testsuite/tests/overloadedstrings/should_fail/all.T - + testsuite/tests/overloadedstrings/should_run/T27124a.hs - testsuite/tests/overloadedstrings/should_run/all.T - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T - + utils/changelog-d/ChangelogD.hs - + utils/changelog-d/LICENSE - + utils/changelog-d/README.md - + utils/changelog-d/changelog-d.cabal - utils/deriveConstants/Main.hs - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bd7451922702c7402fc0b39792450… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bd7451922702c7402fc0b39792450… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Migrate `ghc-pkg` to use `OsPath` and `file-io`
by Marge Bot (＠marge-bot) 17 Apr '26

17 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2794529c by Fendor at 2026-04-17T14:32:33-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - db7c03e1 by Wolfgang Jeltsch at 2026-04-17T14:32:34-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: T3294 Metric Increase: T12227 T12707 T5642 - - - - - 36 changed files: - + changelog.d/ghc-pkg-long-path-support - compiler/GHC/Unit/State.hs - libraries/base/src/Control/Concurrent.hs - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.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/typecheck/should_compile/T9497a.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T9497d.stderr - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a81a80d94f709403086a3d200ac7a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a81a80d94f709403086a3d200ac7a… You're receiving this email because of your account on gitlab.haskell.org.

1 0