- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/supersven/cross-testsuite
by Sven Tennie (＠supersven) 30 May '26

30 May '26

Sven Tennie pushed new branch wip/supersven/cross-testsuite at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/cross-testsuite You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Hadrian: create a ghc-internal .def file per ghc-internal dll
by Marge Bot (＠marge-bot) 30 May '26

30 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d603477f by David Eichmann at 2026-05-29T13:17:12-04:00 Hadrian: create a ghc-internal .def file per ghc-internal dll The .def file generated from rts/win32/libHSghc-internal.def.in contains the name of the ghc-internal dll. The correct dll name differs based on if the dll is inplace/final and if using the Dynamic way. Previously, this was not accounted for and inconsistent dlls names where used. That led to failure when loading dlls at runtime in experiments with windows dynamic linking. - - - - - 1fc21753 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: copy backend interface haddocks to Native backend (#27305) The haddock comments documenting the BigNat backend interface (function contracts, expected MutableWordArray# sizes, return-value semantics, etc.) were attached to the FFI backend module. Copy them to the Native backend so they remain in tree once the FFI backend is removed. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 717059df by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove FFI backend (#27305) The FFI backend of ghc-bignum (now part of ghc-internal) had no known users and is easy to recreate by relinking ghc-internal with a custom backend. Remove the backend module, the bignum-ffi cabal flag, and the ffi option from Hadrian's --bignum selector. The backend interface documentation now lives in the Native backend module. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 4bb3b1d8 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove Check backend (#27305) The Check backend of ghc-bignum (now part of ghc-internal) compared the selected backend's output against the Native backend for validation. It had no known users. Remove the backend module, the bignum-check cabal flag, the bignumCheck Hadrian flavour field, and the check- prefix in Hadrian's --bignum selector. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - ad79d02c by David Eichmann at 2026-05-30T07:28:13-04:00 Add code comments to allocator code - - - - - c80f15fa by Matthew Pickering at 2026-05-30T07:28:16-04:00 hadrian: Refactor system-cxx-std-lib rules I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. This commit increases the `shakeVersion`, to provide backwards compatibility to previous builds with different PackageData. Fixes #25303 Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com> - - - - - 29 changed files: - + changelog.d/hadrian-system-cxx-std-lib-25303 - + changelog.d/remove-bignum-check-backend - + changelog.d/remove-bignum-ffi-backend - hadrian/README.md - hadrian/doc/user-settings.md - hadrian/src/CommandLine.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Main.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/ghc-bignum.cabal - libraries/ghc-internal/bignum-backend.rst - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Check.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/FFI.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs - rts/sm/BlockAlloc.c - rts/sm/MBlock.c - rts/win32/libHSghc-internal.def.in Changes: ===================================== changelog.d/hadrian-system-cxx-std-lib-25303 ===================================== @@ -0,0 +1,22 @@ +section: packaging +synopsis: Fix Hadrian rules for system-cxx-std-lib package dependency +issues: #25303 +mrs: !16013 +description: { + Hadrian's handling of the `system-cxx-std-lib` virtual package has been + fixed and made more uniform. + + Previously, `text` had an ad-hoc rule outside of `configurePackage` to + declare a dependency on `system-cxx-std-lib`, the dependency was not + discovered from cabal files, and the package database was not recached after + the `.conf` file was generated. + + The dependency is now read from cabal files via a new + `dependsOnSystemCxxStdLib` field in `PackageData`, and the `.conf` file + is needed inside `configurePackage` alongside all other package + dependencies, consistent with how every other package is handled. + + `shakeVersion` has been bumped to ensure existing build databases are + invalidated when upgrading, preventing binary deserialisation errors due to + the changed `PackageData` type. +} ===================================== changelog.d/remove-bignum-check-backend ===================================== @@ -0,0 +1,11 @@ +section: packaging +synopsis: Remove the Check backend of ghc-bignum +issues: #27305 +mrs: !16106 + +description: { + The Check backend of ghc-bignum (now part of ghc-internal), which compared + the results of the selected backend against the Native backend, has been + removed along with the ``bignum-check`` cabal flag and the ``check-`` + prefix in Hadrian's ``--bignum`` option. +} ===================================== changelog.d/remove-bignum-ffi-backend ===================================== @@ -0,0 +1,12 @@ +section: packaging +synopsis: Remove the FFI backend of ghc-bignum +issues: #27305 +mrs: !16106 + +description: { + The FFI backend of ghc-bignum (now part of ghc-internal) has been removed. + It had no known users and was easy to recreate by relinking ghc-internal + with a custom backend implementation. As a result, the ``bignum-ffi`` + cabal flag has been dropped, and selecting the ``ffi`` backend via + Hadrian's ``--bignum`` option is no longer supported. +} ===================================== hadrian/README.md ===================================== @@ -101,7 +101,7 @@ Stage2 GHC. * `--skip-depends`: skips rebuilding Haskell module dependency files. -* `--bignum={native,gmp,check-gmp,ffi}`: **Deprecated.** Use the `+native_bignum` flavour +* `--bignum={native,gmp}`: **Deprecated.** Use the `+native_bignum` flavour transformer instead (e.g. `--flavour=default+native_bignum`). When building for the JavaScript target, the native bignum backend is enabled automatically. ===================================== hadrian/doc/user-settings.md ===================================== @@ -24,10 +24,8 @@ data Flavour = Flavour { extraArgs :: Args, -- | Build these packages. packages :: Stage -> Action [Package], - -- | Bignum backend: 'native', 'gmp', 'ffi', etc. + -- | Bignum backend: 'native', 'gmp', etc. bignumBackend :: String, - -- | Check selected bignum backend against native backend - bignumCheck :: Bool, -- | Build the @text@ package with @simdutf@ support. Disabled by -- default due to packaging difficulties described in #20724. textWithSIMDUTF :: Bool, ===================================== hadrian/src/CommandLine.hs ===================================== @@ -1,7 +1,7 @@ module CommandLine ( optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, lookupFreeze2, lookupSkipDepends, lookupBignum, - cmdBignum, cmdBignumCheck, cmdProgressInfo, cmdCompleteSetting, + cmdBignum, cmdProgressInfo, cmdCompleteSetting, cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs, cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs, cmdKeepResponseFiles @@ -32,7 +32,6 @@ data CommandLineArgs = CommandLineArgs , skipDepends :: Bool , unitIdHash :: Bool , bignum :: Maybe String - , bignumCheck :: Bool , progressInfo :: ProgressInfo , buildRoot :: BuildRoot , testArgs :: TestArgs @@ -54,7 +53,6 @@ defaultCommandLineArgs = CommandLineArgs , skipDepends = False , unitIdHash = False , bignum = Nothing - , bignumCheck = False , progressInfo = Brief , buildRoot = BuildRoot "_build" , testArgs = defaultTestArgs @@ -132,10 +130,7 @@ readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms } readBignum :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) readBignum Nothing = Right id -readBignum (Just ms) = Right $ \flags -> case break (== '-') (lower ms) of - (backend,"") -> flags { bignum = Just backend } - ("check",'-':backend) -> flags { bignum = Just backend, bignumCheck = True } - _ -> flags { bignum = Just (lower ms) } +readBignum (Just ms) = Right $ \flags -> flags { bignum = Just (lower ms) } readBuildRoot :: FilePath -> Either String (CommandLineArgs -> CommandLineArgs) readBuildRoot ms = @@ -302,7 +297,7 @@ optDescrs = , Option [] ["skip-depends"] (NoArg readSkipDepends) "Skip rebuilding dependency information." , Option [] ["bignum"] (OptArg readBignum "BACKEND") - "Select bignum backend: native, gmp (default), check-gmp (gmp compared to native), ffi." + "Select bignum backend: native, gmp (default)." , Option [] ["progress-info"] (ReqArg readProgressInfo "STYLE") "Progress info style (None, Brief, Normal or Unicorn)." , Option [] ["docs"] (ReqArg readDocsArg "TARGET") @@ -429,9 +424,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs cmdBignum :: Action (Maybe String) cmdBignum = bignum <$> cmdLineArgs -cmdBignumCheck :: Action Bool -cmdBignumCheck = bignumCheck <$> cmdLineArgs - cmdKeepResponseFiles :: Action Bool cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs ===================================== hadrian/src/Flavour/Type.hs ===================================== @@ -19,10 +19,8 @@ data Flavour = Flavour { extraArgs :: Args, -- | Build these packages. packages :: Stage -> Action [Package], - -- | Bignum backend: 'native', 'gmp', 'ffi', etc. + -- | Bignum backend: 'native', 'gmp', etc. bignumBackend :: String, - -- | Check selected bignum backend against native backend - bignumCheck :: Bool, -- | Build the @text@ package with @simdutf@ support. Disabled by -- default due to packaging difficulties described in #20724. textWithSIMDUTF :: Bool, ===================================== hadrian/src/Hadrian/Haskell/Cabal/Parse.hs ===================================== @@ -81,10 +81,11 @@ parsePackageData pkg = do sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ] deps = nubOrd sorted \\ [name] depPkgs = mapMaybe findPackageByName deps + cxxStdLib = elem "system-cxx-std-lib" deps return $ PackageData name version (C.fromShortText (C.synopsis pd)) (C.fromShortText (C.description pd)) - depPkgs gpd + depPkgs cxxStdLib gpd where -- Collect an overapproximation of dependencies by ignoring conditionals collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency] @@ -138,7 +139,9 @@ configurePackage :: Context -> Action () configurePackage context@Context {..} = do putProgressInfo $ "| Configure package " ++ quote (pkgName package) gpd <- pkgGenericDescription package - depPkgs <- packageDependencies <$> readPackageData package + pd <- readPackageData package + let depPkgs = packageDependencies pd + needSystemCxxStdLib = dependsOnSystemCxxStdLib pd -- Stage packages are those we have in this stage. stagePkgs <- stagePackages stage @@ -157,7 +160,12 @@ configurePackage context@Context {..} = do -- We'll need those packages in our package database. deps <- sequence [ pkgConfFile (context { package = pkg, iplace = forceBaseAfterGhcInternal pkg }) | pkg <- depPkgs, pkg `elem` stagePkgs ] - need $ extraPreConfigureDeps ++ deps + -- system-cxx-std-lib is magic.. it doesn't have a cabal file or source code, so we have + -- to treat it specially as `pkgConfFile` uses `readPackageData` to compute the version. + systemCxxStdLib <- sequence [ systemCxxStdLibConfPath (PackageDbLoc stage iplace) | needSystemCxxStdLib ] + need $ extraPreConfigureDeps + ++ deps + ++ systemCxxStdLib -- Figure out what hooks we need. let configureFile = replaceFileName (pkgCabalFile package) "configure" ===================================== hadrian/src/Hadrian/Haskell/Cabal/Type.hs ===================================== @@ -30,6 +30,7 @@ data PackageData = PackageData , synopsis :: String , description :: String , packageDependencies :: [Package] + , dependsOnSystemCxxStdLib :: Bool , genericPackageDescription :: GenericPackageDescription } deriving (Eq, Generic, Show) ===================================== hadrian/src/Main.hs ===================================== @@ -63,7 +63,13 @@ main = do shakeColor <- shouldUseColor let options :: ShakeOptions options = shakeOptions - { shakeChange = ChangeModtimeAndDigest + { -- Bump shakeVersion whenever a type stored in the Shake oracle + -- changes its Binary representation (e.g. fields added/removed + -- from PackageData or other oracle value types). This forces + -- Shake to wipe the stale database instead of crashing on + -- deserialisation. + shakeVersion = "2" + , shakeChange = ChangeModtimeAndDigest , shakeFiles = buildRoot -/- Base.shakeFilesDir , shakeProgress = Progress.hadrianProgress cwd , shakeRebuild = rebuild ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -242,9 +242,6 @@ copyRules = do prefix -/- "html/**" <~ return "utils/haddock/haddock-api/resources" prefix -/- "latex/**" <~ return "utils/haddock/haddock-api/resources" - forM_ [Inplace, Final] $ \iplace -> - root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do - copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file generateRules :: Rules () generateRules = do @@ -390,7 +387,6 @@ templateRules = do , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1 , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2 ] - templateRule "rts/win32/libHSghc-internal.def" projectVersion templateRule "docs/index.html" $ packageUnitIds Stage1 templateRule "docs/users_guide/ghc_config.py" $ mconcat [ projectVersion ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -9,6 +9,7 @@ import GHC.Toolchain.Target (Target(tgtArchOs)) import Base import Context +import qualified Data.List as List import Expression hiding (way, package, stage) import Oracles.ModuleFiles import Packages @@ -20,6 +21,7 @@ import Utilities import Data.Time.Clock import Rules.Generate (generatedDependencies) import Oracles.Flag +import Way.Type (wayToUnits) -- * Library 'Rules' @@ -203,13 +205,32 @@ extraObjects context | package context == rts = do target <- interpretInContext context getStagedTarget - builddir <- buildPath context - return [ builddir -/- "libHSghc-internal.dll.a" - | archOS_OS (tgtArchOs target) == OSMinGW32 - , Dynamic `wayUnit` way context ] + if not (archOS_OS (tgtArchOs target) == OSMinGW32 + && Dynamic `wayUnit` way context) + then return [] + else do + -- Find the ghc-internal library file name. Note that the + -- ghc-internal's .dll.a file is placed in the RTS build dir and not + -- the ghc-internal build dir as we only use it when building the + -- RTS and not other libraries. + ghcInternalDllName <- takeFileName <$> pkgLibraryFile Context { + stage = stage context, + way = rtsWayToLibraryWay (way context), + iplace = iplace context, + package = ghcInternal + } + + builddir <- buildPath context + return [ builddir -/- ghcInternalDllName <> ".a"] | otherwise = return [] +-- | The rts is compiled in many different ways, but libraries are only built in +-- (non)Dynamic and (non)Profiled ways. This function converts the rts way into +-- compatible library way. +rtsWayToLibraryWay :: Way -> Way +rtsWayToLibraryWay = wayFromUnits . List.intersect [Dynamic, Profiling] . wayToUnits + -- | Return all the object files to be put into the library we're building for -- the given 'Context'. libraryObjects :: Context -> Action [FilePath] ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -6,7 +6,6 @@ module Rules.Register ( import Base import Context -import Flavour import Oracles.Setting import Hadrian.BuildPath import Hadrian.Expression @@ -48,14 +47,6 @@ configurePackageRules = do isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend when isGmp $ need [buildP -/- "include/ghc-gmp.h"] - when (pkg == text) $ do - simdutf <- textWithSIMDUTF <$> flavour - when simdutf $ do - -- This is required, otherwise you get Error: hadrian: - -- Encountered missing or private dependencies: - -- system-cxx-std-lib ==1.0 - cxxStdLib <- systemCxxStdLibConfPath $ PackageDbLoc stage Inplace - need [cxxStdLib] Cabal.configurePackage ctx root -/- "**/autogen/cabal_macros.h" %> \out -> do @@ -105,6 +96,12 @@ registerPackageRules rs stage iplace = do target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] writeFileLines stamp [] + -- Special rule for registering system-cxx-std-lib + root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do + copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file + buildWithResources rs $ + target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] + -- Register a package. root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do historyDisable ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -13,11 +13,19 @@ rtsRules = priority 3 $ do -- to be linked into the rts dll. forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do let buildPath = root -/- buildDir (rtsContext stage) - buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib + buildPath -/- "libHSghc-internal-*.def" %> buildGhcInternalImportDef + buildPath -/- "libHSghc-internal-*.dll.a" %> buildGhcInternalImportLib + +buildGhcInternalImportDef :: FilePath -> Action () +buildGhcInternalImportDef target = do + templateIn <- readFile' "rts/win32/libHSghc-internal.def.in" + let dllName = takeFileName target -<.> "dll" + templateOut = replace "@GhcInternalDll@" dllName templateIn + writeFile' target templateOut buildGhcInternalImportLib :: FilePath -> Action () buildGhcInternalImportLib target = do - let input = "rts/win32/libHSghc-internal.def" + let input = dropExtensions target <.> "def" -- the .def file output = target -- the .dll.a import lib need [input] runBuilder Dlltool ["-d", input, "-l", output] [input] [output] ===================================== hadrian/src/Settings.hs ===================================== @@ -3,7 +3,7 @@ module Settings ( getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath, - isLibrary, stagePackages, getBignumBackend, getBignumCheck, completeSetting, + isLibrary, stagePackages, getBignumBackend, completeSetting, queryBuildTarget, queryHostTarget, queryTargetTarget, queryBuild, queryHost, queryTarget, queryArch, queryOS, queryVendor @@ -46,11 +46,6 @@ getRtsWays = expr flavour >>= rtsWays getBignumBackend :: Expr String getBignumBackend = bignumBackend <$> expr flavour -getBignumCheck :: Expr Bool -getBignumCheck = expr $ cmdBignum >>= \case - Nothing -> bignumCheck <$> flavour - Just _ -> cmdBignumCheck - stagePackages :: Stage -> Action [Package] stagePackages stage = do f <- flavour ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -241,7 +241,6 @@ runTestBuilderArgs = builder Testsuite ? do -- MP: TODO, these should be queried from the test compiler? bignumBackend <- getBignumBackend - bignumCheck <- getBignumCheck keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs) @@ -307,7 +306,7 @@ runTestBuilderArgs = builder Testsuite ? do , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags , arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasDynamicRts) , arg "-e", arg $ asBool "config.ghc_with_threaded_rts=" (hasThreadedRts) - , arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native" && not bignumCheck) + , arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native") , arg "-e", arg $ asBool "config.target_has_smp=" targetWithSMP , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic , arg "-e", arg $ "config.leading_underscore=" ++ show leadingUnderscore ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -293,7 +293,6 @@ defaultFlavour = Flavour , extraArgs = defaultExtraArgs , packages = defaultPackages , bignumBackend = defaultBignumBackend - , bignumCheck = False , textWithSIMDUTF = False , libraryWays = defaultLibraryWays , rtsWays = defaultRtsWays ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -240,15 +240,11 @@ ghcInternalArgs = package ghcInternal ? do includesGmp <- getSetting GmpIncludeDir backend <- getBignumBackend - check <- getBignumCheck mconcat [ -- select bignum backend builder (Cabal Flags) ? arg ("bignum-" <> backend) - , -- check the selected backend against native backend - builder (Cabal Flags) ? check `cabalFlag` "bignum-check" - -- backend specific , case backend of "gmp" -> mconcat ===================================== libraries/ghc-bignum/ghc-bignum.cabal ===================================== @@ -36,7 +36,7 @@ library GHC.Internal.Bignum.Primitives as GHC.Num.Primitives , GHC.Internal.Bignum.WordArray as GHC.Num.WordArray , GHC.Internal.Bignum.Backend as GHC.Num.Backend - , GHC.Internal.Bignum.Backend.Selected as GHC.Num.Backend.Selected + , GHC.Internal.Bignum.Backend as GHC.Num.Backend.Selected , GHC.Internal.Bignum.Backend.Native as GHC.Num.Backend.Native , GHC.Internal.Bignum.BigNat as GHC.Num.BigNat , GHC.Internal.Bignum.Natural as GHC.Num.Natural ===================================== libraries/ghc-internal/bignum-backend.rst ===================================== @@ -33,20 +33,9 @@ supported: integer-simple package. The major difference is that it uses a much more efficient memory representation (integer-simple was based on Haskell lists) and that it allows a lot more code sharing between the different backends than - was previously possible between integer-gmp and integer-simple. - -* FFI: an implementation that relies on external FFI calls. This backend can be - useful: - - * for alternative GHC backends that target non native platforms (JavaScript, - JVM, etc.): the backend can dynamically match and rewrite the FFI calls in - order to call the appropriate platform specific BigNum API. - - * to test new native backends: just tweak the ghc-bignum build to link with - the native library providing the implementation of the FFI calls - - Note that the FFI backend module contains the description of the interface - that needs to be implemented by every backend. + was previously possible between integer-gmp and integer-simple. The Native + backend module contains the description of the interface that needs to be + implemented by every backend. This package has been designed to make the implementation of new backends relatively easy. Previously you had to implement the whole Integer/Natural ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -56,21 +56,11 @@ Flag bignum-native Manual: True Default: False -Flag bignum-ffi - Description: Enable FFI bignum backend - Manual: True - Default: False - Flag bignum-gmp Description: Enable GMP bignum backend Manual: True Default: False -Flag bignum-check - Description: Validate results of the enabled backend against native backend. - Manual: True - Default: False - Flag need-atomic Description: Enable linking with "atomic" library (for 64-bit atomic ops on armel, #20549) Manual: True @@ -382,13 +372,11 @@ Library -- Bignum configuration ---------------------------------------- -- check that at least one backend is enabled - if !flag(bignum-native) && !flag(bignum-gmp) && !flag(bignum-ffi) + if !flag(bignum-native) && !flag(bignum-gmp) buildable: False -- check that at most one flag is set - if flag(bignum-native) && (flag(bignum-gmp) || flag(bignum-ffi)) - buildable: False - if flag(bignum-gmp) && flag(bignum-ffi) + if flag(bignum-native) && flag(bignum-gmp) buildable: False if flag(bignum-gmp) @@ -398,25 +386,14 @@ Library c-sources: cbits/gmp_wrappers.c - if flag(bignum-ffi) - cpp-options: -DBIGNUM_FFI - other-modules: - GHC.Internal.Bignum.Backend.FFI - if flag(bignum-native) cpp-options: -DBIGNUM_NATIVE - if flag(bignum-check) - cpp-options: -DBIGNUM_CHECK - other-modules: - GHC.Internal.Bignum.Backend.Check - exposed-modules: GHC.Internal.Bignum.Primitives GHC.Internal.Bignum.WordArray GHC.Internal.Bignum.BigNat GHC.Internal.Bignum.Backend - GHC.Internal.Bignum.Backend.Selected GHC.Internal.Bignum.Backend.Native GHC.Internal.Bignum.Natural GHC.Internal.Bignum.Integer ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs ===================================== @@ -7,9 +7,12 @@ module GHC.Internal.Bignum.Backend ) where -#if defined(BIGNUM_CHECK) -import GHC.Internal.Bignum.Backend.Check as Backend +#if defined(BIGNUM_NATIVE) +import GHC.Internal.Bignum.Backend.Native as Backend + +#elif defined(BIGNUM_GMP) +import GHC.Internal.Bignum.Backend.GMP as Backend + #else -import GHC.Internal.Bignum.Backend.Selected as Backend +#error Undefined BigNum backend. Use a flag to select it (e.g. gmp, native)` #endif - ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Check.hs deleted ===================================== @@ -1,508 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | Check Native implementation against another backend -module GHC.Internal.Bignum.Backend.Check where - -import GHC.Internal.CString -import GHC.Internal.Prim -import GHC.Internal.Types -import GHC.Internal.Bignum.WordArray -import GHC.Internal.Bignum.Primitives -import {-# SOURCE #-} GHC.Internal.Bignum.Integer -import {-# SOURCE #-} GHC.Internal.Bignum.Natural -import qualified GHC.Internal.Bignum.Backend.Native as Native -import qualified GHC.Internal.Bignum.Backend.Selected as Other - -#if defined(BIGNUM_NATIVE) -#error You can't validate Native backend against itself. Choose another backend (e.g. gmp, ffi) -#endif - -default () - --- | ghc-bignum backend name -backendName :: [Char] -backendName = unpackAppendCString# "check-"# Other.backendName - -- we don't have (++) at our disposal, so we directly use - -- `unpackAppendCString#` - -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare a b = - let - gr = Other.bignat_compare a b - nr = Native.bignat_compare a b - in case gr ==# nr of - 0# -> unexpectedValue_Int# (# #) - _ -> gr - -mwaCompare - :: MutableWordArray# s - -> MutableWordArray# s - -> State# s - -> (# State# s, Bool# #) -mwaCompare mwa mwb s = - case mwaSize# mwa s of - (# s, szA #) -> case mwaSize# mwb s of - (# s, szB #) -> case szA ==# szB of - 0# -> (# s, 0# #) - _ -> let - go i s - | isTrue# (i <# 0#) = (# s, 1# #) - | True = - case readWordArray# mwa i s of - (# s, a #) -> case readWordArray# mwb i s of - (# s, b #) -> case a `eqWord#` b of - 0# -> (# s, 0# #) - _ -> go (i -# 1#) s - in go (szA -# 1#) s - -mwaCompareOp - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { s -> - case g mwb s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - (# s, _ #) -> s - }}}}}} - -mwaCompareOp2 - :: MutableWordArray# s - -> MutableWordArray# s - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp2 mwa mwb f g s = - case mwaSize# mwa s of { (# s, szA #) -> - case mwaSize# mwb s of { (# s, szB #) -> - case newWordArray# szA s of { (# s, mwa' #) -> - case newWordArray# szB s of { (# s, mwb' #) -> - case f mwa mwb s of { s -> - case g mwa' mwb' s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaTrimZeroes# mwa' s of { s -> - case mwaTrimZeroes# mwb' s of { s -> - case mwaCompare mwa mwa' s of { (# s, ba #) -> - case mwaCompare mwb mwb' s of { (# s, bb #) -> - case ba &&# bb of - 0# -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> s - }}}}}}}}}}}} - -mwaCompareOpBool - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> State# s - -> (# State# s, Bool# #) -mwaCompareOpBool mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case ra ==# rb of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> case ra of -- don't compare MWAs if underflow signaled! - 0# -> (# s, ra #) -- underflow - _ -> case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -mwaCompareOpWord - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> State# s - -> (# State# s, Word# #) -mwaCompareOpWord mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, b #) -> case b &&# (ra `eqWord#` rb) of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_add m wa wb) - (\m -> Native.bignat_add m wa wb) - -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_add_word m wa b) - (\m -> Native.bignat_add_word m wa b) - -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_mul_word m wa b) - (\m -> Native.bignat_mul_word m wa b) - -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub m wa wb) - (\m -> Native.bignat_sub m wa wb) - -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub_word m wa b) - (\m -> Native.bignat_sub_word m wa b) - -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_mul m wa wb) - (\m -> Native.bignat_mul m wa wb) - -bignat_popcount :: WordArray# -> Word# -bignat_popcount wa = - let - gr = Other.bignat_popcount wa - nr = Native.bignat_popcount wa - in case gr `eqWord#` nr of - 0# -> 1## `quotWord#` 0## - _ -> gr - -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftl m wa n) - (\m -> Native.bignat_shiftl m wa n) - -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr m wa n) - (\m -> Native.bignat_shiftr m wa n) - -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr_neg m wa n) - (\m -> Native.bignat_shiftr_neg m wa n) - -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_or mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_or m wa wb) - (\m -> Native.bignat_or m wa wb) - -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_xor mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_xor m wa wb) - (\m -> Native.bignat_xor m wa wb) - -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and m wa wb) - (\m -> Native.bignat_and m wa wb) - -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and_not mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and_not m wa wb) - (\m -> Native.bignat_and_not m wa wb) - -bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb - = mwaCompareOp2 mwq mwr - (\m1 m2 -> Other.bignat_quotrem m1 m2 wa wb) - (\m1 m2 -> Native.bignat_quotrem m1 m2 wa wb) - -bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb - = mwaCompareOp mwq - (\m -> Other.bignat_quot m wa wb) - (\m -> Native.bignat_quot m wa wb) - -bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_rem m wa wb) - (\m -> Native.bignat_rem m wa wb) - -bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b - = mwaCompareOpWord mwq - (\m -> Other.bignat_quotrem_word m wa b) - (\m -> Native.bignat_quotrem_word m wa b) - -bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b - = mwaCompareOp mwq - (\m -> Other.bignat_quot_word m wa b) - (\m -> Native.bignat_quot_word m wa b) - -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word wa b = - let - gr = Other.bignat_rem_word wa b - nr = Native.bignat_rem_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_gcd m wa wb) - (\m -> Native.bignat_gcd m wa wb) - -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word wa b = - let - gr = Other.bignat_gcd_word wa b - nr = Native.bignat_gcd_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word a b = - let - gr = Other.bignat_gcd_word_word a b - nr = Native.bignat_gcd_word_word a b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double a e = - let - gr = Other.bignat_encode_double a e - nr = Native.bignat_encode_double a e - in case gr ==## nr of - 1# -> gr - _ -> case unexpectedValue of - !_ -> 0.0## - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word b e m = - let - gr = Other.bignat_powmod_word b e m - nr = Native.bignat_powmod_word b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m - = mwaCompareOp r - (\r' -> Other.bignat_powmod r' b e m) - (\r' -> Native.bignat_powmod r' b e m) - -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words b e m = - let - gr = Other.bignat_powmod_words b e m - nr = Native.bignat_powmod_words b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -integer_gcde - :: Integer - -> Integer - -> (# Integer, Integer, Integer #) -integer_gcde a b = - let - !(# g0,x0,y0 #) = Other.integer_gcde a b - !(# g1,x1,y1 #) = Native.integer_gcde a b - in if isTrue# (integerEq# x0 x1 - &&# integerEq# y0 y1 - &&# integerEq# g0 g1) - then (# g0, x0, y0 #) - else case unexpectedValue of - !_ -> (# integerZero, integerZero, integerZero #) - -integer_recip_mod - :: Integer - -> Natural - -> (# Natural | () #) -integer_recip_mod x m = - let - !r0 = Other.integer_recip_mod x m - !r1 = Native.integer_recip_mod x m - in case (# r0, r1 #) of - (# (# | () #), (# | () #) #) -> r0 - (# (# y0 | #), (# y1 | #) #) - | isTrue# (naturalEq# y0 y1) -> r0 - _ -> case unexpectedValue of - !_ -> (# | () #) - -integer_powmod - :: Integer - -> Natural - -> Natural - -> Natural -integer_powmod b e m = - let - !r0 = Other.integer_powmod b e m - !r1 = Native.integer_powmod b e m - in if isTrue# (naturalEq# r0 r1) - then r0 - else case unexpectedValue of - !_ -> naturalZero ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/FFI.hs deleted ===================================== @@ -1,641 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} - --- | External BigNat backend that directly call FFI operations. --- --- This backend can be useful for specific compilers such as GHCJS or Asterius --- that replace bignat foreign calls with calls to the native platform bignat --- library (e.g. JavaScript's BigInt). You can also link an extra object --- providing the implementation. -module GHC.Internal.Bignum.Backend.FFI where - -import GHC.Internal.Prim -import GHC.Internal.Types -import GHC.Internal.Bignum.WordArray -import GHC.Internal.Bignum.Primitives -import qualified GHC.Internal.Bignum.Backend.Native as Native -import {-# SOURCE #-} GHC.Internal.Bignum.Natural -import {-# SOURCE #-} GHC.Internal.Bignum.Integer - --- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base --- (This module uses the empty tuple () and string literals.) -import GHC.Internal.Tuple () -import GHC.Internal.CString () - -default () - --- | ghc-bignum backend name -backendName :: [Char] -backendName = "ffi" - --- | Compare two non-zero BigNat of the same length --- --- Return: --- < 0 ==> LT --- == 0 ==> EQ --- > 0 ==> GT -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare = ghc_bignat_compare - -foreign import ccall unsafe ghc_bignat_compare - :: WordArray# - -> WordArray# - -> Int# - --- | Add two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb s - = ioVoid (ghc_bignat_add mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | Add a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b s = - ioVoid (ghc_bignat_add_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Multiply a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b s = - ioVoid (ghc_bignat_mul_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Sub two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb s = ioBool (ghc_bignat_sub mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_sub - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO Bool - --- | Sub a non-zero word from a non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b s = ioBool (ghc_bignat_sub_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_sub_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO Bool - --- | Multiply two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a+size b --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb s = ioVoid (ghc_bignat_mul mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | PopCount of a non-zero BigNat -bignat_popcount :: WordArray# -> Word# -bignat_popcount = ghc_bignat_popcount - -foreign import ccall unsafe ghc_bignat_popcount - :: WordArray# - -> Word# - --- | Left-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + required new limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n s = ioVoid (ghc_bignat_shiftl mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n s = ioVoid (ghc_bignat_shiftr mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits by first --- converting it into its two's complement representation and then again after --- the arithmetic shift. --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Words (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n s = ioVoid (ghc_bignat_shiftr_neg mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - - --- | OR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_or #-} -bignat_or mwa wa wb s = ioVoid (ghc_bignat_or mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | XOR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_xor #-} -bignat_xor mwa wa wb s = ioVoid (ghc_bignat_xor mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | AND two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: min (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and #-} -bignat_and mwa wa wb s = ioVoid (ghc_bignat_and mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | ANDNOT two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and_not #-} -bignat_and_not mwa wa wb s = ioVoid (ghc_bignat_and_not mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of two non-zero BigNat --- --- Result quotient and remainder are to be stored in the MutableWordArray#. --- The first one (quotient) has size: size(A)-size(B)+1 --- The second one (remainder) has size: size(b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem - :: MutableWordArray# RealWorld -- ^ Quotient - -> MutableWordArray# RealWorld -- ^ Remainder - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb s = - ioVoid (ghc_bignat_quotrem mwq mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Quotient of two non-zero BigNat --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A)-size(B)+1 --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb s = - ioVoid (ghc_bignat_quot mwq wa wb) s - -foreign import ccall unsafe ghc_bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Remainder of two non-zero BigNat --- --- Result remainder is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_rem - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb s = - ioVoid (ghc_bignat_rem mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The remainder is returned. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b s = - ioWord# (ghc_bignat_quotrem_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO Word - --- | Quot of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b s = - ioVoid (ghc_bignat_quot_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Remainder of a non-zero BigNat and a non-zero Word --- --- The remainder is returned. -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word = ghc_bignat_rem_word - -foreign import ccall unsafe ghc_bignat_rem_word - :: WordArray# - -> Word# - -> Word# - - --- | Greatest common divisor (GCD) of two non-zero and non-one BigNat --- --- Result GCD is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- The first WordArray# is greater than the second WordArray#. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb s = - ioVoid (ghc_bignat_gcd mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a --- non-zero/non-one Word# --- --- Result GCD is returned -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word = ghc_bignat_gcd_word - -foreign import ccall unsafe ghc_bignat_gcd_word - :: WordArray# - -> Word# - -> Word# - --- | Greatest common divisor (GCD) of two Word# --- --- Result GCD is returned -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word = ghc_bignat_gcd_word_word - -foreign import ccall unsafe ghc_bignat_gcd_word_word - :: Word# - -> Word# - -> Word# - --- | Encode (# BigNat mantissa, Int# exponent #) into a Double# -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double = ghc_bignat_encode_double - -foreign import ccall unsafe ghc_bignat_encode_double - :: WordArray# - -> Int# - -> Double# - --- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word = ghc_bignat_powmod_word - -foreign import ccall unsafe ghc_bignat_powmod_word - :: WordArray# -> WordArray# -> Word# -> Word# - --- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 --- --- Result is to be stored in the MutableWordArray# (which size is equal to the --- one of m). --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m s = - ioVoid (ghc_bignat_powmod r b e m) s - -foreign import ccall unsafe ghc_bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> IO () - --- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words = ghc_bignat_powmod_words - -foreign import ccall unsafe ghc_bignat_powmod_words - :: Word# -> Word# -> Word# -> Word# - - --- | Return extended GCD of two non-zero integers. --- --- I.e. integer_gcde a b returns (g,x,y) so that ax + by = g --- --- Input: a and b are non zero. --- Output: g must be > 0 --- -integer_gcde - :: Integer - -> Integer - -> (# Integer, Integer, Integer #) -integer_gcde = Native.integer_gcde - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. - - --- | Computes the modular inverse of two non-zero integers. --- --- I.e. y = integer_recip_mod x m --- = x^(-1) `mod` m --- --- with 0 < y < abs m -integer_recip_mod - :: Integer - -> Natural - -> (# Natural | () #) -integer_recip_mod = Native.integer_recip_mod - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. - --- | Computes the modular exponentiation. --- --- I.e. y = integer_powmod b e m --- = b^e `mod` m --- --- with 0 <= y < abs m -integer_powmod - :: Integer - -> Natural - -> Natural - -> Natural -integer_powmod = Native.integer_powmod - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Internal.Bignum.Backend.Native where #include "MachDeps.h" #include "WordSize.h" -#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) || defined(BIGNUM_FFI) +#if defined(BIGNUM_NATIVE) import {-# SOURCE #-} GHC.Internal.Bignum.BigNat import {-# SOURCE #-} GHC.Internal.Bignum.Natural import {-# SOURCE #-} GHC.Internal.Bignum.Integer @@ -50,6 +50,12 @@ count_words_bits_int :: Word# -> (# Int#, Int# #) count_words_bits_int n = case count_words_bits n of (# nw, nb #) -> (# word2Int# nw, word2Int# nb #) +-- | Compare two non-zero BigNat of the same length +-- +-- Return: +-- < 0 ==> LT +-- == 0 ==> EQ +-- > 0 ==> GT bignat_compare :: WordArray# -> WordArray# -> Int# bignat_compare wa wb = go (sz -# 1#) where @@ -62,6 +68,13 @@ bignat_compare wa wb = go (sz -# 1#) | isTrue# (a `gtWord#` b) -> 1# | True -> -1# +-- | Add two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_add :: MutableWordArray# s -- ^ Result -> WordArray# @@ -120,6 +133,13 @@ bignat_add mwa wa wb = addABc 0# 0## in case mwaWrite# mwa i r s of s' -> addAoBc wab (i +# 1#) carry' s' +-- | Add a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_add_word :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -128,6 +148,15 @@ bignat_add_word -> State# RealWorld bignat_add_word mwa wa b s = mwaInitArrayPlusWord mwa wa b s +-- | Sub a non-zero word from a non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. bignat_sub_word :: MutableWordArray# RealWorld -> WordArray# @@ -154,6 +183,13 @@ bignat_sub_word mwa wa b = go b 0# (# l , c #) -> case mwaWrite# mwa i l s of s1 -> go (int2Word# c) (i +# 1#) s1 +-- | Multiply a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_mul_word :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -173,6 +209,13 @@ bignat_mul_word mwa wa b = go 0# 0## s' -> go (i +# 1#) carry' s' +-- | Multiply two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a+size b +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_mul :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -214,6 +257,15 @@ bignat_mul mwa wa wb s1 = bi -> case mul mwa wa bi i ctzA 0## s of s' -> mulEachB (i +# 1#) s' +-- | Sub two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. bignat_sub :: MutableWordArray# RealWorld -> WordArray# @@ -227,6 +279,7 @@ bignat_sub mwa wa wb s = case mwaArrayCopy# mwa 0# wa 0# (wordArraySize# wa) s of s' -> mwaSubInplaceArray mwa 0# wb s' +-- | PopCount of a non-zero BigNat bignat_popcount :: WordArray# -> Word# bignat_popcount wa = go 0# 0## where @@ -235,6 +288,13 @@ bignat_popcount wa = go 0# 0## | isTrue# (i ==# sz) = c | True = go (i +# 1#) (c `plusWord#` popCnt# (indexWordArray# wa i)) +-- | Left-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + required new limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftl :: MutableWordArray# s -> WordArray# @@ -267,6 +327,13 @@ bignat_shiftl mwa wa n s1 = s' -> mwaBitShift (i +# 1#) c' s' +-- | Right-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftr :: MutableWordArray# s -> WordArray# @@ -293,6 +360,15 @@ bignat_shiftr mwa wa n s1 in case mwaWrite# mwa i v s of s' -> mwaBitShift (i -# 1#) c' s' +-- | Right-shift a non-zero BigNat by a non-zero amount of bits by first +-- converting it into its two's complement representation and then again after +-- the arithmetic shift. +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Words (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftr_neg :: MutableWordArray# s -> WordArray# @@ -329,6 +405,10 @@ bignat_shiftr_neg mwa wa n s1 in go 0# +-- | OR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) bignat_or :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -346,6 +426,13 @@ bignat_or mwa wa wb s1 case mwaInitArrayBinOp mwa wx wy or# s of s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' +-- | XOR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_xor :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -363,6 +450,13 @@ bignat_xor mwa wa wb s1 case mwaInitArrayBinOp mwa wx wy xor# s of s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' +-- | AND two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: min (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_and :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -371,6 +465,13 @@ bignat_and -> State# RealWorld bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s +-- | ANDNOT two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_and_not :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -384,9 +485,17 @@ bignat_and_not mwa wa wb s = !szA = wordArraySize# wa !szB = wordArraySize# wb +-- | QuotRem of two non-zero BigNat +-- +-- Result quotient and remainder are to be stored in the MutableWordArray#. +-- The first one (quotient) has size: size(A)-size(B)+1 +-- The second one (remainder) has size: size(b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quotrem - :: MutableWordArray# s - -> MutableWordArray# s + :: MutableWordArray# s -- ^ Quotient + -> MutableWordArray# s -- ^ Remainder -> WordArray# -> WordArray# -> State# s @@ -434,8 +543,15 @@ bignat_quotrem mwq mwr uwa uwb s0 = +-- | Quotient of two non-zero BigNat +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A)-size(B)+1 +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quot - :: MutableWordArray# RealWorld + :: MutableWordArray# RealWorld -- ^ Quotient -> WordArray# -> WordArray# -> State# RealWorld @@ -445,8 +561,15 @@ bignat_quot mwq wa wb s = case newWordArray# (wordArraySize# wb) s of (# s, mwr #) -> bignat_quotrem mwq mwr wa wb s +-- | Remainder of two non-zero BigNat +-- +-- Result remainder is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_rem - :: MutableWordArray# RealWorld + :: MutableWordArray# RealWorld -- ^ Remainder -> WordArray# -> WordArray# -> State# RealWorld @@ -577,6 +700,15 @@ bignat_quotrem_normalized mwq mwa b s0 = | True -> loop (m -# 1#) s2 }} +-- | QuotRem of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The remainder is returned. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quotrem_word :: MutableWordArray# s -- ^ Quotient -> WordArray# @@ -595,6 +727,13 @@ bignat_quotrem_word mwq wa b s = go (sz -# 1#) 0## s in case mwaWrite# mwq i q s of s' -> go (i -# 1#) r' s' +-- | Quot of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quot_word :: MutableWordArray# s -- ^ Quotient -> WordArray# @@ -613,6 +752,9 @@ bignat_quot_word mwq wa b s = go (sz -# 1#) 0## s in case mwaWrite# mwq i q s of s' -> go (i -# 1#) r' s' +-- | Remainder of a non-zero BigNat and a non-zero Word +-- +-- The remainder is returned. bignat_rem_word :: WordArray# -> Word# @@ -629,6 +771,14 @@ bignat_rem_word wa b = go (sz -# 1#) 0## in go (i -# 1#) r' +-- | Greatest common divisor (GCD) of two non-zero and non-one BigNat +-- +-- Result GCD is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- The first WordArray# is greater than the second WordArray#. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_gcd :: MutableWordArray# s -> WordArray# @@ -647,13 +797,21 @@ bignat_gcd mwr = go !wmin' = bigNatRem wmax wmin in go wmax' wmin' s +-- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a +-- non-zero/non-one Word# +-- +-- Result GCD is returned bignat_gcd_word :: WordArray# -> Word# -> Word# bignat_gcd_word a b = bignat_gcd_word_word b (bigNatRemWord# a b) --- | This operation doesn't really belongs here, but GMP's one is much faster +-- | Greatest common divisor (GCD) of two Word# +-- +-- Result GCD is returned. +-- +-- This operation doesn't really belongs here, but GMP's one is much faster -- than this simple implementation (basic Euclid algorithm). -- -- Ideally we should make an implementation as fast as GMP's one and put it into @@ -665,6 +823,7 @@ bignat_gcd_word_word bignat_gcd_word_word a 0## = a bignat_gcd_word_word a b = bignat_gcd_word_word b (a `remWord#` b) +-- | Encode (# BigNat mantissa, Int# exponent #) into a Double# bignat_encode_double :: WordArray# -> Int# -> Double# bignat_encode_double wa e0 = go 0.0## e0 0# where @@ -676,6 +835,12 @@ bignat_encode_double wa e0 = go 0.0## e0 0# (e +# WORD_SIZE_IN_BITS#) -- FIXME: we assume that e doesn't overflow... (i +# 1#) +-- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# bignat_powmod_word b0 e0 m = go (naturalFromBigNat# b0) (naturalFromBigNat# e0) (naturalFromWord# 1##) where @@ -693,6 +858,18 @@ bignat_powmod_word b0 e0 m = go (naturalFromBigNat# b0) (naturalFromBigNat# e0) m' = naturalFromWord# m e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" +-- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 +-- +-- Result is to be stored in the MutableWordArray# (which size is equal to the +-- one of m). +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_powmod :: MutableWordArray# RealWorld -> WordArray# @@ -720,6 +897,12 @@ bignat_powmod r b0 e0 m s = mwaInitCopyShrink# r r' s m' = naturalFromBigNat# m e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" +-- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 bignat_powmod_words :: Word# -> Word# @@ -731,6 +914,13 @@ bignat_powmod_words b e m = m +-- | Return extended GCD of two non-zero integers. +-- +-- I.e. integer_gcde a b returns (g,x,y) so that ax + by = g +-- +-- Input: a and b are non zero. +-- Output: g must be > 0 +-- integer_gcde :: Integer -> Integer @@ -748,6 +938,12 @@ integer_gcde a b = f (# a,integerOne,integerZero #) (# b,integerZero,integerOne !(# q, r #) -> f new (# r , old_s `integerSub` (q `integerMul` s) , old_t `integerSub` (q `integerMul` t) #) +-- | Computes the modular inverse of two non-zero integers. +-- +-- I.e. y = integer_recip_mod x m +-- = x^(-1) `mod` m +-- +-- with 0 < y < abs m integer_recip_mod :: Integer -> Natural @@ -763,6 +959,12 @@ integer_recip_mod x m = -- a `mod` m > 0 because m > 0 | True -> (# | () #) +-- | Computes the modular exponentiation. +-- +-- I.e. y = integer_powmod b e m +-- = b^e `mod` m +-- +-- with 0 <= y < abs m integer_powmod :: Integer -> Natural ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs deleted ===================================== @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Selected backend --- --- We need this module in addition to GHC.Internal.Bignum.Backend to avoid module loops with --- Check backend. -module GHC.Internal.Bignum.Backend.Selected - ( module Backend - ) -where - -#if defined(BIGNUM_NATIVE) -import GHC.Internal.Bignum.Backend.Native as Backend - -#elif defined(BIGNUM_FFI) -import GHC.Internal.Bignum.Backend.FFI as Backend - -#elif defined(BIGNUM_GMP) -import GHC.Internal.Bignum.Backend.GMP as Backend - -#else -#error Undefined BigNum backend. Use a flag to select it (e.g. gmp, native, ffi)` -#endif ===================================== rts/sm/BlockAlloc.c ===================================== @@ -549,6 +549,8 @@ allocGroupOnNode (uint32_t node, W_ n) ln++; } + // If no free blocks exist then allocate a new megablock and keep just a + // chunk of it. if (ln == NUM_FREE_LISTS) { #if 0 /* useful for debugging fragmentation */ if ((W_)mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W @@ -1020,6 +1022,9 @@ freeGroup(bdescr *p) } // coalesce backwards + // Note that p is not a megablock/megagroup, so there are still live blocks on + // this megablock. Hence we can't coalesce backwards past the first block + // descriptor of this megablock. if (p != FIRST_BDESCR(MBLOCK_ROUND_DOWN(p))) { bdescr *prev; ===================================== rts/sm/MBlock.c ===================================== @@ -95,6 +95,10 @@ typedef struct free_list { } free_list; static free_list *free_list_head; + +// The address in `mblock_address_space` just after the highest MBlock. This +// will be the address of the next new MBlock committed when the free list is +// empty. static W_ mblock_high_watermark; /* * it is quite important that these are in the same cache line as they @@ -103,22 +107,47 @@ static W_ mblock_high_watermark; */ struct mblock_address_range mblock_address_space = { 0, 0, {} }; +// Search for the first committed MBlock at or after startingAt. +// +// start_iter [in/out]: The free_list or a subset of it. Must contain all +// entries for MBlocks at or after startingAt. On return this is set to the +// free_list entry just after the returned MBlock. If no MBlock was found, This +// is set to NULL (the search will have reached the end of the free list). +// +// startingAt [in]: address from which to start searching. This must be to the +// start of an MBlock. +// +// return: The address of the committed MBlock. NULL if no committed MBLock was +// found. +// static void *getAllocatedMBlock(free_list **start_iter, W_ startingAt) { + // We simultaneously traverse the free list and the mblock_address_space. free_list *iter; W_ p = startingAt; for (iter = *start_iter; iter != NULL; iter = iter->next) { + // The current free MBlock, `iter`, is past the current MBlock, `p`. + // This means that `p` is committed (if it was free, then we would have + // found it on the free list). Stop searching. if (p < iter->address) break; + // Note that if `p > iter->address`, then we don't bump `p`. This just + // means we are skipping entries in the free list that correspond to + // MBlocks before `startingAt`. if (p == iter->address) + // Move to the next MBlock. The MBlock may be committed, + // uncommitted, or even past mblock_high_watermark. p += iter->size; } + // Output current free list entry. *start_iter = iter; + // If we reached mblock_high_watermark, then we didn't find any committed + // MBlocks. if (p >= mblock_high_watermark) return NULL; @@ -152,6 +181,11 @@ void * getNextMBlock(void **state STG_UNUSED, void *mblock) return getAllocatedMBlock(casted_state, (W_)mblock + MBLOCK_SIZE); } +// Used to implement getCommittedMBlocks. Search the free list for n contiguous +// free MBlocks, and commit those MBlocks, updating the free_list. Returns the +// address of the start of those MBlocks. Returns NULL if no n contiguous +// MBlocks were found in the free list. Unlike getFreshMBlocks, this doesn't +// attempt to allocate new MBlocks past mblock_high_watermark. static void *getReusableMBlocks(uint32_t n) { struct free_list *iter; @@ -163,7 +197,10 @@ static void *getReusableMBlocks(uint32_t n) if (iter->size < size) continue; + // We've found a large enough group of MBlocks. addr = (void*)iter->address; + + // Update the free list. iter->address += size; iter->size -= size; if (iter->size == 0) { @@ -190,6 +227,9 @@ static void *getReusableMBlocks(uint32_t n) return NULL; } +// Used to implement getCommittedMBlocks. Commit n new MBlocks starting at +// mblock_high_watermark. May exit with an out of memory error if we've passed +// mblock_address_space.end (this is unlikely). static void *getFreshMBlocks(uint32_t n) { W_ size = MBLOCK_SIZE * (W_)n; @@ -207,6 +247,8 @@ static void *getFreshMBlocks(uint32_t n) return addr; } +// Commit n new MBlocks. Tries to reuse freed MBlocks, else commits new +// MBlock(s) at mblock_high_watermark. static void *getCommittedMBlocks(uint32_t n) { void *p; @@ -220,6 +262,11 @@ static void *getCommittedMBlocks(uint32_t n) return p; } +// Decommit n contiguous MBlocks starting at the given address. +// +// addr [in]: address of the start of the n MBlocks (in mblock_address_space). +// +// n [in]: number of contiguous MBlocks to decommit. static void decommitMBlocks(char *addr, uint32_t n) { struct free_list *iter, *prev; @@ -228,17 +275,24 @@ static void decommitMBlocks(char *addr, uint32_t n) osDecommitMemory(addr, size); + // Update the free list. prev = NULL; for (iter = free_list_head; iter != NULL; iter = iter->next) { prev = iter; + // iter is still entirely behind and not contiguous with the MBlocks so + // continue traversing free_list. if (iter->address + iter->size < address) continue; + // The MBlocks are after and contiguous to iter. Simply modify the + // current entry to include n more MBlocks and possibly coalesce. if (iter->address + iter->size == address) { iter->size += size; + // If the current free_list entry now reaches mblock_high_watermark, + // remove the entry and decrement mblock_high_watermark. if (address + size == mblock_high_watermark) { mblock_high_watermark -= iter->size; if (iter->prev) { @@ -251,6 +305,8 @@ static void decommitMBlocks(char *addr, uint32_t n) return; } + // If the current free_list entry now reaches the next free_list + // entry, coalesce them. if (iter->next && iter->next->address == iter->address + iter->size) { struct free_list *next; @@ -269,6 +325,8 @@ static void decommitMBlocks(char *addr, uint32_t n) stgFree(next); } return; + + // The MBlocks are before and contiguous to iter. } else if (address + size == iter->address) { iter->address = address; iter->size += size; @@ -280,6 +338,9 @@ static void decommitMBlocks(char *addr, uint32_t n) ASSERT(iter->prev->address + iter->prev->size < iter->address); } return; + + // The MBlocks are before and not contiguous to iter. Insert a new entry + // just before iter. } else { struct free_list *new_iter; @@ -311,6 +372,7 @@ static void decommitMBlocks(char *addr, uint32_t n) if (address + size == mblock_high_watermark) { mblock_high_watermark -= size; } else { + // Add a new entry to the end of the free list. struct free_list *new_iter; new_iter = stgMallocBytes(sizeof(struct free_list), "freeMBlocks"); ===================================== rts/win32/libHSghc-internal.def.in ===================================== @@ -1,4 +1,4 @@ -LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll +LIBRARY @GhcInternalDll@ EXPORTS init_ghc_hs_iface View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da02b9b49d813c3f7a0199a1a5752d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da02b9b49d813c3f7a0199a1a5752d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/refactor-system-cxx-std-lib-hadrian-rules] 13 commits: Fixes for black holes
by Sven Tennie (＠supersven) 30 May '26

30 May '26

Sven Tennie pushed to branch wip/supersven/refactor-system-cxx-std-lib-hadrian-rules at Glasgow Haskell Compiler / GHC Commits: 63ce5770 by Luite Stegeman at 2026-05-28T12:23:35-04:00 Fixes for black holes - suspend duplicate work for eager black holes - detect eager black holes in checkBlockingQueues - don't overwrite existing black holes even if they're not in an eager blackhole frame - don't deadlock on self when thunk is already blackholed Fixes #26936 - - - - - 037a80dc by Tom McLaughlin at 2026-05-28T12:24:36-04:00 Event/Windows.hsc: rethrow exceptions in overlapped IO This prevents the WinIO manager from swallowing exceptions in overlapped IO. It was added to make WinIO support possible in the `network` library. See https://gitlab.haskell.org/ghc/ghc/-/issues/27283. We also bump __IO_MANAGER_WINIO__ to 2 so libraries can gate on this using CPP. - - - - - 2d53bcdb by Wolfgang Jeltsch at 2026-05-28T12:25:21-04:00 Allow `downsweep` to use nodes of an existing module graph To this end, `downsweep` has not been able to use the nodes of a module graph obtained from a previous downsweeping round. In some GHC API applications, downsweeping is performed somewhat incrementally and therefore could profit from reusing such existing results. This contribution makes this possible. Resolves #27054. Co-authored-by: Matthew Pickering <matthewtpickering(a)gmail.com> - - - - - f4fbb583 by Simon Jakobi at 2026-05-28T12:26:04-04:00 Add regression test for T11226 Closes #11226. - - - - - ed29a5e6 by Sven Tennie at 2026-05-28T17:30:36-04:00 Add optional 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). `LibDir` is set in the inplace `settings` files. For bindists, we generate a new `settings` file with no `LibDir` entry. GHC then defaults to use `topDir` as `libDir` again. This keeps the bindist relocatable. If `LibDir` is a relative path, it is interpreted relatively to `topDir`. The global package db is part of the `lib/` folder. If we want to point for inplace cross-compilers to the succeeding stage's folder, this is done by setting `LibDir`. Thus, the global package db must be found relative to `libDir`` (which may default to `topDir` or be set by `LibDir`). The complexity of settings becomes scary. So, add a test to ensure `LibDir` works as expected. - - - - - 8339cf8f by Sven Tennie at 2026-05-28T17:30:36-04:00 Add Haddock to FileSettings Helping to understand the fields' meanings without deeper analyses. - - - - - 4ce251e4 by Sylvain Henry at 2026-05-28T17:31:39-04:00 foundation test: skip signed minBound `quot` (-1) (#27222) `minBound `quot` (-1)` for fixed-width signed integers is platform dependent: the mathematical result -minBound is not representable in the type. On x86, IDIV traps; LLVM's sdiv is undefined behaviour in this case; on AArch64/RISC-V, SDIV wraps to minBound. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - b8ba7e61 by Simon Jakobi at 2026-05-28T17:32:23-04:00 Prevent dictionary-passing in checkTyEqRhs ...by pre-specializing it to TcM. Previously, wherever checkTyEqRhs was used in other modules, the Core showed dictionary passing ($fMonadIOEnv). The added SPECIALIZE pragma prevents this. - - - - - d603477f by David Eichmann at 2026-05-29T13:17:12-04:00 Hadrian: create a ghc-internal .def file per ghc-internal dll The .def file generated from rts/win32/libHSghc-internal.def.in contains the name of the ghc-internal dll. The correct dll name differs based on if the dll is inplace/final and if using the Dynamic way. Previously, this was not accounted for and inconsistent dlls names where used. That led to failure when loading dlls at runtime in experiments with windows dynamic linking. - - - - - 1fc21753 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: copy backend interface haddocks to Native backend (#27305) The haddock comments documenting the BigNat backend interface (function contracts, expected MutableWordArray# sizes, return-value semantics, etc.) were attached to the FFI backend module. Copy them to the Native backend so they remain in tree once the FFI backend is removed. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 717059df by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove FFI backend (#27305) The FFI backend of ghc-bignum (now part of ghc-internal) had no known users and is easy to recreate by relinking ghc-internal with a custom backend. Remove the backend module, the bignum-ffi cabal flag, and the ffi option from Hadrian's --bignum selector. The backend interface documentation now lives in the Native backend module. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 4bb3b1d8 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove Check backend (#27305) The Check backend of ghc-bignum (now part of ghc-internal) compared the selected backend's output against the Native backend for validation. It had no known users. Remove the backend module, the bignum-check cabal flag, the bignumCheck Hadrian flavour field, and the check- prefix in Hadrian's --bignum selector. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - ed07c7be by Matthew Pickering at 2026-05-30T09:04:21+02:00 hadrian: Refactor system-cxx-std-lib rules I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. This commit increases the `shakeVersion`, to provide backwards compatibility to previous builds with different PackageData. Fixes #25303 Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com> - - - - - 69 changed files: - + changelog.d/fix-blackhole-handling - + changelog.d/hadrian-system-cxx-std-lib-25303 - + changelog.d/libdir-setting - + changelog.d/module-graph-reuse-in-downsweep - + changelog.d/remove-bignum-check-backend - + changelog.d/remove-bignum-ffi-backend - + changelog.d/windows-rethrow-overlapped-exception - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/SysTools/Cpp.hs - compiler/GHC/Tc/Utils/Unify.hs - hadrian/README.md - hadrian/doc/user-settings.md - hadrian/src/CommandLine.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Main.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/ghc-bignum.cabal - libraries/ghc-boot/GHC/Settings/Utils.hs - libraries/ghc-internal/bignum-backend.rst - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Check.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/FFI.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - rts/Messages.c - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.h - rts/include/rts/storage/ClosureMacros.h - rts/win32/libHSghc-internal.def.in - testsuite/tests/MiniQuickCheck.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/A.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/B.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/C.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/D.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/X.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Y.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Z.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - + testsuite/tests/ghc-api/settings/LibDir.hs - + testsuite/tests/ghc-api/settings/LibDir.stdout - + testsuite/tests/ghc-api/settings/all.T - testsuite/tests/numeric/should_run/foundation.hs - + testsuite/tests/perf/should_run/T11226.hs - + testsuite/tests/perf/should_run/T11226.stdout - testsuite/tests/perf/should_run/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9529a7593576d4ae76821520d76a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9529a7593576d4ae76821520d76a4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/refactor-system-cxx-std-lib-hadrian-rules] hadrian: Refactor system-cxx-std-lib rules
by Sven Tennie (＠supersven) 30 May '26

30 May '26

Sven Tennie pushed to branch wip/supersven/refactor-system-cxx-std-lib-hadrian-rules at Glasgow Haskell Compiler / GHC Commits: a9529a75 by Matthew Pickering at 2026-05-30T09:02:21+02:00 hadrian: Refactor system-cxx-std-lib rules I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. This commit increases the `shakeVersion`, to provide backwards compatibility to previous builds with different PackageData. Fixes #25303 Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com> - - - - - 6 changed files: - + changelog.d/hadrian-system-cxx-std-lib-25303 - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Main.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Register.hs Changes: ===================================== changelog.d/hadrian-system-cxx-std-lib-25303 ===================================== @@ -0,0 +1,22 @@ +section: packaging +synopsis: Fix Hadrian rules for system-cxx-std-lib package dependency +issues: #25303 +mrs: !16013 +description: { + Hadrian's handling of the `system-cxx-std-lib` virtual package has been + fixed and made more uniform. + + Previously, `text` had an ad-hoc rule outside of `configurePackage` to + declare a dependency on `system-cxx-std-lib`, the dependency was not + discovered from cabal files, and the package database was not recached after + the `.conf` file was generated. + + The dependency is now read from cabal files via a new + `dependsOnSystemCxxStdLib` field in `PackageData`, and the `.conf` file + is needed inside `configurePackage` alongside all other package + dependencies, consistent with how every other package is handled. + + `shakeVersion` has been bumped to ensure existing build databases are + invalidated when upgrading, preventing binary deserialisation errors due to + the changed `PackageData` type. +} ===================================== hadrian/src/Hadrian/Haskell/Cabal/Parse.hs ===================================== @@ -81,10 +81,11 @@ parsePackageData pkg = do sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ] deps = nubOrd sorted \\ [name] depPkgs = mapMaybe findPackageByName deps + cxxStdLib = elem "system-cxx-std-lib" deps return $ PackageData name version (C.fromShortText (C.synopsis pd)) (C.fromShortText (C.description pd)) - depPkgs gpd + depPkgs cxxStdLib gpd where -- Collect an overapproximation of dependencies by ignoring conditionals collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency] @@ -138,7 +139,9 @@ configurePackage :: Context -> Action () configurePackage context@Context {..} = do putProgressInfo $ "| Configure package " ++ quote (pkgName package) gpd <- pkgGenericDescription package - depPkgs <- packageDependencies <$> readPackageData package + pd <- readPackageData package + let depPkgs = packageDependencies pd + needSystemCxxStdLib = dependsOnSystemCxxStdLib pd -- Stage packages are those we have in this stage. stagePkgs <- stagePackages stage @@ -157,7 +160,12 @@ configurePackage context@Context {..} = do -- We'll need those packages in our package database. deps <- sequence [ pkgConfFile (context { package = pkg, iplace = forceBaseAfterGhcInternal pkg }) | pkg <- depPkgs, pkg `elem` stagePkgs ] - need $ extraPreConfigureDeps ++ deps + -- system-cxx-std-lib is magic.. it doesn't have a cabal file or source code, so we have + -- to treat it specially as `pkgConfFile` uses `readPackageData` to compute the version. + systemCxxStdLib <- sequence [ systemCxxStdLibConfPath (PackageDbLoc stage iplace) | needSystemCxxStdLib ] + need $ extraPreConfigureDeps + ++ deps + ++ systemCxxStdLib -- Figure out what hooks we need. let configureFile = replaceFileName (pkgCabalFile package) "configure" ===================================== hadrian/src/Hadrian/Haskell/Cabal/Type.hs ===================================== @@ -30,6 +30,7 @@ data PackageData = PackageData , synopsis :: String , description :: String , packageDependencies :: [Package] + , dependsOnSystemCxxStdLib :: Bool , genericPackageDescription :: GenericPackageDescription } deriving (Eq, Generic, Show) ===================================== hadrian/src/Main.hs ===================================== @@ -63,7 +63,13 @@ main = do shakeColor <- shouldUseColor let options :: ShakeOptions options = shakeOptions - { shakeChange = ChangeModtimeAndDigest + { -- Bump shakeVersion whenever a type stored in the Shake oracle + -- changes its Binary representation (e.g. fields added/removed + -- from PackageData or other oracle value types). This forces + -- Shake to wipe the stale database instead of crashing on + -- deserialisation. + shakeVersion = "2" + , shakeChange = ChangeModtimeAndDigest , shakeFiles = buildRoot -/- Base.shakeFilesDir , shakeProgress = Progress.hadrianProgress cwd , shakeRebuild = rebuild ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -242,9 +242,6 @@ copyRules = do prefix -/- "html/**" <~ return "utils/haddock/haddock-api/resources" prefix -/- "latex/**" <~ return "utils/haddock/haddock-api/resources" - forM_ [Inplace, Final] $ \iplace -> - root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do - copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file generateRules :: Rules () generateRules = do ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -6,7 +6,6 @@ module Rules.Register ( import Base import Context -import Flavour import Oracles.Setting import Hadrian.BuildPath import Hadrian.Expression @@ -48,14 +47,6 @@ configurePackageRules = do isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend when isGmp $ need [buildP -/- "include/ghc-gmp.h"] - when (pkg == text) $ do - simdutf <- textWithSIMDUTF <$> flavour - when simdutf $ do - -- This is required, otherwise you get Error: hadrian: - -- Encountered missing or private dependencies: - -- system-cxx-std-lib ==1.0 - cxxStdLib <- systemCxxStdLibConfPath $ PackageDbLoc stage Inplace - need [cxxStdLib] Cabal.configurePackage ctx root -/- "**/autogen/cabal_macros.h" %> \out -> do @@ -105,6 +96,12 @@ registerPackageRules rs stage iplace = do target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] writeFileLines stamp [] + -- Special rule for registering system-cxx-std-lib + root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do + copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file + buildWithResources rs $ + target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] + -- Register a package. root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do historyDisable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9529a7593576d4ae76821520d76a40… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9529a7593576d4ae76821520d76a40… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T25450-print-cpu] ghc/Main: Remove redundant PrintEnabledCpuFeatures branch
by Simon Jakobi (＠sjakobi2) 30 May '26

30 May '26

Simon Jakobi pushed to branch wip/sjakobi/T25450-print-cpu at Glasgow Haskell Compiler / GHC Commits: f33fa016 by Simon Jakobi at 2026-05-30T05:09:28+02:00 ghc/Main: Remove redundant PrintEnabledCpuFeatures branch The outer case on postLoadMode already dispatches PrintEnabledCpuFeatures before session setup, so the inner case branch is unreachable and -Woverlapping-patterns rejects it under -Werror in validate builds. - - - - - 1 changed file: - ghc/Main.hs Changes: ===================================== ghc/Main.hs ===================================== @@ -280,7 +280,6 @@ main' postLoadMode units dflags0 args flagWarnings = do ShowPackages -> liftIO $ showUnits hsc_env DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) - PrintEnabledCpuFeatures -> panic "impossible: PrintEnabledCpuFeatures handled before session setup" liftIO $ dumpFinalStats logger View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f33fa016e9e9c71c3de774da3d9aca4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f33fa016e9e9c71c3de774da3d9aca4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 11 commits: hadrian: Fill in more of the default.host toolchain file
by Sven Tennie (＠supersven) 29 May '26

29 May '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 34a80f29 by Matthew Pickering at 2026-05-29T21:09:55+02:00 hadrian: Fill in more of the default.host toolchain file When you are building a cross compiler this file will be used to build stage1 and it's libraries, so we need enough information here to work accurately. There is still more work to be done (see for example, word size is still fixed). - - - - - 2974153a by Matthew Pickering at 2026-05-29T21:09:55+02:00 hadrian: Disable docs when cross compiling Before there were a variety of ad-hoc places where doc building was disabled when cross compiling. * Some CI jobs sets --docs=none in gen_ci.hs * Some CI jobs set --docs=none in .gitlab/ci.sh * There was some logic in hadrian to not need the ["docs"] target when making a bindist. Now the situation is simple: * If you are cross compiling then defaultDocsTargets is empty by default. In theory, there is no reason why we can't build documentation for cross compiler bindists, but this is left to future work to generalise the documentation building rules to allow this (#24289) - - - - - 017b215b by Matthew Pickering at 2026-05-29T21:12:22+02:00 hadrian: Build stage 2 cross compilers * Most of hadrian is abstracted over the stage in order to remove the assumption that the target of all stages is the same platform. This allows the RTS to be built for two different targets for example. * Abstracts the bindist creation logic to allow building either normal or cross bindists. Normal bindists use stage 1 libraries and a stage 2 compiler. Cross bindists use stage 2 libararies and a stage 2 compiler. * hadrian: Make binary-dist-dir the default build target. This allows us to have the logic in one place about which libraries/stages to build with cross compilers. Fixes #24192 New hadrian target: * `binary-dist-dir-cross`: Build a cross compiler bindist (compiler = stage 1, libraries = stage 2) This commit also contains various changes to make stage2 compilers feasible. ------------------------- Metric Decrease: ManyAlternatives MultiComponentModulesRecomp MultiLayerModulesRecomp T10421 T12425 T12707 T13035 T13379 T15703 T16577 T18698a T18698b T18923 T1969 T21839c T3294 T4801 T5030 T5321Fun T5642 T783 T9198 T9872d T9961 parsing001 T5321FD T6048 T12227 T18140 T18282 T9233 T5631 T9630 ------------------------- Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com> Fix rebase: settings-use-distro-mingw is now staged - - - - - 29e0b86b by Matthew Pickering at 2026-05-29T21:12:22+02:00 ci: Test cross bindists We remove the special logic for testing in-tree cross compilers and instead test cross compiler bindists, like we do for all other platforms. - - - - - 0d5176d3 by Matthew Pickering at 2026-05-29T21:12:22+02:00 ci: Introduce CROSS_STAGE variable In preparation for building and testing stage3 bindists we introduce the CROSS_STAGE variable which is used by a CI job to determine what kind of bindist the CI job should produce. At the moment we are only using CROSS_STAGE=2 but in the future we will have some jobs which set CROSS_STAGE=3 to produce native bindists for a target, but produced by a cross compiler, which can be tested on by another CI job on the native platform. CROSS_STAGE=2: Build a normal cross compiler bindist CROSS_STAGE=3: Build a stage 3 bindist, one which is a native compiler and library for the target - - - - - da29dd60 by Sven Tennie at 2026-05-29T21:12:22+02:00 ghc: Distinguish between having an interpreter and having an internal one Otherwise, we fail with warnings when compiling tools. Actually, these are related but different things: - ghc can run an interpreter (either internal or external) - ghc is compiled with an internal interpreter - - - - - 01bd1662 by Matthew Pickering at 2026-05-29T21:12:22+02:00 hadrian: Refactor system-cxx-std-lib rules0 I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. Fixes #25303 - - - - - b400aa0b by Sven Tennie at 2026-05-29T21:12:22+02:00 ci: Increase timeout for emulators Test runs with emulators naturally take longer than on native machines. Generate jobs.yml - - - - - 47b4d424 by Matthew Pickering at 2026-05-29T21:12:22+02:00 ci: Javascript don't set CROSS_EMULATOR There is no CROSS_EMULATOR needed to run javascript binaries, so we don't set the CROSS_EMULATOR to some dummy value. - - - - - 321dd3ef by Sven Tennie at 2026-05-29T21:12:22+02:00 Javascript skip T23697 See #22355 about how HSC2HS and the Javascript target don't play well together. - - - - - a3b31d8e by Sven Tennie at 2026-05-29T21:12:22+02:00 Mark T24602 as fragile It was skipped before (due to CROSS_EMULATOR being set, which changed for JS), so we don't make things worse by marking it as fragile. - - - - - 64 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - configure.ac - distrib/configure.ac.in - hadrian/README.md - hadrian/bindist/config.mk.in - hadrian/cfg/default.host.target.in - + hadrian/cfg/system.config.host.in - hadrian/cfg/system.config.in - + hadrian/cfg/system.config.target.in - hadrian/hadrian.cabal - hadrian/src/Base.hs - + hadrian/src/BindistConfig.hs - hadrian/src/Builder.hs - hadrian/src/Context.hs - hadrian/src/Expression.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Hadrian/Builder.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Hadrian/Haskell/Hash.hs - hadrian/src/Hadrian/Oracles/TextFile.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Oracles/Flavour.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Oracles/TestSettings.hs - hadrian/src/Packages.hs - hadrian/src/Rules.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/CabalReinstall.hs - hadrian/src/Rules/Changelog.hs - hadrian/src/Rules/Compile.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Gmp.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Program.hs - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Builders/Common.hs - hadrian/src/Settings/Builders/Configure.hs - hadrian/src/Settings/Builders/DeriveConstants.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Builders/Hsc2Hs.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Builders/SplitSections.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/GhcInGhci.hs - hadrian/src/Settings/Flavours/Performance.hs - hadrian/src/Settings/Flavours/QuickCross.hs - hadrian/src/Settings/Flavours/Validate.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Program.hs - hadrian/src/Settings/Warnings.hs - libraries/base/tests/all.T - m4/fp_find_nm.m4 - m4/prep_target_file.m4 - testsuite/ghc-config/ghc-config.hs - testsuite/tests/javascript/closure/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/850bece6dffc2a9e263ae637a60ad9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/850bece6dffc2a9e263ae637a60ad9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 3 commits: ghc-bignum: copy backend interface haddocks to Native backend (#27305)
by Marge Bot (＠marge-bot) 29 May '26

29 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1fc21753 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: copy backend interface haddocks to Native backend (#27305) The haddock comments documenting the BigNat backend interface (function contracts, expected MutableWordArray# sizes, return-value semantics, etc.) were attached to the FFI backend module. Copy them to the Native backend so they remain in tree once the FFI backend is removed. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 717059df by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove FFI backend (#27305) The FFI backend of ghc-bignum (now part of ghc-internal) had no known users and is easy to recreate by relinking ghc-internal with a custom backend. Remove the backend module, the bignum-ffi cabal flag, and the ffi option from Hadrian's --bignum selector. The backend interface documentation now lives in the Native backend module. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 4bb3b1d8 by Sylvain Henry at 2026-05-29T13:18:14-04:00 ghc-bignum: remove Check backend (#27305) The Check backend of ghc-bignum (now part of ghc-internal) compared the selected backend's output against the Native backend for validation. It had no known users. Remove the backend module, the bignum-check cabal flag, the bignumCheck Hadrian flavour field, and the check- prefix in Hadrian's --bignum selector. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 18 changed files: - + changelog.d/remove-bignum-check-backend - + changelog.d/remove-bignum-ffi-backend - hadrian/README.md - hadrian/doc/user-settings.md - hadrian/src/CommandLine.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/ghc-bignum.cabal - libraries/ghc-internal/bignum-backend.rst - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Check.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/FFI.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs - − libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs Changes: ===================================== changelog.d/remove-bignum-check-backend ===================================== @@ -0,0 +1,11 @@ +section: packaging +synopsis: Remove the Check backend of ghc-bignum +issues: #27305 +mrs: !16106 + +description: { + The Check backend of ghc-bignum (now part of ghc-internal), which compared + the results of the selected backend against the Native backend, has been + removed along with the ``bignum-check`` cabal flag and the ``check-`` + prefix in Hadrian's ``--bignum`` option. +} ===================================== changelog.d/remove-bignum-ffi-backend ===================================== @@ -0,0 +1,12 @@ +section: packaging +synopsis: Remove the FFI backend of ghc-bignum +issues: #27305 +mrs: !16106 + +description: { + The FFI backend of ghc-bignum (now part of ghc-internal) has been removed. + It had no known users and was easy to recreate by relinking ghc-internal + with a custom backend implementation. As a result, the ``bignum-ffi`` + cabal flag has been dropped, and selecting the ``ffi`` backend via + Hadrian's ``--bignum`` option is no longer supported. +} ===================================== hadrian/README.md ===================================== @@ -101,7 +101,7 @@ Stage2 GHC. * `--skip-depends`: skips rebuilding Haskell module dependency files. -* `--bignum={native,gmp,check-gmp,ffi}`: **Deprecated.** Use the `+native_bignum` flavour +* `--bignum={native,gmp}`: **Deprecated.** Use the `+native_bignum` flavour transformer instead (e.g. `--flavour=default+native_bignum`). When building for the JavaScript target, the native bignum backend is enabled automatically. ===================================== hadrian/doc/user-settings.md ===================================== @@ -24,10 +24,8 @@ data Flavour = Flavour { extraArgs :: Args, -- | Build these packages. packages :: Stage -> Action [Package], - -- | Bignum backend: 'native', 'gmp', 'ffi', etc. + -- | Bignum backend: 'native', 'gmp', etc. bignumBackend :: String, - -- | Check selected bignum backend against native backend - bignumCheck :: Bool, -- | Build the @text@ package with @simdutf@ support. Disabled by -- default due to packaging difficulties described in #20724. textWithSIMDUTF :: Bool, ===================================== hadrian/src/CommandLine.hs ===================================== @@ -1,7 +1,7 @@ module CommandLine ( optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, lookupFreeze2, lookupSkipDepends, lookupBignum, - cmdBignum, cmdBignumCheck, cmdProgressInfo, cmdCompleteSetting, + cmdBignum, cmdProgressInfo, cmdCompleteSetting, cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs, cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs, cmdKeepResponseFiles @@ -32,7 +32,6 @@ data CommandLineArgs = CommandLineArgs , skipDepends :: Bool , unitIdHash :: Bool , bignum :: Maybe String - , bignumCheck :: Bool , progressInfo :: ProgressInfo , buildRoot :: BuildRoot , testArgs :: TestArgs @@ -54,7 +53,6 @@ defaultCommandLineArgs = CommandLineArgs , skipDepends = False , unitIdHash = False , bignum = Nothing - , bignumCheck = False , progressInfo = Brief , buildRoot = BuildRoot "_build" , testArgs = defaultTestArgs @@ -132,10 +130,7 @@ readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms } readBignum :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) readBignum Nothing = Right id -readBignum (Just ms) = Right $ \flags -> case break (== '-') (lower ms) of - (backend,"") -> flags { bignum = Just backend } - ("check",'-':backend) -> flags { bignum = Just backend, bignumCheck = True } - _ -> flags { bignum = Just (lower ms) } +readBignum (Just ms) = Right $ \flags -> flags { bignum = Just (lower ms) } readBuildRoot :: FilePath -> Either String (CommandLineArgs -> CommandLineArgs) readBuildRoot ms = @@ -302,7 +297,7 @@ optDescrs = , Option [] ["skip-depends"] (NoArg readSkipDepends) "Skip rebuilding dependency information." , Option [] ["bignum"] (OptArg readBignum "BACKEND") - "Select bignum backend: native, gmp (default), check-gmp (gmp compared to native), ffi." + "Select bignum backend: native, gmp (default)." , Option [] ["progress-info"] (ReqArg readProgressInfo "STYLE") "Progress info style (None, Brief, Normal or Unicorn)." , Option [] ["docs"] (ReqArg readDocsArg "TARGET") @@ -429,9 +424,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs cmdBignum :: Action (Maybe String) cmdBignum = bignum <$> cmdLineArgs -cmdBignumCheck :: Action Bool -cmdBignumCheck = bignumCheck <$> cmdLineArgs - cmdKeepResponseFiles :: Action Bool cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs ===================================== hadrian/src/Flavour/Type.hs ===================================== @@ -19,10 +19,8 @@ data Flavour = Flavour { extraArgs :: Args, -- | Build these packages. packages :: Stage -> Action [Package], - -- | Bignum backend: 'native', 'gmp', 'ffi', etc. + -- | Bignum backend: 'native', 'gmp', etc. bignumBackend :: String, - -- | Check selected bignum backend against native backend - bignumCheck :: Bool, -- | Build the @text@ package with @simdutf@ support. Disabled by -- default due to packaging difficulties described in #20724. textWithSIMDUTF :: Bool, ===================================== hadrian/src/Settings.hs ===================================== @@ -3,7 +3,7 @@ module Settings ( getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath, - isLibrary, stagePackages, getBignumBackend, getBignumCheck, completeSetting, + isLibrary, stagePackages, getBignumBackend, completeSetting, queryBuildTarget, queryHostTarget, queryTargetTarget, queryBuild, queryHost, queryTarget, queryArch, queryOS, queryVendor @@ -46,11 +46,6 @@ getRtsWays = expr flavour >>= rtsWays getBignumBackend :: Expr String getBignumBackend = bignumBackend <$> expr flavour -getBignumCheck :: Expr Bool -getBignumCheck = expr $ cmdBignum >>= \case - Nothing -> bignumCheck <$> flavour - Just _ -> cmdBignumCheck - stagePackages :: Stage -> Action [Package] stagePackages stage = do f <- flavour ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -241,7 +241,6 @@ runTestBuilderArgs = builder Testsuite ? do -- MP: TODO, these should be queried from the test compiler? bignumBackend <- getBignumBackend - bignumCheck <- getBignumCheck keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs) @@ -307,7 +306,7 @@ runTestBuilderArgs = builder Testsuite ? do , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags , arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasDynamicRts) , arg "-e", arg $ asBool "config.ghc_with_threaded_rts=" (hasThreadedRts) - , arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native" && not bignumCheck) + , arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native") , arg "-e", arg $ asBool "config.target_has_smp=" targetWithSMP , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic , arg "-e", arg $ "config.leading_underscore=" ++ show leadingUnderscore ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -293,7 +293,6 @@ defaultFlavour = Flavour , extraArgs = defaultExtraArgs , packages = defaultPackages , bignumBackend = defaultBignumBackend - , bignumCheck = False , textWithSIMDUTF = False , libraryWays = defaultLibraryWays , rtsWays = defaultRtsWays ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -240,15 +240,11 @@ ghcInternalArgs = package ghcInternal ? do includesGmp <- getSetting GmpIncludeDir backend <- getBignumBackend - check <- getBignumCheck mconcat [ -- select bignum backend builder (Cabal Flags) ? arg ("bignum-" <> backend) - , -- check the selected backend against native backend - builder (Cabal Flags) ? check `cabalFlag` "bignum-check" - -- backend specific , case backend of "gmp" -> mconcat ===================================== libraries/ghc-bignum/ghc-bignum.cabal ===================================== @@ -36,7 +36,7 @@ library GHC.Internal.Bignum.Primitives as GHC.Num.Primitives , GHC.Internal.Bignum.WordArray as GHC.Num.WordArray , GHC.Internal.Bignum.Backend as GHC.Num.Backend - , GHC.Internal.Bignum.Backend.Selected as GHC.Num.Backend.Selected + , GHC.Internal.Bignum.Backend as GHC.Num.Backend.Selected , GHC.Internal.Bignum.Backend.Native as GHC.Num.Backend.Native , GHC.Internal.Bignum.BigNat as GHC.Num.BigNat , GHC.Internal.Bignum.Natural as GHC.Num.Natural ===================================== libraries/ghc-internal/bignum-backend.rst ===================================== @@ -33,20 +33,9 @@ supported: integer-simple package. The major difference is that it uses a much more efficient memory representation (integer-simple was based on Haskell lists) and that it allows a lot more code sharing between the different backends than - was previously possible between integer-gmp and integer-simple. - -* FFI: an implementation that relies on external FFI calls. This backend can be - useful: - - * for alternative GHC backends that target non native platforms (JavaScript, - JVM, etc.): the backend can dynamically match and rewrite the FFI calls in - order to call the appropriate platform specific BigNum API. - - * to test new native backends: just tweak the ghc-bignum build to link with - the native library providing the implementation of the FFI calls - - Note that the FFI backend module contains the description of the interface - that needs to be implemented by every backend. + was previously possible between integer-gmp and integer-simple. The Native + backend module contains the description of the interface that needs to be + implemented by every backend. This package has been designed to make the implementation of new backends relatively easy. Previously you had to implement the whole Integer/Natural ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -56,21 +56,11 @@ Flag bignum-native Manual: True Default: False -Flag bignum-ffi - Description: Enable FFI bignum backend - Manual: True - Default: False - Flag bignum-gmp Description: Enable GMP bignum backend Manual: True Default: False -Flag bignum-check - Description: Validate results of the enabled backend against native backend. - Manual: True - Default: False - Flag need-atomic Description: Enable linking with "atomic" library (for 64-bit atomic ops on armel, #20549) Manual: True @@ -382,13 +372,11 @@ Library -- Bignum configuration ---------------------------------------- -- check that at least one backend is enabled - if !flag(bignum-native) && !flag(bignum-gmp) && !flag(bignum-ffi) + if !flag(bignum-native) && !flag(bignum-gmp) buildable: False -- check that at most one flag is set - if flag(bignum-native) && (flag(bignum-gmp) || flag(bignum-ffi)) - buildable: False - if flag(bignum-gmp) && flag(bignum-ffi) + if flag(bignum-native) && flag(bignum-gmp) buildable: False if flag(bignum-gmp) @@ -398,25 +386,14 @@ Library c-sources: cbits/gmp_wrappers.c - if flag(bignum-ffi) - cpp-options: -DBIGNUM_FFI - other-modules: - GHC.Internal.Bignum.Backend.FFI - if flag(bignum-native) cpp-options: -DBIGNUM_NATIVE - if flag(bignum-check) - cpp-options: -DBIGNUM_CHECK - other-modules: - GHC.Internal.Bignum.Backend.Check - exposed-modules: GHC.Internal.Bignum.Primitives GHC.Internal.Bignum.WordArray GHC.Internal.Bignum.BigNat GHC.Internal.Bignum.Backend - GHC.Internal.Bignum.Backend.Selected GHC.Internal.Bignum.Backend.Native GHC.Internal.Bignum.Natural GHC.Internal.Bignum.Integer ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend.hs ===================================== @@ -7,9 +7,12 @@ module GHC.Internal.Bignum.Backend ) where -#if defined(BIGNUM_CHECK) -import GHC.Internal.Bignum.Backend.Check as Backend +#if defined(BIGNUM_NATIVE) +import GHC.Internal.Bignum.Backend.Native as Backend + +#elif defined(BIGNUM_GMP) +import GHC.Internal.Bignum.Backend.GMP as Backend + #else -import GHC.Internal.Bignum.Backend.Selected as Backend +#error Undefined BigNum backend. Use a flag to select it (e.g. gmp, native)` #endif - ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Check.hs deleted ===================================== @@ -1,508 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | Check Native implementation against another backend -module GHC.Internal.Bignum.Backend.Check where - -import GHC.Internal.CString -import GHC.Internal.Prim -import GHC.Internal.Types -import GHC.Internal.Bignum.WordArray -import GHC.Internal.Bignum.Primitives -import {-# SOURCE #-} GHC.Internal.Bignum.Integer -import {-# SOURCE #-} GHC.Internal.Bignum.Natural -import qualified GHC.Internal.Bignum.Backend.Native as Native -import qualified GHC.Internal.Bignum.Backend.Selected as Other - -#if defined(BIGNUM_NATIVE) -#error You can't validate Native backend against itself. Choose another backend (e.g. gmp, ffi) -#endif - -default () - --- | ghc-bignum backend name -backendName :: [Char] -backendName = unpackAppendCString# "check-"# Other.backendName - -- we don't have (++) at our disposal, so we directly use - -- `unpackAppendCString#` - -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare a b = - let - gr = Other.bignat_compare a b - nr = Native.bignat_compare a b - in case gr ==# nr of - 0# -> unexpectedValue_Int# (# #) - _ -> gr - -mwaCompare - :: MutableWordArray# s - -> MutableWordArray# s - -> State# s - -> (# State# s, Bool# #) -mwaCompare mwa mwb s = - case mwaSize# mwa s of - (# s, szA #) -> case mwaSize# mwb s of - (# s, szB #) -> case szA ==# szB of - 0# -> (# s, 0# #) - _ -> let - go i s - | isTrue# (i <# 0#) = (# s, 1# #) - | True = - case readWordArray# mwa i s of - (# s, a #) -> case readWordArray# mwb i s of - (# s, b #) -> case a `eqWord#` b of - 0# -> (# s, 0# #) - _ -> go (i -# 1#) s - in go (szA -# 1#) s - -mwaCompareOp - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { s -> - case g mwb s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - (# s, _ #) -> s - }}}}}} - -mwaCompareOp2 - :: MutableWordArray# s - -> MutableWordArray# s - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp2 mwa mwb f g s = - case mwaSize# mwa s of { (# s, szA #) -> - case mwaSize# mwb s of { (# s, szB #) -> - case newWordArray# szA s of { (# s, mwa' #) -> - case newWordArray# szB s of { (# s, mwb' #) -> - case f mwa mwb s of { s -> - case g mwa' mwb' s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaTrimZeroes# mwa' s of { s -> - case mwaTrimZeroes# mwb' s of { s -> - case mwaCompare mwa mwa' s of { (# s, ba #) -> - case mwaCompare mwb mwb' s of { (# s, bb #) -> - case ba &&# bb of - 0# -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> s - }}}}}}}}}}}} - -mwaCompareOpBool - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> State# s - -> (# State# s, Bool# #) -mwaCompareOpBool mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case ra ==# rb of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> case ra of -- don't compare MWAs if underflow signaled! - 0# -> (# s, ra #) -- underflow - _ -> case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -mwaCompareOpWord - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> State# s - -> (# State# s, Word# #) -mwaCompareOpWord mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, b #) -> case b &&# (ra `eqWord#` rb) of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_add m wa wb) - (\m -> Native.bignat_add m wa wb) - -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_add_word m wa b) - (\m -> Native.bignat_add_word m wa b) - -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_mul_word m wa b) - (\m -> Native.bignat_mul_word m wa b) - -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub m wa wb) - (\m -> Native.bignat_sub m wa wb) - -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub_word m wa b) - (\m -> Native.bignat_sub_word m wa b) - -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_mul m wa wb) - (\m -> Native.bignat_mul m wa wb) - -bignat_popcount :: WordArray# -> Word# -bignat_popcount wa = - let - gr = Other.bignat_popcount wa - nr = Native.bignat_popcount wa - in case gr `eqWord#` nr of - 0# -> 1## `quotWord#` 0## - _ -> gr - -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftl m wa n) - (\m -> Native.bignat_shiftl m wa n) - -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr m wa n) - (\m -> Native.bignat_shiftr m wa n) - -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr_neg m wa n) - (\m -> Native.bignat_shiftr_neg m wa n) - -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_or mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_or m wa wb) - (\m -> Native.bignat_or m wa wb) - -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_xor mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_xor m wa wb) - (\m -> Native.bignat_xor m wa wb) - -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and m wa wb) - (\m -> Native.bignat_and m wa wb) - -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and_not mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and_not m wa wb) - (\m -> Native.bignat_and_not m wa wb) - -bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb - = mwaCompareOp2 mwq mwr - (\m1 m2 -> Other.bignat_quotrem m1 m2 wa wb) - (\m1 m2 -> Native.bignat_quotrem m1 m2 wa wb) - -bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb - = mwaCompareOp mwq - (\m -> Other.bignat_quot m wa wb) - (\m -> Native.bignat_quot m wa wb) - -bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_rem m wa wb) - (\m -> Native.bignat_rem m wa wb) - -bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b - = mwaCompareOpWord mwq - (\m -> Other.bignat_quotrem_word m wa b) - (\m -> Native.bignat_quotrem_word m wa b) - -bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b - = mwaCompareOp mwq - (\m -> Other.bignat_quot_word m wa b) - (\m -> Native.bignat_quot_word m wa b) - -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word wa b = - let - gr = Other.bignat_rem_word wa b - nr = Native.bignat_rem_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_gcd m wa wb) - (\m -> Native.bignat_gcd m wa wb) - -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word wa b = - let - gr = Other.bignat_gcd_word wa b - nr = Native.bignat_gcd_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word a b = - let - gr = Other.bignat_gcd_word_word a b - nr = Native.bignat_gcd_word_word a b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double a e = - let - gr = Other.bignat_encode_double a e - nr = Native.bignat_encode_double a e - in case gr ==## nr of - 1# -> gr - _ -> case unexpectedValue of - !_ -> 0.0## - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word b e m = - let - gr = Other.bignat_powmod_word b e m - nr = Native.bignat_powmod_word b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m - = mwaCompareOp r - (\r' -> Other.bignat_powmod r' b e m) - (\r' -> Native.bignat_powmod r' b e m) - -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words b e m = - let - gr = Other.bignat_powmod_words b e m - nr = Native.bignat_powmod_words b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -integer_gcde - :: Integer - -> Integer - -> (# Integer, Integer, Integer #) -integer_gcde a b = - let - !(# g0,x0,y0 #) = Other.integer_gcde a b - !(# g1,x1,y1 #) = Native.integer_gcde a b - in if isTrue# (integerEq# x0 x1 - &&# integerEq# y0 y1 - &&# integerEq# g0 g1) - then (# g0, x0, y0 #) - else case unexpectedValue of - !_ -> (# integerZero, integerZero, integerZero #) - -integer_recip_mod - :: Integer - -> Natural - -> (# Natural | () #) -integer_recip_mod x m = - let - !r0 = Other.integer_recip_mod x m - !r1 = Native.integer_recip_mod x m - in case (# r0, r1 #) of - (# (# | () #), (# | () #) #) -> r0 - (# (# y0 | #), (# y1 | #) #) - | isTrue# (naturalEq# y0 y1) -> r0 - _ -> case unexpectedValue of - !_ -> (# | () #) - -integer_powmod - :: Integer - -> Natural - -> Natural - -> Natural -integer_powmod b e m = - let - !r0 = Other.integer_powmod b e m - !r1 = Native.integer_powmod b e m - in if isTrue# (naturalEq# r0 r1) - then r0 - else case unexpectedValue of - !_ -> naturalZero ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/FFI.hs deleted ===================================== @@ -1,641 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} - --- | External BigNat backend that directly call FFI operations. --- --- This backend can be useful for specific compilers such as GHCJS or Asterius --- that replace bignat foreign calls with calls to the native platform bignat --- library (e.g. JavaScript's BigInt). You can also link an extra object --- providing the implementation. -module GHC.Internal.Bignum.Backend.FFI where - -import GHC.Internal.Prim -import GHC.Internal.Types -import GHC.Internal.Bignum.WordArray -import GHC.Internal.Bignum.Primitives -import qualified GHC.Internal.Bignum.Backend.Native as Native -import {-# SOURCE #-} GHC.Internal.Bignum.Natural -import {-# SOURCE #-} GHC.Internal.Bignum.Integer - --- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base --- (This module uses the empty tuple () and string literals.) -import GHC.Internal.Tuple () -import GHC.Internal.CString () - -default () - --- | ghc-bignum backend name -backendName :: [Char] -backendName = "ffi" - --- | Compare two non-zero BigNat of the same length --- --- Return: --- < 0 ==> LT --- == 0 ==> EQ --- > 0 ==> GT -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare = ghc_bignat_compare - -foreign import ccall unsafe ghc_bignat_compare - :: WordArray# - -> WordArray# - -> Int# - --- | Add two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb s - = ioVoid (ghc_bignat_add mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | Add a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b s = - ioVoid (ghc_bignat_add_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Multiply a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b s = - ioVoid (ghc_bignat_mul_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Sub two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb s = ioBool (ghc_bignat_sub mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_sub - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO Bool - --- | Sub a non-zero word from a non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b s = ioBool (ghc_bignat_sub_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_sub_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO Bool - --- | Multiply two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a+size b --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb s = ioVoid (ghc_bignat_mul mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | PopCount of a non-zero BigNat -bignat_popcount :: WordArray# -> Word# -bignat_popcount = ghc_bignat_popcount - -foreign import ccall unsafe ghc_bignat_popcount - :: WordArray# - -> Word# - --- | Left-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + required new limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n s = ioVoid (ghc_bignat_shiftl mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n s = ioVoid (ghc_bignat_shiftr mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits by first --- converting it into its two's complement representation and then again after --- the arithmetic shift. --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Words (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n s = ioVoid (ghc_bignat_shiftr_neg mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - - --- | OR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_or #-} -bignat_or mwa wa wb s = ioVoid (ghc_bignat_or mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | XOR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_xor #-} -bignat_xor mwa wa wb s = ioVoid (ghc_bignat_xor mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | AND two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: min (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and #-} -bignat_and mwa wa wb s = ioVoid (ghc_bignat_and mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | ANDNOT two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and_not #-} -bignat_and_not mwa wa wb s = ioVoid (ghc_bignat_and_not mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of two non-zero BigNat --- --- Result quotient and remainder are to be stored in the MutableWordArray#. --- The first one (quotient) has size: size(A)-size(B)+1 --- The second one (remainder) has size: size(b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem - :: MutableWordArray# RealWorld -- ^ Quotient - -> MutableWordArray# RealWorld -- ^ Remainder - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb s = - ioVoid (ghc_bignat_quotrem mwq mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Quotient of two non-zero BigNat --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A)-size(B)+1 --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb s = - ioVoid (ghc_bignat_quot mwq wa wb) s - -foreign import ccall unsafe ghc_bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Remainder of two non-zero BigNat --- --- Result remainder is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_rem - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb s = - ioVoid (ghc_bignat_rem mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The remainder is returned. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b s = - ioWord# (ghc_bignat_quotrem_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO Word - --- | Quot of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b s = - ioVoid (ghc_bignat_quot_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Remainder of a non-zero BigNat and a non-zero Word --- --- The remainder is returned. -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word = ghc_bignat_rem_word - -foreign import ccall unsafe ghc_bignat_rem_word - :: WordArray# - -> Word# - -> Word# - - --- | Greatest common divisor (GCD) of two non-zero and non-one BigNat --- --- Result GCD is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- The first WordArray# is greater than the second WordArray#. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb s = - ioVoid (ghc_bignat_gcd mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a --- non-zero/non-one Word# --- --- Result GCD is returned -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word = ghc_bignat_gcd_word - -foreign import ccall unsafe ghc_bignat_gcd_word - :: WordArray# - -> Word# - -> Word# - --- | Greatest common divisor (GCD) of two Word# --- --- Result GCD is returned -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word = ghc_bignat_gcd_word_word - -foreign import ccall unsafe ghc_bignat_gcd_word_word - :: Word# - -> Word# - -> Word# - --- | Encode (# BigNat mantissa, Int# exponent #) into a Double# -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double = ghc_bignat_encode_double - -foreign import ccall unsafe ghc_bignat_encode_double - :: WordArray# - -> Int# - -> Double# - --- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word = ghc_bignat_powmod_word - -foreign import ccall unsafe ghc_bignat_powmod_word - :: WordArray# -> WordArray# -> Word# -> Word# - --- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 --- --- Result is to be stored in the MutableWordArray# (which size is equal to the --- one of m). --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m s = - ioVoid (ghc_bignat_powmod r b e m) s - -foreign import ccall unsafe ghc_bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> IO () - --- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words = ghc_bignat_powmod_words - -foreign import ccall unsafe ghc_bignat_powmod_words - :: Word# -> Word# -> Word# -> Word# - - --- | Return extended GCD of two non-zero integers. --- --- I.e. integer_gcde a b returns (g,x,y) so that ax + by = g --- --- Input: a and b are non zero. --- Output: g must be > 0 --- -integer_gcde - :: Integer - -> Integer - -> (# Integer, Integer, Integer #) -integer_gcde = Native.integer_gcde - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. - - --- | Computes the modular inverse of two non-zero integers. --- --- I.e. y = integer_recip_mod x m --- = x^(-1) `mod` m --- --- with 0 < y < abs m -integer_recip_mod - :: Integer - -> Natural - -> (# Natural | () #) -integer_recip_mod = Native.integer_recip_mod - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. - --- | Computes the modular exponentiation. --- --- I.e. y = integer_powmod b e m --- = b^e `mod` m --- --- with 0 <= y < abs m -integer_powmod - :: Integer - -> Natural - -> Natural - -> Natural -integer_powmod = Native.integer_powmod - -- for now we use Native's implementation. If some FFI backend user needs a - -- specific implementation, we'll need to determine a prototype to pass and - -- return BigNat signs and sizes via FFI. ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Native.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Internal.Bignum.Backend.Native where #include "MachDeps.h" #include "WordSize.h" -#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) || defined(BIGNUM_FFI) +#if defined(BIGNUM_NATIVE) import {-# SOURCE #-} GHC.Internal.Bignum.BigNat import {-# SOURCE #-} GHC.Internal.Bignum.Natural import {-# SOURCE #-} GHC.Internal.Bignum.Integer @@ -50,6 +50,12 @@ count_words_bits_int :: Word# -> (# Int#, Int# #) count_words_bits_int n = case count_words_bits n of (# nw, nb #) -> (# word2Int# nw, word2Int# nb #) +-- | Compare two non-zero BigNat of the same length +-- +-- Return: +-- < 0 ==> LT +-- == 0 ==> EQ +-- > 0 ==> GT bignat_compare :: WordArray# -> WordArray# -> Int# bignat_compare wa wb = go (sz -# 1#) where @@ -62,6 +68,13 @@ bignat_compare wa wb = go (sz -# 1#) | isTrue# (a `gtWord#` b) -> 1# | True -> -1# +-- | Add two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_add :: MutableWordArray# s -- ^ Result -> WordArray# @@ -120,6 +133,13 @@ bignat_add mwa wa wb = addABc 0# 0## in case mwaWrite# mwa i r s of s' -> addAoBc wab (i +# 1#) carry' s' +-- | Add a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_add_word :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -128,6 +148,15 @@ bignat_add_word -> State# RealWorld bignat_add_word mwa wa b s = mwaInitArrayPlusWord mwa wa b s +-- | Sub a non-zero word from a non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. bignat_sub_word :: MutableWordArray# RealWorld -> WordArray# @@ -154,6 +183,13 @@ bignat_sub_word mwa wa b = go b 0# (# l , c #) -> case mwaWrite# mwa i l s of s1 -> go (int2Word# c) (i +# 1#) s1 +-- | Multiply a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_mul_word :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -173,6 +209,13 @@ bignat_mul_word mwa wa b = go 0# 0## s' -> go (i +# 1#) carry' s' +-- | Multiply two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a+size b +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_mul :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -214,6 +257,15 @@ bignat_mul mwa wa wb s1 = bi -> case mul mwa wa bi i ctzA 0## s of s' -> mulEachB (i +# 1#) s' +-- | Sub two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. bignat_sub :: MutableWordArray# RealWorld -> WordArray# @@ -227,6 +279,7 @@ bignat_sub mwa wa wb s = case mwaArrayCopy# mwa 0# wa 0# (wordArraySize# wa) s of s' -> mwaSubInplaceArray mwa 0# wb s' +-- | PopCount of a non-zero BigNat bignat_popcount :: WordArray# -> Word# bignat_popcount wa = go 0# 0## where @@ -235,6 +288,13 @@ bignat_popcount wa = go 0# 0## | isTrue# (i ==# sz) = c | True = go (i +# 1#) (c `plusWord#` popCnt# (indexWordArray# wa i)) +-- | Left-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + required new limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftl :: MutableWordArray# s -> WordArray# @@ -267,6 +327,13 @@ bignat_shiftl mwa wa n s1 = s' -> mwaBitShift (i +# 1#) c' s' +-- | Right-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftr :: MutableWordArray# s -> WordArray# @@ -293,6 +360,15 @@ bignat_shiftr mwa wa n s1 in case mwaWrite# mwa i v s of s' -> mwaBitShift (i -# 1#) c' s' +-- | Right-shift a non-zero BigNat by a non-zero amount of bits by first +-- converting it into its two's complement representation and then again after +-- the arithmetic shift. +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Words (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. bignat_shiftr_neg :: MutableWordArray# s -> WordArray# @@ -329,6 +405,10 @@ bignat_shiftr_neg mwa wa n s1 in go 0# +-- | OR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) bignat_or :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -346,6 +426,13 @@ bignat_or mwa wa wb s1 case mwaInitArrayBinOp mwa wx wy or# s of s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' +-- | XOR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_xor :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -363,6 +450,13 @@ bignat_xor mwa wa wb s1 case mwaInitArrayBinOp mwa wx wy xor# s of s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' +-- | AND two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: min (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_and :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -371,6 +465,13 @@ bignat_and -> State# RealWorld bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s +-- | ANDNOT two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_and_not :: MutableWordArray# RealWorld -- ^ Result -> WordArray# @@ -384,9 +485,17 @@ bignat_and_not mwa wa wb s = !szA = wordArraySize# wa !szB = wordArraySize# wb +-- | QuotRem of two non-zero BigNat +-- +-- Result quotient and remainder are to be stored in the MutableWordArray#. +-- The first one (quotient) has size: size(A)-size(B)+1 +-- The second one (remainder) has size: size(b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quotrem - :: MutableWordArray# s - -> MutableWordArray# s + :: MutableWordArray# s -- ^ Quotient + -> MutableWordArray# s -- ^ Remainder -> WordArray# -> WordArray# -> State# s @@ -434,8 +543,15 @@ bignat_quotrem mwq mwr uwa uwb s0 = +-- | Quotient of two non-zero BigNat +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A)-size(B)+1 +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quot - :: MutableWordArray# RealWorld + :: MutableWordArray# RealWorld -- ^ Quotient -> WordArray# -> WordArray# -> State# RealWorld @@ -445,8 +561,15 @@ bignat_quot mwq wa wb s = case newWordArray# (wordArraySize# wb) s of (# s, mwr #) -> bignat_quotrem mwq mwr wa wb s +-- | Remainder of two non-zero BigNat +-- +-- Result remainder is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_rem - :: MutableWordArray# RealWorld + :: MutableWordArray# RealWorld -- ^ Remainder -> WordArray# -> WordArray# -> State# RealWorld @@ -577,6 +700,15 @@ bignat_quotrem_normalized mwq mwa b s0 = | True -> loop (m -# 1#) s2 }} +-- | QuotRem of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The remainder is returned. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quotrem_word :: MutableWordArray# s -- ^ Quotient -> WordArray# @@ -595,6 +727,13 @@ bignat_quotrem_word mwq wa b s = go (sz -# 1#) 0## s in case mwaWrite# mwq i q s of s' -> go (i -# 1#) r' s' +-- | Quot of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_quot_word :: MutableWordArray# s -- ^ Quotient -> WordArray# @@ -613,6 +752,9 @@ bignat_quot_word mwq wa b s = go (sz -# 1#) 0## s in case mwaWrite# mwq i q s of s' -> go (i -# 1#) r' s' +-- | Remainder of a non-zero BigNat and a non-zero Word +-- +-- The remainder is returned. bignat_rem_word :: WordArray# -> Word# @@ -629,6 +771,14 @@ bignat_rem_word wa b = go (sz -# 1#) 0## in go (i -# 1#) r' +-- | Greatest common divisor (GCD) of two non-zero and non-one BigNat +-- +-- Result GCD is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- The first WordArray# is greater than the second WordArray#. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_gcd :: MutableWordArray# s -> WordArray# @@ -647,13 +797,21 @@ bignat_gcd mwr = go !wmin' = bigNatRem wmax wmin in go wmax' wmin' s +-- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a +-- non-zero/non-one Word# +-- +-- Result GCD is returned bignat_gcd_word :: WordArray# -> Word# -> Word# bignat_gcd_word a b = bignat_gcd_word_word b (bigNatRemWord# a b) --- | This operation doesn't really belongs here, but GMP's one is much faster +-- | Greatest common divisor (GCD) of two Word# +-- +-- Result GCD is returned. +-- +-- This operation doesn't really belongs here, but GMP's one is much faster -- than this simple implementation (basic Euclid algorithm). -- -- Ideally we should make an implementation as fast as GMP's one and put it into @@ -665,6 +823,7 @@ bignat_gcd_word_word bignat_gcd_word_word a 0## = a bignat_gcd_word_word a b = bignat_gcd_word_word b (a `remWord#` b) +-- | Encode (# BigNat mantissa, Int# exponent #) into a Double# bignat_encode_double :: WordArray# -> Int# -> Double# bignat_encode_double wa e0 = go 0.0## e0 0# where @@ -676,6 +835,12 @@ bignat_encode_double wa e0 = go 0.0## e0 0# (e +# WORD_SIZE_IN_BITS#) -- FIXME: we assume that e doesn't overflow... (i +# 1#) +-- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# bignat_powmod_word b0 e0 m = go (naturalFromBigNat# b0) (naturalFromBigNat# e0) (naturalFromWord# 1##) where @@ -693,6 +858,18 @@ bignat_powmod_word b0 e0 m = go (naturalFromBigNat# b0) (naturalFromBigNat# e0) m' = naturalFromWord# m e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" +-- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 +-- +-- Result is to be stored in the MutableWordArray# (which size is equal to the +-- one of m). +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. bignat_powmod :: MutableWordArray# RealWorld -> WordArray# @@ -720,6 +897,12 @@ bignat_powmod r b0 e0 m s = mwaInitCopyShrink# r r' s m' = naturalFromBigNat# m e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" +-- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 bignat_powmod_words :: Word# -> Word# @@ -731,6 +914,13 @@ bignat_powmod_words b e m = m +-- | Return extended GCD of two non-zero integers. +-- +-- I.e. integer_gcde a b returns (g,x,y) so that ax + by = g +-- +-- Input: a and b are non zero. +-- Output: g must be > 0 +-- integer_gcde :: Integer -> Integer @@ -748,6 +938,12 @@ integer_gcde a b = f (# a,integerOne,integerZero #) (# b,integerZero,integerOne !(# q, r #) -> f new (# r , old_s `integerSub` (q `integerMul` s) , old_t `integerSub` (q `integerMul` t) #) +-- | Computes the modular inverse of two non-zero integers. +-- +-- I.e. y = integer_recip_mod x m +-- = x^(-1) `mod` m +-- +-- with 0 < y < abs m integer_recip_mod :: Integer -> Natural @@ -763,6 +959,12 @@ integer_recip_mod x m = -- a `mod` m > 0 because m > 0 | True -> (# | () #) +-- | Computes the modular exponentiation. +-- +-- I.e. y = integer_powmod b e m +-- = b^e `mod` m +-- +-- with 0 <= y < abs m integer_powmod :: Integer -> Natural ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Backend/Selected.hs deleted ===================================== @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Selected backend --- --- We need this module in addition to GHC.Internal.Bignum.Backend to avoid module loops with --- Check backend. -module GHC.Internal.Bignum.Backend.Selected - ( module Backend - ) -where - -#if defined(BIGNUM_NATIVE) -import GHC.Internal.Bignum.Backend.Native as Backend - -#elif defined(BIGNUM_FFI) -import GHC.Internal.Bignum.Backend.FFI as Backend - -#elif defined(BIGNUM_GMP) -import GHC.Internal.Bignum.Backend.GMP as Backend - -#else -#error Undefined BigNum backend. Use a flag to select it (e.g. gmp, native, ffi)` -#endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d603477f4cd5dff83d81d8ecef52e2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d603477f4cd5dff83d81d8ecef52e2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Hadrian: create a ghc-internal .def file per ghc-internal dll
by Marge Bot (＠marge-bot) 29 May '26

29 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d603477f by David Eichmann at 2026-05-29T13:17:12-04:00 Hadrian: create a ghc-internal .def file per ghc-internal dll The .def file generated from rts/win32/libHSghc-internal.def.in contains the name of the ghc-internal dll. The correct dll name differs based on if the dll is inplace/final and if using the Dynamic way. Previously, this was not accounted for and inconsistent dlls names where used. That led to failure when loading dlls at runtime in experiments with windows dynamic linking. - - - - - 4 changed files: - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Rts.hs - rts/win32/libHSghc-internal.def.in Changes: ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -390,7 +390,6 @@ templateRules = do , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1 , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2 ] - templateRule "rts/win32/libHSghc-internal.def" projectVersion templateRule "docs/index.html" $ packageUnitIds Stage1 templateRule "docs/users_guide/ghc_config.py" $ mconcat [ projectVersion ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -9,6 +9,7 @@ import GHC.Toolchain.Target (Target(tgtArchOs)) import Base import Context +import qualified Data.List as List import Expression hiding (way, package, stage) import Oracles.ModuleFiles import Packages @@ -20,6 +21,7 @@ import Utilities import Data.Time.Clock import Rules.Generate (generatedDependencies) import Oracles.Flag +import Way.Type (wayToUnits) -- * Library 'Rules' @@ -203,13 +205,32 @@ extraObjects context | package context == rts = do target <- interpretInContext context getStagedTarget - builddir <- buildPath context - return [ builddir -/- "libHSghc-internal.dll.a" - | archOS_OS (tgtArchOs target) == OSMinGW32 - , Dynamic `wayUnit` way context ] + if not (archOS_OS (tgtArchOs target) == OSMinGW32 + && Dynamic `wayUnit` way context) + then return [] + else do + -- Find the ghc-internal library file name. Note that the + -- ghc-internal's .dll.a file is placed in the RTS build dir and not + -- the ghc-internal build dir as we only use it when building the + -- RTS and not other libraries. + ghcInternalDllName <- takeFileName <$> pkgLibraryFile Context { + stage = stage context, + way = rtsWayToLibraryWay (way context), + iplace = iplace context, + package = ghcInternal + } + + builddir <- buildPath context + return [ builddir -/- ghcInternalDllName <> ".a"] | otherwise = return [] +-- | The rts is compiled in many different ways, but libraries are only built in +-- (non)Dynamic and (non)Profiled ways. This function converts the rts way into +-- compatible library way. +rtsWayToLibraryWay :: Way -> Way +rtsWayToLibraryWay = wayFromUnits . List.intersect [Dynamic, Profiling] . wayToUnits + -- | Return all the object files to be put into the library we're building for -- the given 'Context'. libraryObjects :: Context -> Action [FilePath] ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -13,11 +13,19 @@ rtsRules = priority 3 $ do -- to be linked into the rts dll. forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do let buildPath = root -/- buildDir (rtsContext stage) - buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib + buildPath -/- "libHSghc-internal-*.def" %> buildGhcInternalImportDef + buildPath -/- "libHSghc-internal-*.dll.a" %> buildGhcInternalImportLib + +buildGhcInternalImportDef :: FilePath -> Action () +buildGhcInternalImportDef target = do + templateIn <- readFile' "rts/win32/libHSghc-internal.def.in" + let dllName = takeFileName target -<.> "dll" + templateOut = replace "@GhcInternalDll@" dllName templateIn + writeFile' target templateOut buildGhcInternalImportLib :: FilePath -> Action () buildGhcInternalImportLib target = do - let input = "rts/win32/libHSghc-internal.def" + let input = dropExtensions target <.> "def" -- the .def file output = target -- the .dll.a import lib need [input] runBuilder Dlltool ["-d", input, "-l", output] [input] [output] ===================================== rts/win32/libHSghc-internal.def.in ===================================== @@ -1,4 +1,4 @@ -LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll +LIBRARY @GhcInternalDll@ EXPORTS init_ghc_hs_iface View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d603477f4cd5dff83d81d8ecef52e21… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d603477f4cd5dff83d81d8ecef52e21… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] Trim the continuation in mkDupableContWithDmds
by Magnus (＠MangoIV) 29 May '26

