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@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@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@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@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/da02b9b49d813c3f7a0199a1a5752d7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da02b9b49d813c3f7a0199a1a5752d7... You're receiving this email because of your account on gitlab.haskell.org.