29 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: ede8d11e by mangoiv at 2026-05-29T18:46:15+02:00 Trim the continuation in mkDupableContWithDmds When there are no remaining argument demands, it means the application is bottoming. In this case, we can trim the continuation to avoid the panic that was observed in #27261. See Note [Trimming the continuation for bottoming functions] in GHC.Core.Opt.Simplify.Iteration. This patch was rewritten to avoid pulling in a refactor. The original patch is included in master as 4a645683 - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - + testsuite/tests/simplCore/should_compile/T27261.hs - + testsuite/tests/simplCore/should_compile/T27261_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -24,7 +24,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Reduction @@ -2293,24 +2293,14 @@ rebuildCall :: SimplEnv -> ArgInfo -> SimplCont ---------- Bottoming applications -------------- rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont + -- When we run out of demands, it means that the call is definitely bottom. + -- See (TC2) in Note [Trimming the continuation for bottoming functions] + = rebuild env (argInfoExpr fun rev_args) (mkBottomCont env cont) + -- NOTE(mangoiv): the env passed to mkBottomCont is only relevant for its static part + -- and should not be looked at whatsoever, which is why it should be fine to pass it + -- this way. The reason why we deviate from the original patch is that it was done + -- after a significant refactor we cannot backport. + -- The original patch should be included in `master` as 4a645683ee0bd4421a88cd6ec49b40c6046b041d ---------- Try inlining, if ai_rewrite = TryInlining -------- -- In the TryInlining case we try inlining immediately, before simplifying @@ -3813,6 +3803,41 @@ When we have then we can just duplicate those alts because the A and C cases will disappear immediately. This is more direct than creating join points and inlining them away. See #4930. + +Note [Trimming the continuation for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + f :: Int -> Int -> Int + f x = error "urk" + + foo = f 3 4 + +f's demand signature say "after one arg I return bottom". We can drop +the remaining arguments, thus + + foo = case f 3 of {} + +This trimming can also be done with other continuations: + * case (error "hello") of { ... } + * f (error "Hello") where f is strict + etc + +We implement the trimming in three parts: + +(TC1) In `mkArgInfo`, for a bottoming function, we make a list of `RemainingArgDmds` + with a finite list of elements (in the example above, just one). + + For comparison, note that, for non-bottoming functions, the `RemainingArgDmds` + always finishes with an infinite list of `topDmd`. + +(TC2) In `rebuildCall`, when we run out of `RemainingArgDmds` we discard the + remaining continuation. + + After discarding the continuation, the types might not match, in which case + we leave behind a (case <hole> of {}) wrapper. See the call to `mkBottomCont`. + +(TC3) In `mkDupableContWithDmds`, we similarly discard the continuation when + we run out of `RemainingArgDmds`. -} -------------------- @@ -3856,6 +3881,13 @@ mkDupableContWithDmds env _ cont mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn +mkDupableContWithDmds env dmds cont + -- No more demands => function is definitely bottom + -- => simply trim the continuation + -- c.f. the null-demands case in `rebuildCall` + -- See (TC3) in Note [Trimming the continuation for bottoming functions] + | [] <- dmds = return (emptyFloats env, mkBottomCont env cont) + mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) = do { (floats, cont') <- mkDupableContWithDmds env dmds cont ; return (floats, CastIt { sc_co = optOutCoercion env co opt @@ -3931,7 +3963,7 @@ mkDupableContWithDmds env dmds ; return (floats, ApplyToTy { sc_cont = cont' , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } -mkDupableContWithDmds env dmds +mkDupableContWithDmds env (dmd : cont_dmds) (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) @@ -3939,8 +3971,7 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:cont_dmds) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + do { (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' @@ -3954,7 +3985,6 @@ mkDupableContWithDmds env dmds -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup, sc_cont = cont' , sc_hole_ty = hole_ty }) } - mkDupableContWithDmds env _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) = -- e.g. (case [...hole...] of { pi -> ei }) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils ( SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, + contIsTrivial, contArgs, contIsRhs, mkBottomCont, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -87,6 +87,8 @@ import Control.Monad ( guard, when ) import Data.List ( sortBy ) import Data.Maybe import Data.Graph +import GHC.Core.TyCo.Compare (eqTypeIgnoringMultiplicity) +import GHC.Core.Make (mkWildValBinder) {- ********************************************************************* * * @@ -505,6 +507,20 @@ contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k contIsTrivial _ = False +------------------- +contStop :: SimplCont -> SimplCont +-- ^ Get the 'Stop' at the tail of the continuation +-- +-- Always returns a continuation of form @(Stop ...)@. +contStop stop@(Stop {}) = stop +contStop (CastIt { sc_cont = k }) = contStop k +contStop (StrictBind { sc_cont = k }) = contStop k +contStop (StrictArg { sc_cont = k }) = contStop k +contStop (Select { sc_cont = k }) = contStop k +contStop (ApplyToTy { sc_cont = k }) = contStop k +contStop (ApplyToVal { sc_cont = k }) = contStop k +contStop (TickIt _ k) = contStop k + ------------------- contResultType :: SimplCont -> OutType contResultType (Stop ty _ _) = ty @@ -623,6 +639,40 @@ contEvalContext k = case k of -- Perhaps reconstruct the demand on the scrutinee by looking at field -- and case binder dmds, see addCaseBndrDmd. No priority right now. +------------------- +mkBottomCont ::StaticEnv -> SimplCont -> SimplCont +-- ^ Given a continuation `cont`, return a `cont` /of the same type/, +-- looking like @(case \<hole\> of {})@. +-- +-- This is used when we are going to fill in the @<hole>@ with bottom. +-- See (TC2,3) in Note [Trimming the continuation for bottoming functions] +-- +-- Don't bother to trim, making a @case <hole> of {}@, if we have only +-- an essentially-trivial continuation; e.g. @(<hole> \@ty |> co)@. +mkBottomCont se cont = go cont + where + go k@(Stop {}) = k + go (TickIt t k') = TickIt t (go k') + go k@(CastIt { sc_cont = k' }) = k { sc_cont = go k' } + go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' } + go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k -- Optimisation only + go k | Stop res_ty _ _ <- stop_cont + = if hole_ty `eqTypeIgnoringMultiplicity` res_ty + then stop_cont + else Select { sc_alts = [] + , sc_bndr = mkWildValBinder OneTy hole_ty + , sc_dup = OkToDup + , sc_env = zapSubstEnv se + -- NOTE(mangoiv): we zap the env here because there were + -- some subtle changes in invariants on substitutions. + -- that would require backports of major refactorings. + , sc_cont = stop_cont } + | otherwise = panic "stop_cont is not Stop {}" + where + hole_ty = contHoleType k + stop_cont = contStop k + + ------------------- mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo ===================================== testsuite/tests/simplCore/should_compile/T27261.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-full-laziness -dppr-debug #-} + +module T27261 (foo) where + +import T27261_aux (myError) + +foo :: [String] -> (() -> Int) -> Int +foo cs = + \ k -> ( case bar of + Just str -> let cs2 = case cs of { [] -> cs; _ -> "stack entry" : cs } + in myError cs2 str + Nothing -> \ c -> c () ) + ( \ _ -> k () ) + +bar :: Maybe String +bar = Nothing +{-# NOINLINE bar #-} ===================================== testsuite/tests/simplCore/should_compile/T27261_aux.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE BangPatterns #-} + +module T27261_aux (myError) where + +myError :: [String] -> String -> a +myError !_ _ = undefined +{-# NOINLINE myError #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -541,3 +541,4 @@ test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, [ test('T26681', normal, compile, ['-O']) test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all']) test('T26682', normal, multimod_compile, ['T26682', '-O -v0']) +test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ede8d11e16d63622e68977dfe325b70… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ede8d11e16d63622e68977dfe325b70… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files] Hadrian: disable response files for GHC/Haddock builders on non-Windows
by David Eichmann (＠DavidEichmann) 29 May '26

29 May '26

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files at Glasgow Haskell Compiler / GHC Commits: 52935fea by David Eichmann at 2026-05-29T17:19:55+01:00 Hadrian: disable response files for GHC/Haddock builders on non-Windows This makes debugging build errors easier on non-windows hosts. See issue #27230 - - - - - 2 changed files: - hadrian/src/Builder.hs - hadrian/src/Hadrian/Utilities.hs Changes: ===================================== hadrian/src/Builder.hs ===================================== @@ -346,7 +346,16 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc _ _ -> runGhcWithResponse path buildArgs buildInputs buildOptions + Ghc _ _ -> + -- Use a response file for ghc invocations to avoid issues with command line + -- size limit on Windows (#26637). + -- Note we can't put the buildArgs in a response file, because some flags require + -- empty arguments (such as the -dep-suffix flag), but that isn't supported + -- yet due to #26560. + withResponseFileOnWindows + buildInputs + (escapeArgs buildInputs) + (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions) HsCpp -> captureStdout @@ -386,23 +395,10 @@ runHaddock :: FilePath -- ^ path to @haddock@ -> [String] -> [FilePath] -- ^ input file paths -> Action () -runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do - writeFile' tmp $ escapeArgs fileInputs - cmd [haddockPath] flagArgs ('@' : tmp) - --- | Use a response file for ghc invocations to avoid issues with command line --- size limit on Windows (#26637). -runGhcWithResponse :: FilePath -- ^ Path to ghc - -> [String] -- ^ Arguments passed on the command line - -> [FilePath] -- ^ Input file paths (passed via response file) - -> [CmdOption] - -> Action () -runGhcWithResponse ghcPath buildArgs buildInputs buildOptions = withResponseFile $ \tmp -> do - -- We can't put the buildArgs in a response file, because some flags require - -- empty arguments (such as the -dep-suffix flag), but that isn't supported - -- yet due to #26560. - writeFile' tmp (escapeArgs buildInputs) - cmd [ghcPath] buildArgs ('@' : tmp) buildOptions +runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows + fileInputs + (escapeArgs fileInputs) + (\fileInputs' -> cmd [haddockPath] flagArgs fileInputs') -- TODO: Some builders are required only on certain platforms. For example, -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -14,7 +14,7 @@ module Hadrian.Utilities ( -- * Paths BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, - KeepResponseFiles (..), keepResponseFiles, withResponseFile, + KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows, -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, @@ -49,7 +49,9 @@ import Development.Shake hiding (Normal) import Development.Shake.Classes import Development.Shake.FilePath import System.Environment (lookupEnv) +import System.Info.Extra (isWindows) import System.IO (hClose, openTempFile) +import System.IO.Error (isPermissionError) import qualified Data.ByteString as BS import qualified Control.Exception.Base as IO @@ -57,8 +59,7 @@ import qualified Data.HashMap.Strict as Map import qualified System.Directory.Extra as IO import qualified System.Info.Extra as IO import qualified System.IO as IO -import System.IO.Error (isPermissionError) -import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.Posix as Posix -- | Extract a value from a singleton list, or terminate with an error message -- if the list does not contain exactly one value. @@ -328,6 +329,23 @@ keepResponseFiles = do KeepResponseFiles keep <- userSetting (KeepResponseFiles False) return keep +-- | Run an action either with command arguments direcly or by, on windows, +-- placing those arguments into a response file (initialized to some string). +-- +-- With @--keep-response-files@, the file is left on disk (if used) +withResponseFileOnWindows :: + [String] -- ^ Command arguments + -> String -- ^ Response file content (the command arguments converted to the response file format). + -> ([String] -> Action a) -- ^ Perform an action with the given command arguments or, on windows, the with the + -- response file initialized and the passed argument is in the form ["@reponseFilePath"] + -> Action a +withResponseFileOnWindows commandArgs responseFileContent action = do + if isWindows + then withResponseFile $ \tmp -> do + writeFile' tmp responseFileContent + action ['@' : tmp] + else action commandArgs + -- | Run an action with a response file path. -- -- With @--keep-response-files@, the file is left on disk. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52935feab3cdf20cc7c98f6214c38b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52935feab3cdf20cc7c98f6214c38b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0