diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2019-09-19 16:26:52 +0200 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-06-17 16:22:03 -0400 |
| commit | 9f96bc127d6231b5e76bbab442244eb303b08867 (patch) | |
| tree | 3b40983164af5d78e7efe8cdb7e580ba36819f79 | |
| parent | 57db91d8ee501c7cf176c4bb1e2101d3092fd0f6 (diff) | |
| download | haskell-9f96bc127d6231b5e76bbab442244eb303b08867.tar.gz | |
ghc-bignum library
ghc-bignum is a newer package that aims to replace the legacy
integer-simple and integer-gmp packages.
* it supports several backends. In particular GMP is still supported and
most of the code from integer-gmp has been merged in the "gmp"
backend.
* the pure Haskell "native" backend is new and is much faster than the
previous pure Haskell implementation provided by integer-simple
* new backends are easier to write because they only have to provide a
few well defined functions. All the other code is common to all
backends. In particular they all share the efficient small/big number
distinction previously used only in integer-gmp.
* backends can all be tested against the "native" backend with a simple
Cabal flag. Backends are only allowed to differ in performance, their
results should be the same.
* Add `integer-gmp` compat package: provide some pattern synonyms and
function aliases for those in `ghc-bignum`. It is intended to avoid
breaking packages that depend on `integer-gmp` internals.
Update submodules: text, bytestring
Metric Decrease:
Conversions
ManyAlternatives
ManyConstructors
Naperian
T10359
T10547
T10678
T12150
T12227
T12234
T12425
T13035
T13719
T14936
T1969
T4801
T4830
T5237
T5549
T5837
T8766
T9020
parsing001
space_leak_001
T16190
haddock.base
On ARM and i386, T17499 regresses (+6% > 5%).
On x86_64 unregistered, T13701 sometimes regresses (+2.2% > 2%).
Metric Increase:
T17499
T13701
45 files changed, 7111 insertions, 3015 deletions
diff --git a/.gitmodules b/.gitmodules index 79b5622ce9..c44e7335e5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -105,7 +105,7 @@ url = https://gitlab.haskell.org/ghc/libffi-tarballs.git ignore = untracked [submodule "gmp-tarballs"] - path = libraries/integer-gmp/gmp/gmp-tarballs + path = libraries/ghc-bignum/gmp/gmp-tarballs url = https://gitlab.haskell.org/ghc/gmp-tarballs.git [submodule "libraries/exceptions"] path = libraries/exceptions diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index b44038e02c..a5ba52e88e 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -854,7 +854,7 @@ When you compile a simple module that contains Template Haskell splice a = () -$(return []) + $(return []) with the compiler flags ``-fplugin SourcePlugin`` it will give the following output: @@ -865,16 +865,12 @@ output: module A where a = () $(return []) - interface loaded: Prelude - interface loaded: GHC.Float - interface loaded: GHC.Base + typeCheckPlugin (rn): a = () interface loaded: Language.Haskell.TH.Lib.Internal - interface loaded: Language.Haskell.TH.Syntax - interface loaded: GHC.Types meta: return [] - interface loaded: GHC.Integer.Type typeCheckPlugin (rn): - Just a = () + typeCheckPlugin (rn): + Nothing typeCheckPlugin (tc): {$trModule = Module (TrNameS "main"#) (TrNameS "A"#), a = ()} diff --git a/libraries/integer-gmp/.gitignore b/libraries/ghc-bignum/.gitignore index 3f3fc66144..3f3fc66144 100644 --- a/libraries/integer-gmp/.gitignore +++ b/libraries/ghc-bignum/.gitignore diff --git a/libraries/integer-gmp/README.rst b/libraries/ghc-bignum/GMP.rst index e5f19279d9..cfdd31235d 100644 --- a/libraries/integer-gmp/README.rst +++ b/libraries/ghc-bignum/GMP.rst @@ -1,18 +1,18 @@ GMP === -integer-gmp depends on the external GMP library (gmplib.org). The latter -provides a header ("gmp.h") and a library to link with. +ghc-bignum's GMP backend depends on the external GMP library (gmplib.org). The +latter provides a header ("gmp.h") and a library to link with. Linking ------- Sadly we can't just put a ``extra-libraries: gmp`` field in the Cabal file because -``integer-gmp`` is a boot package that is part of GHC's *binary* distribution. +``ghc-bignum`` is a boot package that is part of GHC's *binary* distribution. It means that it won't be rebuilt on each user platform. In particular it can be used in an environment that doesn't provide GMP. -A solution would be to always link GMP statically with ``integer-gmp``, but: +A solution would be to always link GMP statically with ``ghc-bignum``, but: 1. GMP's license is LPGL while GHC's license is BSD @@ -32,7 +32,7 @@ As Cabal can't statically link an external library with a Haskell library, GHC's build system uses a hack: 1. it builds libgmp.a 2. it extracts the objects (.o) from it - 3. it passes these objects as "extra" objects when it links integer-gmp + 3. it passes these objects as "extra" objects when it links ghc-bignum Note that these objects must be built as position independent code (PIC) because they end up being used in statically and dynamically linked code (cf #17799). @@ -45,19 +45,20 @@ GMP is linked: .. code:: + --with-gmp enable GMP backend --with-gmp-includes directory containing gmp.h --with-gmp-libraries directory containing gmp library --with-intree-gmp force using the in-tree GMP --with-gmp-framework-preferred on OSX, prefer the GMP framework to the gmp lib -These options are then used when integer-gmp package is configured: in the +These options are then used when ghc-bignum package is configured: in the .cabal file, we can see the field ``build-type: Configure``, meaning that the -``configure`` script in ``libraries/integer-gmp/`` is executed during the setup +``configure`` script in ``libraries/ghc-bignum/`` is executed during the setup phase of the package. -This script is responsible of creating ``integer-gmp.buildinfo`` (from -``integer-gmp.buildinfo.in``). The fields contained in this file are -merged with the ones already defined in ``integer-gmp.cabal``. +This script is responsible of creating ``ghc-bignum.buildinfo`` (from +``ghc-bignum.buildinfo.in``). The fields contained in this file are +merged with the ones already defined in ``ghc-bignum.cabal``. See https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters. @@ -65,10 +66,10 @@ https://www.haskell.org/cabal/users-guide/developing-packages.html#system-depend Headers ------- -When GMP is statically linked (in-tree build), a user of the integer-gmp package +When GMP is statically linked (in-tree build), a user of the ghc-bignum package can't have access to the "gmp.h" header file. So GHC's build system copies the -``ghc.h`` header from the in-tree build to ``integer-gmp/include/ghc-gmp.h``. As you -can see in ``integer-gmp.buildinfo[.in]``, ``ghc-gmp.h`` is installed as a +``ghc.h`` header from the in-tree build to ``ghc-bignum/include/ghc-gmp.h``. As you +can see in ``ghc-bignum.buildinfo[.in]``, ``ghc-gmp.h`` is installed as a header (``install-includes`` field). While the commit that introduced it (a9a0dd34dcdfb7309f57bda88435acca14ec54d5) @@ -77,4 +78,4 @@ doesn't document it, it's probably to get access to other GMP functions. Note that when in-tree GMP build isn't used, ``ghc-gmp.h`` only contains ``#include <gmp.h>``. Hence it imports the header from the HOST platform, which may not be exactly the same as the one used on the BUILD platform to build the -integer-gmp package. +ghc-bignum package. diff --git a/libraries/ghc-bignum/LICENSE b/libraries/ghc-bignum/LICENSE new file mode 100644 index 0000000000..c282c942ff --- /dev/null +++ b/libraries/ghc-bignum/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2020, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/libraries/ghc-bignum/README.rst b/libraries/ghc-bignum/README.rst new file mode 100644 index 0000000000..83e9fe8546 --- /dev/null +++ b/libraries/ghc-bignum/README.rst @@ -0,0 +1,81 @@ +GHC BIGNUM LIBRARY +================== + +This package contains the implementation of the infinite precision integral +types ("big numbers/bignum"): + +* BigNat: a positive natural represented as an array of Word# in memory +* Natural: a positive natural represented either by a Word# or by a BigNat +* Integer: a signed integer represented either by an Int# or in sign-magnitude + representation where the magnitude is represented by a BigNat + +Natural and Integer have each two representations: + +* a small one: Word# or Int# respectively +* a large one: based on BigNat + +The small representation is used when the number fits in it. We do this because +GHC is very good at optimizing codes which use Word#/Int# representations +(e.g. storing the number in registers instead of in memory). + +Backends +-------- + +Several backends providing the implementation of some BigNat operations are +supported: + +* GMP: based on the `GNU Multiple Precision Arithmetic library + <https://gmplib.org/>`_ library (adapted from the legacy integer-gmp package) + +* Native: a pure Haskell implementation written from scratch by Sylvain Henry. + It replaces the previous pure Haskell implementation provided by the + 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. + +This package has been designed to make the implementation of new backends +relatively easy. Previously you had to implement the whole Integer/Natural +interface, to create a new package, etc. Now everything is well contained and +you only have to implement a small part of the BigNat interface. If you want to +try to implement a new backend, you don't have to implement the whole interface +upfront as you can always use the implementation provided by the Native backend +as a fall back. + + +Avoiding `patError` +------------------- + +ghc-bignum is below `base` package. Hence if we use the natural set of +definitions for functions, e.g.: + + integerXor (IS x) y = ... + integerXor x (IS y) = ... + integerXor ... + +then GHC may not be smart enough (especially when compiling with -O0) +to see that all the cases are handled, and will thus insert calls to +`base:Control.Exception.Base.patError`. But we are below `base` in the +package hierarchy, so this causes link failure! + +We therefore help GHC out, by being more explicit about what all the +cases are: + + integerXor a b = case a of + IS x -> case b of + IS y -> ... + IN y -> ... + ... diff --git a/libraries/integer-gmp/Setup.hs b/libraries/ghc-bignum/Setup.hs index 54f57d6f11..54f57d6f11 100644 --- a/libraries/integer-gmp/Setup.hs +++ b/libraries/ghc-bignum/Setup.hs diff --git a/libraries/integer-gmp/aclocal.m4 b/libraries/ghc-bignum/aclocal.m4 index be248615f5..be248615f5 100644 --- a/libraries/integer-gmp/aclocal.m4 +++ b/libraries/ghc-bignum/aclocal.m4 diff --git a/libraries/integer-gmp/cbits/wrappers.c b/libraries/ghc-bignum/cbits/gmp_wrappers.c index ef1bdead2f..cbcf768391 100644 --- a/libraries/integer-gmp/cbits/wrappers.c +++ b/libraries/ghc-bignum/cbits/gmp_wrappers.c @@ -1,5 +1,5 @@ /* - * `integer-gmp` GMP FFI wrappers + * `ghc-bignum` GMP FFI wrappers * * Copyright (c) 2014, Herbert Valerio Riedel <hvr@gnu.org> * diff --git a/libraries/ghc-bignum/changelog.md b/libraries/ghc-bignum/changelog.md new file mode 100644 index 0000000000..4106aec218 --- /dev/null +++ b/libraries/ghc-bignum/changelog.md @@ -0,0 +1 @@ +# Changelog for `ghc-bignum` package diff --git a/libraries/integer-gmp/config.guess b/libraries/ghc-bignum/config.guess index 79d1317f52..79d1317f52 100755 --- a/libraries/integer-gmp/config.guess +++ b/libraries/ghc-bignum/config.guess diff --git a/libraries/integer-gmp/config.mk.in b/libraries/ghc-bignum/config.mk.in index 2556326b2d..8478314ab1 100644 --- a/libraries/integer-gmp/config.mk.in +++ b/libraries/ghc-bignum/config.mk.in @@ -1,4 +1,4 @@ -# NB: This file lives in the top-level integer-gmp folder, and not in +# NB: This file lives in the top-level ghc-bignum folder, and not in # the gmp subfolder, because of #14972, where we MUST NOT create a # folder named 'gmp' in dist/build/ diff --git a/libraries/integer-gmp/config.sub b/libraries/ghc-bignum/config.sub index f53af5a2da..f53af5a2da 100755 --- a/libraries/integer-gmp/config.sub +++ b/libraries/ghc-bignum/config.sub diff --git a/libraries/ghc-bignum/configure.ac b/libraries/ghc-bignum/configure.ac new file mode 100644 index 0000000000..1c658fdb70 --- /dev/null +++ b/libraries/ghc-bignum/configure.ac @@ -0,0 +1,127 @@ +AC_PREREQ(2.69) +AC_INIT([GHC BigNum library], [1.0], [libraries@haskell.org], [ghc-bignum]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([cbits/gmp_wrappers.c]) + +AC_CANONICAL_TARGET + +AC_PROG_CC +dnl make extensions visible to allow feature-tests to detect them lateron +AC_USE_SYSTEM_EXTENSIONS + + +dnl-------------------------------------------------------------------- +dnl * Deal with arguments telling us gmp is somewhere odd +dnl-------------------------------------------------------------------- + +AC_ARG_WITH([gmp], + [AC_HELP_STRING([--with-gmp], + [Enable GMP backend])], + [GMP_ENABLED=YES], + [GMP_ENABLED=NO]) + +AC_ARG_WITH([gmp-includes], + [AC_HELP_STRING([--with-gmp-includes], + [directory containing gmp.h])], + [GMP_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval"], + [GMP_INCLUDE_DIRS=]) + +AC_ARG_WITH([gmp-libraries], + [AC_HELP_STRING([--with-gmp-libraries], + [directory containing gmp library])], + [GMP_LIB_DIRS=$withval; LDFLAGS="-L$withval"], + [GMP_LIB_DIRS=]) + +AC_ARG_WITH([gmp-framework-preferred], + [AC_HELP_STRING([--with-gmp-framework-preferred], + [on OSX, prefer the GMP framework to the gmp lib])], + [GMP_PREFER_FRAMEWORK=YES], + [GMP_PREFER_FRAMEWORK=NO]) + +AC_ARG_WITH([intree-gmp], + [AC_HELP_STRING([--with-intree-gmp], + [force using the in-tree GMP])], + [GMP_FORCE_INTREE=YES], + [GMP_FORCE_INTREE=NO]) + +if test "$GMP_ENABLED" = "YES" +then + +dnl-------------------------------------------------------------------- +dnl * Detect gmp +dnl-------------------------------------------------------------------- + + HaveLibGmp=NO + GMP_LIBS= + HaveFrameworkGMP=NO + GMP_FRAMEWORK= + HaveSecurePowm=0 + + if test "$GMP_FORCE_INTREE" != "YES" + then + if test "$GMP_PREFER_FRAMEWORK" = "YES" + then + LOOK_FOR_GMP_FRAMEWORK + LOOK_FOR_GMP_LIB + else + LOOK_FOR_GMP_LIB + LOOK_FOR_GMP_FRAMEWORK + fi + fi + + AC_MSG_CHECKING([whether to use in-tree GMP]) + if test "$HaveFrameworkGMP" = "YES" || test "$HaveLibGmp" = "YES" + then + AC_MSG_RESULT([no]) + UseIntreeGmp=0 + AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Cannot find gmp.h])]) + + AC_MSG_CHECKING([GMP version]) + AC_COMPUTE_INT(GhcGmpVerMj, __GNU_MP_VERSION, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION])) + AC_COMPUTE_INT(GhcGmpVerMi, __GNU_MP_VERSION_MINOR, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_MINOR])) + AC_COMPUTE_INT(GhcGmpVerPl, __GNU_MP_VERSION_PATCHLEVEL, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_PATCHLEVEL])) + AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) + + else + AC_MSG_RESULT([yes]) + UseIntreeGmp=1 + HaveSecurePowm=1 + + AC_MSG_CHECKING([GMP version]) + GhcGmpVerMj=6 + GhcGmpVerMi=1 + GhcGmpVerPl=2 + AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) + fi + + +dnl-------------------------------------------------------------------- +dnl * Make sure we got some form of gmp +dnl-------------------------------------------------------------------- + + AC_SUBST(GMP_INCLUDE_DIRS) + AC_SUBST(GMP_LIBS) + AC_SUBST(GMP_LIB_DIRS) + AC_SUBST(GMP_FRAMEWORK) + AC_SUBST(HaveLibGmp) + AC_SUBST(HaveFrameworkGMP) + AC_SUBST(HaveSecurePowm) + AC_SUBST(UseIntreeGmp) + AC_SUBST(GhcGmpVerMj) + AC_SUBST(GhcGmpVerMi) + AC_SUBST(GhcGmpVerPl) + + AC_CONFIG_FILES([ghc-bignum.buildinfo include/HsIntegerGmp.h]) +fi + +AC_CONFIG_FILES([config.mk]) + +dnl-------------------------------------------------------------------- +dnl * Generate output files +dnl-------------------------------------------------------------------- + +AC_OUTPUT diff --git a/libraries/integer-gmp/integer-gmp.buildinfo.in b/libraries/ghc-bignum/ghc-bignum.buildinfo.in index 805a425a19..805a425a19 100644 --- a/libraries/integer-gmp/integer-gmp.buildinfo.in +++ b/libraries/ghc-bignum/ghc-bignum.buildinfo.in diff --git a/libraries/ghc-bignum/ghc-bignum.cabal b/libraries/ghc-bignum/ghc-bignum.cabal new file mode 100644 index 0000000000..3234450b5f --- /dev/null +++ b/libraries/ghc-bignum/ghc-bignum.cabal @@ -0,0 +1,124 @@ +cabal-version: 2.0 +name: ghc-bignum +version: 1.0 +synopsis: GHC BigNum library +license: BSD3 +license-file: LICENSE +author: Sylvain Henry +maintainer: libraries@haskell.org +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new +category: Numeric, Algebra, GHC +build-type: Configure +description: + This package provides the low-level implementation of the standard + 'BigNat', 'Natural' and 'Integer' types. + +extra-source-files: + aclocal.m4 + cbits/gmp_wrappers.c + changelog.md + config.guess + config.sub + configure + configure.ac + config.mk.in + install-sh + ghc-bignum.buildinfo.in + +source-repository head + type: git + location: https://gitlab.haskell.org/ghc/ghc.git + subdir: libraries/ghc-bignum + + +Flag Native + Description: Enable native backend + Manual: True + Default: False + +Flag FFI + Description: Enable FFI backend + Manual: True + Default: False + +Flag GMP + Description: Enable GMP backend + Manual: True + Default: False + +Flag Check + Description: Validate results of the enabled backend against native backend. + Manual: True + Default: False + +library + + -- check that at least one flag is set + if !flag(native) && !flag(gmp) && !flag(ffi) + buildable: False + + -- check that at most one flag is set + if flag(native) && (flag(gmp) || flag(ffi)) + buildable: False + if flag(gmp) && flag(ffi) + buildable: False + + default-language: Haskell2010 + other-extensions: + BangPatterns + CApiFFI + CPP + DeriveDataTypeable + ExplicitForAll + GHCForeignImportPrim + MagicHash + NegativeLiterals + NoImplicitPrelude + StandaloneDeriving + UnboxedTuples + UnliftedFFITypes + ForeignFunctionInterface + + build-depends: + ghc-prim >= 0.5.1.0 && < 0.7 + + hs-source-dirs: src/ + include-dirs: include/ + ghc-options: -Wall + cc-options: -std=c99 -Wall + + -- GHC has wired-in IDs from the ghc-bignum package. Hence the unit-id + -- of the package should not contain the version: i.e. it must be + -- "ghc-bignum" and not "ghc-bignum-1.0". + ghc-options: -this-unit-id ghc-bignum + + include-dirs: include + + if flag(gmp) + cpp-options: -DBIGNUM_GMP + other-modules: + GHC.Num.BigNat.GMP + c-sources: + cbits/gmp_wrappers.c + + if flag(ffi) + cpp-options: -DBIGNUM_FFI + other-modules: + GHC.Num.BigNat.FFI + + if flag(native) + cpp-options: -DBIGNUM_NATIVE + + if flag(check) + cpp-options: -DBIGNUM_CHECK + other-modules: + GHC.Num.BigNat.Check + + + exposed-modules: + GHC.Num.Primitives + GHC.Num.WordArray + GHC.Num.BigNat + GHC.Num.BigNat.Native + GHC.Num.Natural + GHC.Num.Integer diff --git a/libraries/integer-gmp/gmp/ghc-gmp.h b/libraries/ghc-bignum/gmp/ghc-gmp.h index 3fdb398670..3fdb398670 100644 --- a/libraries/integer-gmp/gmp/ghc-gmp.h +++ b/libraries/ghc-bignum/gmp/ghc-gmp.h diff --git a/libraries/integer-gmp/gmp/ghc.mk b/libraries/ghc-bignum/gmp/ghc.mk index 9fb13ecb79..fd2798770e 100644 --- a/libraries/integer-gmp/gmp/ghc.mk +++ b/libraries/ghc-bignum/gmp/ghc.mk @@ -16,8 +16,8 @@ # which causes problems for Debian. ifneq "$(BINDIST)" "YES" -GMP_TARBALL := $(wildcard libraries/integer-gmp/gmp/gmp-tarballs/gmp*.tar.bz2) -GMP_DIR := $(patsubst libraries/integer-gmp/gmp/gmp-tarballs/%-nodoc.tar.bz2,%,$(GMP_TARBALL)) +GMP_TARBALL := $(wildcard libraries/ghc-bignum/gmp/gmp-tarballs/gmp*.tar.bz2) +GMP_DIR := $(patsubst libraries/ghc-bignum/gmp/gmp-tarballs/%-nodoc.tar.bz2,%,$(GMP_TARBALL)) ifeq "$(GMP_TARBALL)" "" $(error "GMP tarball is missing; you may need to run 'git submodule update --init'.") @@ -26,28 +26,28 @@ endif ifneq "$(NO_CLEAN_GMP)" "YES" $(eval $(call clean-target,gmp,,\ - libraries/integer-gmp/include/ghc-gmp.h \ - libraries/integer-gmp/gmp/libgmp.a \ - libraries/integer-gmp/gmp/gmp.h \ - libraries/integer-gmp/gmp/gmpbuild \ - libraries/integer-gmp/gmp/$(GMP_DIR))) + libraries/ghc-bignum/include/ghc-gmp.h \ + libraries/ghc-bignum/gmp/libgmp.a \ + libraries/ghc-bignum/gmp/gmp.h \ + libraries/ghc-bignum/gmp/gmpbuild \ + libraries/ghc-bignum/gmp/$(GMP_DIR))) clean : clean_gmp .PHONY: clean_gmp clean_gmp: - $(call removeTrees,libraries/integer-gmp/gmp/objs) - $(call removeTrees,libraries/integer-gmp/gmp/gmpbuild) + $(call removeTrees,libraries/ghc-bignum/gmp/objs) + $(call removeTrees,libraries/ghc-bignum/gmp/gmpbuild) endif ifeq "$(GMP_PREFER_FRAMEWORK)" "YES" -libraries/integer-gmp_CONFIGURE_OPTS += --with-gmp-framework-preferred +libraries/ghc-bignum_CONFIGURE_OPTS += --with-gmp-framework-preferred endif ifneq "$(CLEANING)" "YES" # Hack. The file config.mk doesn't exist yet after running ./configure in # the toplevel (ghc) directory. To let some toplevel make commands such as # sdist go through, right after ./configure, don't consider this an error. --include libraries/integer-gmp/dist-install/build/config.mk +-include libraries/ghc-bignum/dist-install/build/config.mk endif gmp_CC_OPTS += $(addprefix -I,$(GMP_INCLUDE_DIRS)) @@ -67,7 +67,7 @@ endif # In a bindist, we don't want to know whether /this/ machine has gmp, # but whether the machine the bindist was built on had gmp. ifeq "$(BINDIST)" "YES" -ifeq "$(wildcard libraries/integer-gmp/gmp/libgmp.a)" "" +ifeq "$(wildcard libraries/ghc-bignum/gmp/libgmp.a)" "" HaveLibGmp = YES HaveFrameworkGMP = YES else @@ -89,21 +89,21 @@ libraries/integer-gmp/cbits/wrappers.c: libraries/integer-gmp/include/ghc-gmp.h ifeq "$(UseIntreeGmp)" "YES" # Copy header from in-tree build (gmp.h => ghc-gmp.h) -libraries/integer-gmp/include/ghc-gmp.h: libraries/integer-gmp/gmp/gmp.h +libraries/ghc-bignum/include/ghc-gmp.h: libraries/ghc-bignum/gmp/gmp.h $(CP) $< $@ # Link in-tree GMP objects -libraries/integer-gmp_dist-install_EXTRA_OBJS += libraries/integer-gmp/gmp/objs/*.o +libraries/ghc-bignum_dist-install_EXTRA_OBJS += libraries/ghc-bignum/gmp/objs/*.o else # Copy header from source tree -libraries/integer-gmp/include/ghc-gmp.h: libraries/integer-gmp/gmp/ghc-gmp.h +libraries/ghc-bignum/include/ghc-gmp.h: libraries/ghc-bignum/gmp/ghc-gmp.h $(CP) $< $@ endif -libraries/integer-gmp_dist-install_EXTRA_CC_OPTS += $(gmp_CC_OPTS) +libraries/ghc-bignum_dist-install_EXTRA_CC_OPTS += $(gmp_CC_OPTS) ifneq "$(CLEANING)" "YES" # When running `make clean` before `./configure`, CC_STAGE1 is undefined. @@ -115,25 +115,25 @@ else CCX = $(CC_STAGE1) endif -libraries/integer-gmp/gmp/libgmp.a libraries/integer-gmp/gmp/gmp.h: - $(RM) -rf libraries/integer-gmp/gmp/$(GMP_DIR) libraries/integer-gmp/gmp/gmpbuild libraries/integer-gmp/gmp/objs - cat $(GMP_TARBALL) | $(BZIP2_CMD) -d | { cd libraries/integer-gmp/gmp && $(TAR_CMD) -xf - ; } - mv libraries/integer-gmp/gmp/$(GMP_DIR) libraries/integer-gmp/gmp/gmpbuild - cd libraries/integer-gmp/gmp && $(PATCH_CMD) -p0 < gmpsrc.patch - chmod +x libraries/integer-gmp/gmp/ln +libraries/ghc-bignum/gmp/libgmp.a libraries/ghc-bignum/gmp/gmp.h: + $(RM) -rf libraries/ghc-bignum/gmp/$(GMP_DIR) libraries/ghc-bignum/gmp/gmpbuild libraries/ghc-bignum/gmp/objs + cat $(GMP_TARBALL) | $(BZIP2_CMD) -d | { cd libraries/ghc-bignum/gmp && $(TAR_CMD) -xf - ; } + mv libraries/ghc-bignum/gmp/$(GMP_DIR) libraries/ghc-bignum/gmp/gmpbuild + cd libraries/ghc-bignum/gmp && $(PATCH_CMD) -p0 < gmpsrc.patch + chmod +x libraries/ghc-bignum/gmp/ln # Note: We must pass `TARGETPLATFORM` to the `--host` argument of GMP's # `./configure`, not `HOSTPLATFORM`: the 'host' on which GMP will # run is the 'target' platform of the compiler we're building. - cd libraries/integer-gmp/gmp/gmpbuild; \ + cd libraries/ghc-bignum/gmp/gmpbuild; \ CC=$(CCX) CXX=$(CCX) NM=$(NM) AR=$(AR_STAGE1) ./configure \ --enable-shared=no --with-pic=yes \ --host=$(TARGETPLATFORM) --build=$(BUILDPLATFORM) - $(MAKE) -C libraries/integer-gmp/gmp/gmpbuild MAKEFLAGS= - $(CP) libraries/integer-gmp/gmp/gmpbuild/gmp.h libraries/integer-gmp/gmp/ - $(CP) libraries/integer-gmp/gmp/gmpbuild/.libs/libgmp.a libraries/integer-gmp/gmp/ - $(MKDIRHIER) libraries/integer-gmp/gmp/objs - cd libraries/integer-gmp/gmp/objs && $(AR_STAGE1) x ../libgmp.a - $(RANLIB_CMD) libraries/integer-gmp/gmp/libgmp.a + $(MAKE) -C libraries/ghc-bignum/gmp/gmpbuild MAKEFLAGS= + $(CP) libraries/ghc-bignum/gmp/gmpbuild/gmp.h libraries/ghc-bignum/gmp/ + $(CP) libraries/ghc-bignum/gmp/gmpbuild/.libs/libgmp.a libraries/ghc-bignum/gmp/ + $(MKDIRHIER) libraries/ghc-bignum/gmp/objs + cd libraries/ghc-bignum/gmp/objs && $(AR_STAGE1) x ../libgmp.a + $(RANLIB_CMD) libraries/ghc-bignum/gmp/libgmp.a endif # CLEANING diff --git a/libraries/integer-gmp/gmp/gmp-tarballs b/libraries/ghc-bignum/gmp/gmp-tarballs -Subproject ff5a56f169a8c6564f469008b21ad8ec0bc9d49 +Subproject ff5a56f169a8c6564f469008b21ad8ec0bc9d49 diff --git a/libraries/integer-gmp/gmp/gmpsrc.patch b/libraries/ghc-bignum/gmp/gmpsrc.patch index 067f58e902..067f58e902 100644 --- a/libraries/integer-gmp/gmp/gmpsrc.patch +++ b/libraries/ghc-bignum/gmp/gmpsrc.patch diff --git a/libraries/integer-gmp/gmp/ln b/libraries/ghc-bignum/gmp/ln index a3a297ccdb..a3a297ccdb 100755 --- a/libraries/integer-gmp/gmp/ln +++ b/libraries/ghc-bignum/gmp/ln diff --git a/libraries/integer-gmp/include/HsIntegerGmp.h.in b/libraries/ghc-bignum/include/HsIntegerGmp.h.in index 08ff8dff5f..063817cc15 100644 --- a/libraries/integer-gmp/include/HsIntegerGmp.h.in +++ b/libraries/ghc-bignum/include/HsIntegerGmp.h.in @@ -1,6 +1,6 @@ #pragma once -/* Whether GMP is embedded into integer-gmp */ +/* Whether GMP is embedded into ghc-bignum */ #define GHC_GMP_INTREE @UseIntreeGmp@ /* The following values denote the GMP version used during GHC build-time */ diff --git a/libraries/ghc-bignum/include/WordSize.h b/libraries/ghc-bignum/include/WordSize.h new file mode 100644 index 0000000000..cd52f93764 --- /dev/null +++ b/libraries/ghc-bignum/include/WordSize.h @@ -0,0 +1,32 @@ +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 64 + +# define WORD_SIZE_IN_BYTES 8 +# define WORD_SIZE_BYTES_SHIFT 3 +# define WORD_SIZE_BYTES_MASK 0b111 +# define WORD_SIZE_BITS_SHIFT 6 +# define WORD_SIZE_BITS_MASK 0b111111 +# define WORD_MAXBOUND 0xffffffffffffffff +# define INT_MINBOUND -0x8000000000000000 +# define INT_MAXBOUND 0x7fffffffffffffff +# define ABS_INT_MINBOUND 0x8000000000000000 +# define SQRT_INT_MAXBOUND 0xb504f333 + +#elif WORD_SIZE_IN_BITS == 32 + +# define WORD_SIZE_IN_BYTES 4 +# define WORD_SIZE_BYTES_SHIFT 2 +# define WORD_SIZE_BYTES_MASK 0b11 +# define WORD_SIZE_BITS_SHIFT 5 +# define WORD_SIZE_BITS_MASK 0b11111 +# define WORD_MAXBOUND 0xffffffff +# define INT_MINBOUND -0x80000000 +# define INT_MAXBOUND 0x7fffffff +# define ABS_INT_MINBOUND 0x80000000 +# define SQRT_INT_MAXBOUND 0xb504 + +#else +# error unsupported WORD_SIZE_IN_BITS config +#endif + diff --git a/libraries/integer-gmp/install-sh b/libraries/ghc-bignum/install-sh index 377bb8687f..377bb8687f 100755 --- a/libraries/integer-gmp/install-sh +++ b/libraries/ghc-bignum/install-sh diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs new file mode 100644 index 0000000000..5d0a9919f5 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs @@ -0,0 +1,1509 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE BinaryLiterals #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +-- | Multi-precision natural +module GHC.Num.BigNat where + +#include "MachDeps.h" +#include "WordSize.h" + +import GHC.Prim +import GHC.Types +import GHC.Classes +import GHC.Magic +import GHC.Num.Primitives +import GHC.Num.WordArray + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +#if defined(BIGNUM_CHECK) +import GHC.Num.BigNat.Check + +#elif defined(BIGNUM_NATIVE) +import GHC.Num.BigNat.Native + +#elif defined(BIGNUM_FFI) +import GHC.Num.BigNat.FFI + +#elif defined(BIGNUM_GMP) +import GHC.Num.BigNat.GMP + +#else +#error Undefined BigNat backend. Use a flag to select it (e.g. gmp, native, ffi)` +#endif + +default () + +-- | A BigNat +-- +-- Represented as an array of limbs (Word#) stored in little-endian order (Word# +-- themselves use machine order). +-- +-- Invariant (canonical representation): higher Word# is non-zero. +-- As a consequence, zero is represented with a WordArray# whose size is 0. +type BigNat = WordArray# -- we use a type-alias to make Integer/Natural easier to wire-in + +-- | Check that the BigNat is valid +bigNatCheck# :: BigNat -> Bool# +bigNatCheck# bn + | 0# <- bigNatSize# bn = 1# + | 0## <- bigNatIndex# bn (bigNatSize# bn -# 1#) = 0# + | True = 1# + +-- | Check that the BigNat is valid +bigNatCheck :: BigNat -> Bool +bigNatCheck bn = isTrue# (bigNatCheck# bn) + +-- | Number of words in the BigNat +bigNatSize :: BigNat -> Word +bigNatSize bn = W# (int2Word# (bigNatSize# bn)) + +-- | Number of words in the BigNat +bigNatSize# :: BigNat -> Int# +bigNatSize# ba = wordArraySize# ba + +-- Note [Why Void#?] +-- ~~~~~~~~~~~~~~~~~ +-- +-- We can't have top-level BigNat for now because they are unlifted ByteArray# +-- (see #17521). So we use functions that take an empty argument Void# that +-- will be discarded at compile time. + +data BigNatW = BigNatW BigNat + +{-# NOINLINE bigNatZeroW #-} +bigNatZeroW :: BigNatW +bigNatZeroW = BigNatW (withNewWordArray# 0# (\_ s -> s)) + +{-# NOINLINE bigNatOneW #-} +bigNatOneW :: BigNatW +bigNatOneW = BigNatW (bigNatFromWord# 1##) + +-- | BigNat Zero +bigNatZero :: Void# -> BigNat -- cf Note [Why Void#?] +bigNatZero _ = case bigNatZeroW of + BigNatW w -> w + +-- | BigNat one +bigNatOne :: Void# -> BigNat -- cf Note [Why Void#?] +bigNatOne _ = case bigNatOneW of + BigNatW w -> w + +-- | Indicate if a bigNat is zero +bigNatIsZero :: BigNat -> Bool +bigNatIsZero bn = isTrue# (bigNatIsZero# bn) + +-- | Indicate if a bigNat is zero +bigNatIsZero# :: BigNat -> Bool# +bigNatIsZero# ba = wordArraySize# ba ==# 0# + +-- | Indicate if a bigNat is one +bigNatIsOne :: BigNat -> Bool +bigNatIsOne bn = isTrue# (bigNatIsOne# bn) + +-- | Indicate if a bigNat is one +bigNatIsOne# :: BigNat -> Bool# +bigNatIsOne# ba = + wordArraySize# ba ==# 1# + &&# indexWordArray# ba 0# `eqWord#` 1## + +-- | Indicate if a bigNat is two +bigNatIsTwo :: BigNat -> Bool +bigNatIsTwo bn = isTrue# (bigNatIsTwo# bn) + +-- | Indicate if a bigNat is two +bigNatIsTwo# :: BigNat -> Bool# +bigNatIsTwo# ba = + wordArraySize# ba ==# 1# + &&# indexWordArray# ba 0# `eqWord#` 2## + +-- | Indicate if the value is a power of two and which one +bigNatIsPowerOf2# :: BigNat -> (# () | Word# #) +bigNatIsPowerOf2# a + | bigNatIsZero a = (# () | #) + | True = case wordIsPowerOf2# msw of + (# () | #) -> (# () | #) + (# | c #) -> case checkAllZeroes (imax -# 1#) of + 0# -> (# () | #) + _ -> (# | c `plusWord#` + (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #) + where + msw = bigNatIndex# a imax + sz = bigNatSize# a + imax = sz -# 1# + checkAllZeroes i + | isTrue# (i <# 0#) = 1# + | True = case bigNatIndex# a i of + 0## -> checkAllZeroes (i -# 1#) + _ -> 0# + +-- | Return the Word# at the given index +bigNatIndex# :: BigNat -> Int# -> Word# +bigNatIndex# x i = indexWordArray# x i + +-- | Return the Word# at the given index +bigNatIndex :: BigNat -> Int# -> Word +bigNatIndex bn i = W# (bigNatIndex# bn i) + +------------------------------------------------- +-- Conversion +------------------------------------------------- + +-- | Create a BigNat from a Word +bigNatFromWord :: Word -> BigNat +bigNatFromWord (W# w) = bigNatFromWord# w + +-- | Create a BigNat from a Word +bigNatFromWord# :: Word# -> BigNat +bigNatFromWord# 0## = bigNatZero void# +bigNatFromWord# w = wordArrayFromWord# w + +-- | Convert a list of non-zero Words (most-significant first) into a BigNat +bigNatFromWordList :: [Word] -> BigNat +bigNatFromWordList (W# 0##:xs) = bigNatFromWordList xs +bigNatFromWordList xs = bigNatFromWordListUnsafe xs + +-- | Convert a list of non-zero Words (most-significant first) into a BigNat +bigNatFromWordList# :: [Word] -> WordArray# +{-# NOINLINE bigNatFromWordList# #-} +bigNatFromWordList# xs = bigNatFromWordList xs + +-- | Return the absolute value of the Int# in a BigNat +bigNatFromAbsInt# :: Int# -> BigNat +bigNatFromAbsInt# i = bigNatFromWord# (wordFromAbsInt# i) + +-- | Convert a list of non-zero Words (most-significant first) into a BigNat. +-- Don't remove most-significant zero words +bigNatFromWordListUnsafe :: [Word] -> BigNat +bigNatFromWordListUnsafe [] = bigNatZero void# +bigNatFromWordListUnsafe xs = + let + length i [] = i + length i (_:ys) = length (i +# 1#) ys + !lxs = length 0# xs + writeWordList _mwa _i [] s = s + writeWordList mwa i (W# w:ws) s = + case mwaWrite# mwa i w s of + s1 -> writeWordList mwa (i -# 1#) ws s1 + in withNewWordArray# lxs \mwa -> + writeWordList mwa (lxs -# 1#) xs + +-- | Convert a BigNat into a list of non-zero Words (most-significant first) +bigNatToWordList :: BigNat -> [Word] +bigNatToWordList bn = go (bigNatSize# bn) + where + go 0# = [] + go n = bigNatIndex bn (n -# 1#) : go (n -# 1#) + + +-- | Convert two Word# (most-significant first) into a BigNat +bigNatFromWord2# :: Word# -> Word# -> BigNat +bigNatFromWord2# 0## 0## = bigNatZero void# +bigNatFromWord2# 0## n = bigNatFromWord# n +bigNatFromWord2# w1 w2 = wordArrayFromWord2# w1 w2 + +-- | Convert a BigNat into a Word# +bigNatToWord# :: BigNat -> Word# +bigNatToWord# a + | bigNatIsZero a = 0## + | True = bigNatIndex# a 0# + +-- | Convert a BigNat into a Word# if it fits +bigNatToWordMaybe# :: BigNat -> (# Word# | () #) +bigNatToWordMaybe# a + | bigNatIsZero a = (# 0## | #) + | isTrue# (bigNatSize# a ># 1#) = (# | () #) + | True = (# bigNatIndex# a 0# | #) + +-- | Convert a BigNat into a Word +bigNatToWord :: BigNat -> Word +bigNatToWord bn = W# (bigNatToWord# bn) + +-- | Convert a BigNat into a Int# +bigNatToInt# :: BigNat -> Int# +bigNatToInt# a + | bigNatIsZero a = 0# + | True = indexIntArray# a 0# + +-- | Convert a BigNat into a Int +bigNatToInt :: BigNat -> Int +bigNatToInt bn = I# (bigNatToInt# bn) + +#if WORD_SIZE_IN_BITS == 32 + +-- | Convert a Word64# into a BigNat on 32-bit architectures +bigNatFromWord64# :: Word64# -> BigNat +bigNatFromWord64# w64 = bigNatFromWord2# wh# wl# + where + wh# = word64ToWord# (uncheckedShiftRL64# w64 32#) + wl# = word64ToWord# w64 + +-- | Convert a BigNat into a Word64# on 32-bit architectures +bigNatToWord64# :: BigNat -> Word64# +bigNatToWord64# b + | bigNatIsZero b = wordToWord64# 0## + | wl <- wordToWord64# (bigNatToWord# b) + = if isTrue# (bigNatSize# b ># 1#) + then + let wh = wordToWord64# (bigNatIndex# b 1#) + in uncheckedShiftL64# wh 32# `or64#` wl + else wl + +#endif + +-- | Encode (# BigNat mantissa, Int# exponent #) into a Double# +bigNatEncodeDouble# :: BigNat -> Int# -> Double# +bigNatEncodeDouble# a e + | bigNatIsZero a + = word2Double# 0## -- FIXME: isn't it NaN on 0# exponent? + + | True + = inline bignat_encode_double a e + +------------------------------------------------- +-- Predicates +------------------------------------------------- + +-- | Test if a BigNat is greater than a Word +bigNatGtWord# :: BigNat -> Word# -> Bool# +bigNatGtWord# bn w = + notB# (bigNatIsZero# bn) + &&# ( bigNatSize# bn ># 1# + ||# bigNatIndex# bn 0# `gtWord#` w + ) + +-- | Test if a BigNat is equal to a Word +bigNatEqWord# :: BigNat -> Word# -> Bool# +bigNatEqWord# bn w + | 0## <- w + = bigNatIsZero# bn + + | isTrue# (bigNatSize# bn ==# 1#) + = bigNatIndex# bn 0# `eqWord#` w + + | True + = 0# + +-- | Test if a BigNat is greater than a Word +bigNatGtWord :: BigNat -> Word -> Bool +bigNatGtWord bn (W# w) = isTrue# (bigNatGtWord# bn w) + +-- | Test if a BigNat is lower than or equal to a Word +bigNatLeWord# :: BigNat -> Word# -> Bool# +bigNatLeWord# bn w = notB# (bigNatGtWord# bn w) + +-- | Test if a BigNat is lower than or equal to a Word +bigNatLeWord :: BigNat -> Word -> Bool +bigNatLeWord bn (W# w) = isTrue# (bigNatLeWord# bn w) + +-- | Equality test for BigNat +bigNatEq# :: BigNat -> BigNat -> Bool# +bigNatEq# wa wb + | isTrue# (wordArraySize# wa /=# wordArraySize# wb) = 0# + | isTrue# (wordArraySize# wa ==# 0#) = 1# + | True = inline bignat_compare wa wb ==# 0# + +-- | Equality test for BigNat +bigNatEq :: BigNat -> BigNat -> Bool +bigNatEq a b = isTrue# (bigNatEq# a b) + +-- | Inequality test for BigNat +bigNatNe# :: BigNat -> BigNat -> Bool# +bigNatNe# a b = notB# (bigNatEq# a b) + +-- | Equality test for BigNat +bigNatNe :: BigNat -> BigNat -> Bool +bigNatNe a b = isTrue# (bigNatNe# a b) + +-- | Compare a BigNat and a Word# +bigNatCompareWord# :: BigNat -> Word# -> Ordering +bigNatCompareWord# a b + | bigNatIsZero a = cmpW# 0## b + | isTrue# (wordArraySize# a ># 1#) = GT + | True + = cmpW# (indexWordArray# a 1#) b + +-- | Compare a BigNat and a Word +bigNatCompareWord :: BigNat -> Word -> Ordering +bigNatCompareWord a (W# b) = bigNatCompareWord# a b + +-- | Compare two BigNat +bigNatCompare :: BigNat -> BigNat -> Ordering +bigNatCompare a b = + let + szA = wordArraySize# a + szB = wordArraySize# b + in if + | isTrue# (szA ># szB) -> GT + | isTrue# (szA <# szB) -> LT + | isTrue# (szA ==# 0#) -> EQ + | True -> compareInt# (inline bignat_compare a b) 0# + + +-- | Predicate: a < b +bigNatLt :: BigNat -> BigNat -> Bool +bigNatLt a b = bigNatCompare a b == LT + +------------------------------------------------- +-- Addition +------------------------------------------------- + +-- | Add a bigNat and a Word# +bigNatAddWord# :: BigNat -> Word# -> BigNat +bigNatAddWord# a b + | 0## <- b + = a + + | bigNatIsZero a + = bigNatFromWord# b + + | True + = withNewWordArrayTrimed# (wordArraySize# a +# 1#) \mwa s -> + inline bignat_add_word mwa a b s + +-- | Add a bigNat and a Word +bigNatAddWord :: BigNat -> Word -> BigNat +bigNatAddWord a (W# b) = bigNatAddWord# a b + +-- | Add two bigNats +bigNatAdd :: BigNat -> BigNat -> BigNat +bigNatAdd a b + | bigNatIsZero a = b + | bigNatIsZero b = a + | True = + let + !szA = wordArraySize# a + !szB = wordArraySize# b + !szMax = maxI# szA szB + !sz = szMax +# 1# -- for the potential carry + in withNewWordArrayTrimed# sz \mwa s -> + inline bignat_add mwa a b s + +------------------------------------------------- +-- Multiplication +------------------------------------------------- + +-- | Multiply a BigNat by a Word# +bigNatMulWord# :: BigNat -> Word# -> BigNat +bigNatMulWord# a w + | 0## <- w = bigNatZero void# + | 1## <- w = a + | bigNatIsZero a = bigNatZero void# + | bigNatIsOne a = bigNatFromWord# w + | isTrue# (bigNatSize# a ==# 1#) + = case timesWord2# (bigNatIndex# a 0#) w of + (# h, l #) -> bigNatFromWord2# h l + | True = withNewWordArrayTrimed# (bigNatSize# a +# 1#) \mwa s -> + inline bignat_mul_word mwa a w s + +-- | Multiply a BigNAt by a Word +bigNatMulWord :: BigNat -> Word -> BigNat +bigNatMulWord a (W# w) = bigNatMulWord# a w + +-- | Square a BigNat +bigNatSqr :: BigNat -> BigNat +bigNatSqr a = bigNatMul a a + -- This can be replaced by a backend primitive in the future (e.g. to use + -- GMP's mpn_sqr) + +-- | Multiplication (classical algorithm) +bigNatMul :: BigNat -> BigNat -> BigNat +bigNatMul a b + | bigNatSize b > bigNatSize a = bigNatMul b a -- optimize loops + | bigNatIsZero a = a + | bigNatIsZero b = b + | bigNatIsOne a = b + | bigNatIsOne b = a + | True = + let + !szA = wordArraySize# a + !szB = wordArraySize# b + !sz = szA +# szB + in withNewWordArrayTrimed# sz \mwa s-> + inline bignat_mul mwa a b s + + +------------------------------------------------- +-- Subtraction +------------------------------------------------- + +-- | Subtract a Word# from a BigNat +-- +-- The BigNat must be bigger than the Word#. +bigNatSubWordUnsafe# :: BigNat -> Word# -> BigNat +bigNatSubWordUnsafe# x y + | 0## <- y = x + | True = withNewWordArrayTrimed# sz \mwa -> go mwa y 0# + where + !sz = wordArraySize# x + + go mwa carry i s + | isTrue# (i >=# sz) + = s + + | 0## <- carry + = mwaArrayCopy# mwa i x i (sz -# i) s + + | True + = case subWordC# (indexWordArray# x i) carry of + (# l, c #) -> case mwaWrite# mwa i l s of + s1 -> go mwa (int2Word# c) (i +# 1#) s1 + +-- | Subtract a Word# from a BigNat +-- +-- The BigNat must be bigger than the Word#. +bigNatSubWordUnsafe :: BigNat -> Word -> BigNat +bigNatSubWordUnsafe x (W# y) = bigNatSubWordUnsafe# x y + +-- | Subtract a Word# from a BigNat +bigNatSubWord# :: BigNat -> Word# -> (# () | BigNat #) +bigNatSubWord# a b + | 0## <- b = (# | a #) + | bigNatIsZero a = (# () | #) + | True + = withNewWordArrayTrimedMaybe# (bigNatSize# a) \mwa s -> + inline bignat_sub_word mwa a b s + + +-- | Subtract two BigNat (don't check if a >= b) +bigNatSubUnsafe :: BigNat -> BigNat -> BigNat +bigNatSubUnsafe a b + | bigNatIsZero b = a + | True = + let szA = wordArraySize# a + in withNewWordArrayTrimed# szA \mwa s-> + case inline bignat_sub mwa a b s of + (# s', 0# #) -> s' + (# s', _ #) -> case underflow of _ -> s' + +-- | Subtract two BigNat +bigNatSub :: BigNat -> BigNat -> (# () | BigNat #) +bigNatSub a b + | bigNatIsZero b = (# | a #) + | isTrue# (bigNatSize# a <# bigNatSize# b) + = (# () | #) + + | True + = withNewWordArrayTrimedMaybe# (bigNatSize# a) \mwa s -> + inline bignat_sub mwa a b s + + +------------------------------------------------- +-- Division +------------------------------------------------- + +-- | Divide a BigNat by a Word, return the quotient +-- +-- Require: +-- b /= 0 +bigNatQuotWord# :: BigNat -> Word# -> BigNat +bigNatQuotWord# a b + | 1## <- b = a + | 0## <- b = case divByZero of _ -> bigNatZero void# + | True = + let + sz = wordArraySize# a + in withNewWordArrayTrimed# sz \mwq s -> + inline bignat_quot_word mwq a b s + +-- | Divide a BigNat by a Word, return the quotient +-- +-- Require: +-- b /= 0 +bigNatQuotWord :: BigNat -> Word -> BigNat +bigNatQuotWord a (W# b) = bigNatQuotWord# a b + +-- | Divide a BigNat by a Word, return the remainder +-- +-- Require: +-- b /= 0 +bigNatRemWord# :: BigNat -> Word# -> Word# +bigNatRemWord# a b + | 0## <- b = 1## `remWord#` 0## + | 1## <- b = 0## + | bigNatIsZero a = 0## + | True = inline bignat_rem_word a b + +-- | Divide a BigNat by a Word, return the remainder +-- +-- Require: +-- b /= 0 +bigNatRemWord :: BigNat -> Word -> Word +bigNatRemWord a (W# b) = W# (bigNatRemWord# a b) + +-- | QuotRem a BigNat by a Word +-- +-- Require: +-- b /= 0 +bigNatQuotRemWord# :: BigNat -> Word# -> (# BigNat, Word# #) +bigNatQuotRemWord# a b + | 0## <- b = case divByZero of _ -> (# bigNatZero void#, 0## #) + | 1## <- b = (# a, 0## #) + | isTrue# (bigNatSize# a ==# 1#) + , a0 <- indexWordArray# a 0# + = case compareWord# a0 b of + LT -> (# bigNatZero void#, a0 #) + EQ -> (# bigNatOne void#, 0## #) + GT -> case quotRemWord# a0 b of + (# q, r #) -> (# bigNatFromWord# q, r #) + | True = + let + sz = wordArraySize# a + io s = + case newWordArray# sz s of { (# s1, mwq #) -> + case inline bignat_quotrem_word mwq a b s1 of { (# s2, r #) -> + case mwaTrimZeroes# mwq s2 of { s3 -> + case unsafeFreezeByteArray# mwq s3 of { (# s4, wq #) -> + (# s4, (# wq, r #) #) + }}}} + in case runRW# io of + (# _, (# wq,r #) #) -> (# wq, r #) + + +-- | BigNat division returning (quotient,remainder) +bigNatQuotRem# :: BigNat -> BigNat -> (# BigNat,BigNat #) +bigNatQuotRem# a b + | bigNatIsZero b = case divByZero of _ -> (# bigNatZero void#, bigNatZero void# #) + | bigNatIsZero a = (# bigNatZero void#, bigNatZero void# #) + | bigNatIsOne b = (# a , bigNatZero void# #) + | LT <- cmp = (# bigNatZero void#, a #) + | EQ <- cmp = (# bigNatOne void#, bigNatZero void# #) + | isTrue# (szB ==# 1#) = case bigNatQuotRemWord# a (bigNatIndex# b 0#) of + (# q, r #) -> (# q, bigNatFromWord# r #) + + | True = withNewWordArray2Trimed# szQ szR \mwq mwr s -> + inline bignat_quotrem mwq mwr a b s + where + cmp = bigNatCompare a b + szA = wordArraySize# a + szB = wordArraySize# b + szQ = 1# +# szA -# szB + szR = szB + + +-- | BigNat division returning quotient +bigNatQuot :: BigNat -> BigNat -> BigNat +bigNatQuot a b + | bigNatIsZero b = case divByZero of _ -> bigNatZero void# + | bigNatIsZero a = bigNatZero void# + | bigNatIsOne b = a + | LT <- cmp = bigNatZero void# + | EQ <- cmp = bigNatOne void# + | isTrue# (szB ==# 1#) = bigNatQuotWord# a (bigNatIndex# b 0#) + | True = withNewWordArrayTrimed# szQ \mwq s -> + inline bignat_quot mwq a b s + where + cmp = bigNatCompare a b + szA = wordArraySize# a + szB = wordArraySize# b + szQ = 1# +# szA -# szB + +-- | BigNat division returning remainder +bigNatRem :: BigNat -> BigNat -> BigNat +bigNatRem a b + | bigNatIsZero b = case divByZero of _ -> bigNatZero void# + | bigNatIsZero a = bigNatZero void# + | bigNatIsOne b = bigNatZero void# + | LT <- cmp = a + | EQ <- cmp = bigNatZero void# + | isTrue# (szB ==# 1#) = case bigNatRemWord# a (bigNatIndex# b 0#) of + r -> bigNatFromWord# r + | True = withNewWordArrayTrimed# szR \mwr s -> + inline bignat_rem mwr a b s + where + cmp = bigNatCompare a b + szB = wordArraySize# b + szR = szB + +------------------------------------------------- +-- GCD / LCM +------------------------------------------------- + +-- Word#/Int# GCDs shouldn't be here in BigNat. However GMP provides a very fast +-- implementation so we keep this here at least until we get a native Haskell +-- implementation as fast as GMP's one. Note that these functions are used in +-- `base` (e.g. in GHC.Real) + +-- | Greatest common divisor between two Word# +gcdWord# :: Word# -> Word# -> Word# +gcdWord# = bignat_gcd_word_word + +-- | Greatest common divisor between two Word +gcdWord :: Word -> Word -> Word +gcdWord (W# x) (W# y) = W# (gcdWord# x y) + +-- | Greatest common divisor between two Int# +-- +-- __Warning__: result may become negative if (at least) one argument +-- is 'minBound' +gcdInt# :: Int# -> Int# -> Int# +gcdInt# x y = word2Int# (gcdWord# (wordFromAbsInt# x) (wordFromAbsInt# y)) + +-- | Greatest common divisor between two Int +-- +-- __Warning__: result may become negative if (at least) one argument +-- is 'minBound' +gcdInt :: Int -> Int -> Int +gcdInt (I# x) (I# y) = I# (gcdInt# x y) + +-- | Greatest common divisor +bigNatGcd :: BigNat -> BigNat -> BigNat +bigNatGcd a b + | bigNatIsZero a = b + | bigNatIsZero b = a + | bigNatIsOne a = a + | bigNatIsOne b = b + | True + = case (# bigNatSize# a, bigNatSize# b #) of + (# 1#, 1# #) -> bigNatFromWord# (gcdWord# (bigNatIndex# a 0#) + (bigNatIndex# b 0#)) + (# 1#, _ #) -> bigNatFromWord# (bigNatGcdWord# b (bigNatIndex# a 0#)) + (# _ , 1# #) -> bigNatFromWord# (bigNatGcdWord# a (bigNatIndex# b 0#)) + _ -> + let + go wx wy = -- wx > wy + withNewWordArrayTrimed# (wordArraySize# wy) \mwr s -> + bignat_gcd mwr wx wy s + in case bigNatCompare a b of + EQ -> a + LT -> go b a + GT -> go a b + +-- | Greatest common divisor +bigNatGcdWord# :: BigNat -> Word# -> Word# +bigNatGcdWord# a b + | bigNatIsZero a = 0## + | 0## <- b = 0## + | bigNatIsOne a = 1## + | 1## <- b = 1## + | True = case bigNatCompareWord# a b of + EQ -> b + _ -> bignat_gcd_word a b + +-- | Least common multiple +bigNatLcm :: BigNat -> BigNat -> BigNat +bigNatLcm a b + | bigNatIsZero a = bigNatZero void# + | bigNatIsZero b = bigNatZero void# + | bigNatIsOne a = b + | bigNatIsOne b = a + | True + = case (# bigNatSize# a, bigNatSize# b #) of + (# 1#, 1# #) -> bigNatLcmWordWord# (bigNatIndex# a 0#) (bigNatIndex# b 0#) + (# 1#, _ #) -> bigNatLcmWord# b (bigNatIndex# a 0#) + (# _ , 1# #) -> bigNatLcmWord# a (bigNatIndex# b 0#) + _ -> (a `bigNatQuot` (a `bigNatGcd` b)) `bigNatMul` b + -- TODO: use extended GCD to get a's factor directly + +-- | Least common multiple with a Word# +bigNatLcmWord# :: BigNat -> Word# -> BigNat +bigNatLcmWord# a b + | bigNatIsZero a = bigNatZero void# + | 0## <- b = bigNatZero void# + | bigNatIsOne a = bigNatFromWord# b + | 1## <- b = a + | 1# <- bigNatSize# a = bigNatLcmWordWord# (bigNatIndex# a 0#) b + | True + = (a `bigNatQuotWord#` (a `bigNatGcdWord#` b)) `bigNatMulWord#` b + -- TODO: use extended GCD to get a's factor directly + +-- | Least common multiple between two Word# +bigNatLcmWordWord# :: Word# -> Word# -> BigNat +bigNatLcmWordWord# a b + | 0## <- a = bigNatZero void# + | 0## <- b = bigNatZero void# + | 1## <- a = bigNatFromWord# b + | 1## <- b = bigNatFromWord# a + | True = case (a `quotWord#` (a `gcdWord#` b)) `timesWord2#` b of + -- TODO: use extended GCD to get a's factor directly + (# h, l #) -> bigNatFromWord2# h l + + +------------------------------------------------- +-- Bitwise operations +------------------------------------------------- + +-- | Bitwise OR +bigNatOr :: BigNat -> BigNat -> BigNat +bigNatOr a b + | bigNatIsZero a = b + | bigNatIsZero b = a + | True = withNewWordArray# sz \mwa s -> + inline bignat_or mwa a b s + where + !szA = wordArraySize# a + !szB = wordArraySize# b + !sz = maxI# szA szB + +-- | Bitwise OR with Word# +bigNatOrWord# :: BigNat -> Word# -> BigNat +bigNatOrWord# a b + | bigNatIsZero a = bigNatFromWord# b + | 0## <- b = a + | True = + let sz = wordArraySize# a + in withNewWordArray# sz \mwa s -> + case mwaArrayCopy# mwa 1# a 1# (sz -# 1#) s of + s' -> mwaWrite# mwa 0# (indexWordArray# a 0# `or#` b) s' + +-- | Bitwise AND +bigNatAnd :: BigNat -> BigNat -> BigNat +bigNatAnd a b + | bigNatIsZero a = a + | bigNatIsZero b = b + | True = withNewWordArrayTrimed# sz \mwa s -> + inline bignat_and mwa a b s + where + !szA = wordArraySize# a + !szB = wordArraySize# b + !sz = minI# szA szB + +-- | Bitwise ANDNOT +bigNatAndNot :: BigNat -> BigNat -> BigNat +bigNatAndNot a b + | bigNatIsZero a = a + | bigNatIsZero b = a + | True = withNewWordArrayTrimed# szA \mwa s -> + inline bignat_and_not mwa a b s + where + !szA = wordArraySize# a + +-- | Bitwise AND with Word# +bigNatAndWord# :: BigNat -> Word# -> BigNat +bigNatAndWord# a b + | bigNatIsZero a = a + | True = bigNatFromWord# (indexWordArray# a 0# `and#` b) + +-- | Bitwise ANDNOT with Word# +bigNatAndNotWord# :: BigNat -> Word# -> BigNat +bigNatAndNotWord# a b + | bigNatIsZero a = a + | szA <- bigNatSize# a + = withNewWordArray# szA \mwa s -> + -- duplicate higher limbs + case mwaArrayCopy# mwa 1# a 1# (szA -# 1#) s of + s' -> writeWordArray# mwa 0# + (indexWordArray# a 0# `and#` not# b) s' + +-- | Bitwise AND with Int# +bigNatAndInt# :: BigNat -> Int# -> BigNat +bigNatAndInt# a b + | bigNatIsZero a = a + | isTrue# (b >=# 0#) = bigNatAndWord# a (int2Word# b) + | szA <- bigNatSize# a + = withNewWordArray# szA \mwa s -> + -- duplicate higher limbs (because of sign-extension of b) + case mwaArrayCopy# mwa 1# a 1# (szA -# 1#) s of + s' -> writeWordArray# mwa 0# + (indexWordArray# a 0# `and#` int2Word# b) s' + + +-- | Bitwise XOR +bigNatXor :: BigNat -> BigNat -> BigNat +bigNatXor a b + | bigNatIsZero a = b + | bigNatIsZero b = a + | True = withNewWordArrayTrimed# sz \mwa s -> + inline bignat_xor mwa a b s + where + !szA = wordArraySize# a + !szB = wordArraySize# b + !sz = maxI# szA szB + +-- | Bitwise XOR with Word# +bigNatXorWord# :: BigNat -> Word# -> BigNat +bigNatXorWord# a b + | bigNatIsZero a = bigNatFromWord# b + | 0## <- b = a + | True = + let + sz = wordArraySize# a + in withNewWordArray# sz \mwa s -> + case mwaArrayCopy# mwa 1# a 1# (sz -# 1#) s of + s' -> mwaWrite# mwa 0# (indexWordArray# a 0# `xor#` b) s' + +-- | PopCount for BigNat +bigNatPopCount :: BigNat -> Word +bigNatPopCount a = W# (bigNatPopCount# a) + +-- | PopCount for BigNat +bigNatPopCount# :: BigNat -> Word# +bigNatPopCount# a + | bigNatIsZero a = 0## + | True = inline bignat_popcount a + +-- | Bit shift right +bigNatShiftR# :: BigNat -> Word# -> BigNat +bigNatShiftR# a n + | 0## <- n + = a + + | isTrue# (wordArraySize# a ==# 0#) + = a + + | nw <- word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + , isTrue# (nw >=# wordArraySize# a) + = bigNatZero void# + + | True + = let + !szA = wordArraySize# a + !nw = word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !sz = szA -# nw + in withNewWordArrayTrimed# sz \mwa s -> + inline bignat_shiftr mwa a n s + +-- | Bit shift right (two's complement) +bigNatShiftRNeg# :: BigNat -> Word# -> BigNat +bigNatShiftRNeg# a n + | 0## <- n + = a + + | isTrue# (wordArraySize# a ==# 0#) + = a + + | nw <- word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + , isTrue# (nw >=# wordArraySize# a) + = bigNatZero void# + + | True + = let + !szA = wordArraySize# a + !nw = (word2Int# n -# 1#) `uncheckedIShiftRL#` WORD_SIZE_BITS_SHIFT# + !sz = szA -# nw + in withNewWordArrayTrimed# sz \mwa s -> + inline bignat_shiftr_neg mwa a n s + + +-- | Bit shift right +bigNatShiftR :: BigNat -> Word -> BigNat +bigNatShiftR a (W# n) = bigNatShiftR# a n + +-- | Bit shift left +bigNatShiftL :: BigNat -> Word -> BigNat +bigNatShiftL a (W# n) = bigNatShiftL# a n + +-- | Bit shift left +bigNatShiftL# :: BigNat -> Word# -> BigNat +bigNatShiftL# a n + | 0## <- n + = a + + | isTrue# (wordArraySize# a ==# 0#) + = a + + | True + = let + !szA = wordArraySize# a + !nw = word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !nb = word2Int# (n `and#` WORD_SIZE_BITS_MASK##) + !sz = szA +# nw +# (nb /=# 0#) + + in withNewWordArrayTrimed# sz \mwa s -> + inline bignat_shiftl mwa a n s + + +-- | BigNat bit test +bigNatTestBit# :: BigNat -> Word# -> Bool# +bigNatTestBit# a n = + let + !sz = wordArraySize# a + !nw = word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !nb = n `and#` WORD_SIZE_BITS_MASK## + in if + | isTrue# (nw >=# sz) -> 0# + | True -> testBitW# (indexWordArray# a nw) nb + +-- | BigNat bit test +bigNatTestBit :: BigNat -> Word -> Bool +bigNatTestBit a (W# n) = isTrue# (bigNatTestBit# a n) + + +-- | Return a BigNat whose bit `i` is the only one set. +-- +-- Specialized version of `bigNatShiftL (bigNatFromWord# 1##)` +-- +bigNatBit# :: Word# -> BigNat +bigNatBit# i + | 0## <- i = bigNatOne void# + | True = + let + !nw = word2Int# (i `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !nb = word2Int# (i `and#` WORD_SIZE_BITS_MASK##) + !sz = nw +# 1# + !v = 1## `uncheckedShiftL#` nb + in withNewWordArray# sz \mwa s -> + -- clear the array + case mwaFill# mwa 0## 0## (int2Word# sz) s of + -- set the bit in the most-significant word + s2 -> mwaWrite# mwa (sz -# 1#) v s2 + +-- | Return a BigNat whose bit `i` is the only one set. +-- +-- Specialized version of `bigNatShiftL (bigNatFromWord# 1##)` +-- +bigNatBit :: Word -> BigNat +bigNatBit (W# i) = bigNatBit# i + +-- | BigNat clear bit +bigNatClearBit# :: BigNat -> Word# -> BigNat +bigNatClearBit# a n + -- check the range validity and the current bit value + | isTrue# (bigNatTestBit# a n ==# 0#) = a + | True + = let + !sz = wordArraySize# a + !nw = word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !nb = word2Int# (n `and#` WORD_SIZE_BITS_MASK##) + !nv = bigNatIndex# a nw `xor#` bitW# nb + in if + | isTrue# (sz ==# 1#) + -> bigNatFromWord# nv + + -- special case, operating on most-significant Word + | 0## <- nv + , isTrue# (nw +# 1# ==# sz) + -> case sz -# (waClzAt a (sz -# 2#) +# 1#) of + 0# -> bigNatZero void# + nsz -> withNewWordArray# nsz \mwa s -> + mwaArrayCopy# mwa 0# a 0# nsz s + + | True -> + withNewWordArray# sz \mwa s -> + case mwaArrayCopy# mwa 0# a 0# sz s of + s' -> writeWordArray# mwa nw nv s' + +-- | BigNat set bit +bigNatSetBit# :: BigNat -> Word# -> BigNat +bigNatSetBit# a n + -- check the current bit value + | isTrue# (bigNatTestBit# a n) = a + | True + = let + !sz = wordArraySize# a + !nw = word2Int# (n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !nb = word2Int# (n `and#` WORD_SIZE_BITS_MASK##) + d = nw +# 1# -# sz + in if + -- result BigNat will have more limbs + | isTrue# (d ># 0#) + -> withNewWordArray# (nw +# 1#) \mwa s -> + case mwaArrayCopy# mwa 0# a 0# sz s of + s' -> case mwaFill# mwa 0## (int2Word# sz) (int2Word# (d -# 1#)) s' of + s'' -> writeWordArray# mwa nw (bitW# nb) s'' + + | nv <- bigNatIndex# a nw `or#` bitW# nb + -> withNewWordArray# sz \mwa s -> + case mwaArrayCopy# mwa 0# a 0# sz s of + s' -> writeWordArray# mwa nw nv s' + +-- | Reverse the given bit +bigNatComplementBit# :: BigNat -> Word# -> BigNat +bigNatComplementBit# bn i + | isTrue# (bigNatTestBit# bn i) = bigNatClearBit# bn i + | True = bigNatSetBit# bn i + +------------------------------------------------- +-- Log operations +------------------------------------------------- + +-- | Base 2 logarithm +bigNatLog2# :: BigNat -> Word# +bigNatLog2# a + | bigNatIsZero a = 0## + | True = + let i = int2Word# (bigNatSize# a) `minusWord#` 1## + in wordLog2# (bigNatIndex# a (word2Int# i)) + `plusWord#` (i `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) + +-- | Base 2 logarithm +bigNatLog2 :: BigNat -> Word +bigNatLog2 a = W# (bigNatLog2# a) + +-- | Logarithm for an arbitrary base +bigNatLogBase# :: BigNat -> BigNat -> Word# +bigNatLogBase# base a + | bigNatIsZero base || bigNatIsOne base + = case unexpectedValue of _ -> 0## + + | 1# <- bigNatSize# base + , 2## <- bigNatIndex# base 0# + = bigNatLog2# a + + -- TODO: optimize log base power of 2 (256, etc.) + + | True + = case go base of (# _, e' #) -> e' + where + go pw = if a `bigNatLt` pw + then (# a, 0## #) + else case go (bigNatSqr pw) of + (# q, e #) -> if q `bigNatLt` pw + then (# q, 2## `timesWord#` e #) + else (# q `bigNatQuot` pw + , (2## `timesWord#` e) `plusWord#` 1## #) + +-- | Logarithm for an arbitrary base +bigNatLogBase :: BigNat -> BigNat -> Word +bigNatLogBase base a = W# (bigNatLogBase# base a) + +-- | Logarithm for an arbitrary base +bigNatLogBaseWord# :: Word# -> BigNat -> Word# +bigNatLogBaseWord# base a + | 0## <- base = case unexpectedValue of _ -> 0## + | 1## <- base = case unexpectedValue of _ -> 0## + | 2## <- base = bigNatLog2# a + -- TODO: optimize log base power of 2 (256, etc.) + | True = bigNatLogBase# (bigNatFromWord# base) a + +-- | Logarithm for an arbitrary base +bigNatLogBaseWord :: Word -> BigNat -> Word +bigNatLogBaseWord (W# base) a = W# (bigNatLogBaseWord# base a) + +------------------------------------------------- +-- Various +------------------------------------------------- + +-- | Compute the number of digits of the BigNat in the given base. +-- +-- `base` must be > 1 +bigNatSizeInBase# :: Word# -> BigNat -> Word# +bigNatSizeInBase# base a + | isTrue# (base `leWord#` 1##) + = case unexpectedValue of _ -> 0## + + | bigNatIsZero a + = 0## + + | True + = bigNatLogBaseWord# base a `plusWord#` 1## + +-- | Compute the number of digits of the BigNat in the given base. +-- +-- `base` must be > 1 +bigNatSizeInBase :: Word -> BigNat -> Word +bigNatSizeInBase (W# w) a = W# (bigNatSizeInBase# w a) + +------------------------------------------------- +-- PowMod +------------------------------------------------- + +-- Word# powMod shouldn't be here in BigNat. However GMP provides a very fast +-- implementation so we keep this here at least until we get a native Haskell +-- implementation as fast as GMP's one. + +powModWord# :: Word# -> Word# -> Word# -> Word# +powModWord# = bignat_powmod_words + + +-- | \"@'bigNatPowModWord#' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +bigNatPowModWord# :: BigNat -> BigNat -> Word# -> Word# +bigNatPowModWord# !_ !_ 0## = case divByZero of _ -> 0## +bigNatPowModWord# _ _ 1## = 0## +bigNatPowModWord# b e m + | bigNatIsZero e = 1## + | bigNatIsZero b = 0## + | bigNatIsOne b = 1## + | True = bignat_powmod_word b e m + +-- | \"@'bigNatPowMod' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +bigNatPowMod :: BigNat -> BigNat -> BigNat -> BigNat +bigNatPowMod !b !e !m + | (# m' | #) <- bigNatToWordMaybe# m + = bigNatFromWord# (bigNatPowModWord# b e m') + | bigNatIsZero m = case divByZero of _ -> bigNatZero void# + | bigNatIsOne m = bigNatFromWord# 0## + | bigNatIsZero e = bigNatFromWord# 1## + | bigNatIsZero b = bigNatFromWord# 0## + | bigNatIsOne b = bigNatFromWord# 1## + | True = withNewWordArrayTrimed# (bigNatSize# m) \mwa s -> + inline bignat_powmod mwa b e m s + +-- | Return count of trailing zero bits +-- +-- Return 0 for zero BigNat +bigNatCtz# :: BigNat -> Word# +bigNatCtz# a + | bigNatIsZero a = 0## + | True = go 0# 0## + where + go i c = case indexWordArray# a i of + 0## -> go (i +# 1#) (c `plusWord#` WORD_SIZE_IN_BITS##) + w -> ctz# w `plusWord#` c + +-- | Return count of trailing zero bits +-- +-- Return 0 for zero BigNat +bigNatCtz :: BigNat -> Word +bigNatCtz a = W# (bigNatCtz# a) + + +-- | Return count of trailing zero words +-- +-- Return 0 for zero BigNat +bigNatCtzWord# :: BigNat -> Word# +bigNatCtzWord# a + | bigNatIsZero a = 0## + | True = go 0# 0## + where + go i c = case indexWordArray# a i of + 0## -> go (i +# 1#) (c `plusWord#` 1##) + _ -> c + +-- | Return count of trailing zero words +-- +-- Return 0 for zero BigNat +bigNatCtzWord :: BigNat -> Word +bigNatCtzWord a = W# (bigNatCtzWord# a) + +------------------------------------------------- +-- Export to memory +------------------------------------------------- + +-- | Write a BigNat in base-256 little-endian representation and return the +-- number of bytes written. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToAddrLE# :: BigNat -> Addr# -> State# s -> (# State# s, Word# #) +bigNatToAddrLE# a addr s0 + | isTrue# (sz ==# 0#) = (# s0, 0## #) + | True = case writeMSB s0 of + (# s1, k #) -> case go 0# s1 of + s2 -> (# s2, k `plusWord#` (int2Word# li `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) #) + where + !sz = wordArraySize# a + !li = sz -# 1# + + writeMSB = wordToAddrLE# (indexWordArray# a li) + (addr `plusAddr#` (li `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT#)) + + go i s + | isTrue# (i <# li) + , off <- i `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT# + , w <- indexWordArray# a i + = case wordWriteAddrLE# w (addr `plusAddr#` off) s of + s -> go (i +# 1#) s + + | True + = s + +-- | Write a BigNat in base-256 big-endian representation and return the +-- number of bytes written. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToAddrBE# :: BigNat -> Addr# -> State# s -> (# State# s, Word# #) +bigNatToAddrBE# a addr s0 + | isTrue# (sz ==# 0#) = (# s0, 0## #) + | msw <- indexWordArray# a (sz -# 1#) + = case wordToAddrBE# msw addr s0 of + (# s1, k #) -> case go (sz -# 1#) (addr `plusAddr#` word2Int# k) s1 of + s2 -> (# s2, k `plusWord#` (int2Word# (sz -# 1#) `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) #) + where + sz = wordArraySize# a + + go i adr s + | 0# <- i + = s + + | w <- indexWordArray# a (i -# 1#) + = case wordWriteAddrBE# w adr s of + s' -> go (i -# 1#) + (adr `plusAddr#` WORD_SIZE_IN_BYTES# ) s' + + +-- | Write a BigNat in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToAddr# :: BigNat -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +bigNatToAddr# a addr 0# s = bigNatToAddrLE# a addr s +bigNatToAddr# a addr _ s = bigNatToAddrBE# a addr s + +-- | Write a BigNat in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToAddr :: BigNat -> Addr# -> Bool# -> IO Word +bigNatToAddr a addr e = IO \s -> case bigNatToAddr# a addr e s of + (# s', w #) -> (# s', W# w #) + + + +------------------------------------------------- +-- Import from memory +------------------------------------------------- + +-- | Read a BigNat in base-256 little-endian representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- Higher limbs equal to 0 are automatically trimed. +bigNatFromAddrLE# :: Word# -> Addr# -> State# s -> (# State# s, BigNat #) +bigNatFromAddrLE# 0## _ s = (# s, bigNatZero void# #) +bigNatFromAddrLE# sz addr s = + let + !nw = sz `uncheckedShiftRL#` WORD_SIZE_BYTES_SHIFT# + !nb = sz `and#` WORD_SIZE_BYTES_MASK## + + readMSB mwa s + | 0## <- nb + = s + + | off <- word2Int# (nw `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) + = case wordFromAddrLE# nb (addr `plusAddr#` off) s of + (# s, w #) -> mwaWrite# mwa (word2Int# nw) w s + + go mwa i s + | isTrue# (i ==# word2Int# nw) + = s + + | off <- i `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT# + = case wordFromAddrLE# WORD_SIZE_IN_BYTES## (addr `plusAddr#` off) s of + (# s, w #) -> case mwaWrite# mwa i w s of + s -> go mwa (i +# 1#) s + + in case newWordArray# (word2Int# nw +# (word2Int# nb /=# 0#)) s of + (# s, mwa #) -> case readMSB mwa s of + s -> case go mwa 0# s of + s -> case mwaTrimZeroes# mwa s of + s -> unsafeFreezeByteArray# mwa s + +-- | Read a BigNat in base-256 big-endian representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- Null higher limbs are automatically trimed. +bigNatFromAddrBE# :: Word# -> Addr# -> State# s -> (# State# s, BigNat #) +bigNatFromAddrBE# 0## _ s = (# s, bigNatZero void# #) +bigNatFromAddrBE# sz addr s = + let + !nw = word2Int# (sz `uncheckedShiftRL#` WORD_SIZE_BYTES_SHIFT#) + !nb = sz `and#` WORD_SIZE_BYTES_MASK## + + goMSB mwa s + | 0## <- nb + = s + + | True + = case wordFromAddrBE# nb addr s of + (# s, w #) -> mwaWrite# mwa nw w s + + go mwa i s + | isTrue# (i ==# nw) + = s + + | k <- nw -# 1# -# i + , off <- (k `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT#) +# word2Int# nb + = case wordFromAddrBE# WORD_SIZE_IN_BYTES## (addr `plusAddr#` off) s of + (# s, w #) -> case mwaWrite# mwa i w s of + s -> go mwa (i +# 1#) s + + in case newWordArray# (nw +# (word2Int# nb /=# 0#)) s of + (# s, mwa #) -> case goMSB mwa s of + s -> case go mwa 0# s of + s -> case mwaTrimZeroes# mwa s of + s -> unsafeFreezeByteArray# mwa s + +-- | Read a BigNat in base-256 representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +bigNatFromAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, BigNat #) +bigNatFromAddr# sz addr 0# s = bigNatFromAddrLE# sz addr s +bigNatFromAddr# sz addr _ s = bigNatFromAddrBE# sz addr s + +------------------------------------------------- +-- Export to ByteArray +------------------------------------------------- + +-- | Write a BigNat in base-256 little-endian representation and return the +-- number of bytes written. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToMutableByteArrayLE# :: BigNat -> MutableByteArray# s -> Word# -> State# s -> (# State# s, Word# #) +bigNatToMutableByteArrayLE# a mba moff s0 + | isTrue# (sz ==# 0#) = (# s0, 0## #) + | True = case writeMSB s0 of + (# s1, k #) -> case go 0# s1 of + s2 -> (# s2, k `plusWord#` (int2Word# li `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) #) + where + !sz = wordArraySize# a + !li = sz -# 1# + + writeMSB = wordToMutableByteArrayLE# (indexWordArray# a li) + mba (moff `plusWord#` int2Word# (li `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT#)) + + go i s + | isTrue# (i <# li) + , off <- int2Word# i `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT# + , w <- indexWordArray# a i + = case wordWriteMutableByteArrayLE# w mba (moff `plusWord#` off) s of + s -> go (i +# 1#) s + + | True + = s + +-- | Write a BigNat in base-256 big-endian representation and return the +-- number of bytes written. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToMutableByteArrayBE# :: BigNat -> MutableByteArray# s -> Word# -> State# s -> (# State# s, Word# #) +bigNatToMutableByteArrayBE# a mba moff s0 + | isTrue# (sz ==# 0#) = (# s0, 0## #) + | msw <- indexWordArray# a (sz -# 1#) + = case wordToMutableByteArrayBE# msw mba moff s0 of + (# s1, k #) -> case go (sz -# 1#) k s1 of + s2 -> (# s2, k `plusWord#` (int2Word# (sz -# 1#) `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) #) + where + sz = wordArraySize# a + + go i c s + | 0# <- i + = s + + | w <- indexWordArray# a (i -# 1#) + = case wordWriteMutableByteArrayBE# w mba (moff `plusWord#` c) s of + s' -> go (i -# 1#) + (c `plusWord#` WORD_SIZE_IN_BYTES## ) s' + + +-- | Write a BigNat in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Use \"@'bigNatSizeInBase' 256# /i/@\" to compute the exact number of bytes +-- written in advance. In case of @/i/ == 0@, the function will write and report +-- zero bytes written. +bigNatToMutableByteArray# :: BigNat -> MutableByteArray# s -> Word# -> Bool# -> State# s -> (# State# s, Word# #) +bigNatToMutableByteArray# a mba off 0# s = bigNatToMutableByteArrayLE# a mba off s +bigNatToMutableByteArray# a mba off _ s = bigNatToMutableByteArrayBE# a mba off s + +------------------------------------------------- +-- Import from ByteArray +------------------------------------------------- + +-- | Read a BigNat in base-256 little-endian representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- Null higher limbs are automatically trimed. +bigNatFromByteArrayLE# :: Word# -> ByteArray# -> Word# -> State# s -> (# State# s, BigNat #) +bigNatFromByteArrayLE# 0## _ _ s = (# s, bigNatZero void# #) +bigNatFromByteArrayLE# sz ba moff s = + let + !nw = sz `uncheckedShiftRL#` WORD_SIZE_BYTES_SHIFT# + !nb = sz `and#` WORD_SIZE_BYTES_MASK## + + readMSB mwa s + | 0## <- nb + = s + + | off <- nw `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT# + = case wordFromByteArrayLE# nb ba (moff `plusWord#` off) of + w -> mwaWrite# mwa (word2Int# nw) w s + + go mwa i s + | isTrue# (i `eqWord#` nw) + = s + + | off <- i `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT# + = case wordFromByteArrayLE# WORD_SIZE_IN_BYTES## ba (moff `plusWord#` off) of + w -> case mwaWrite# mwa (word2Int# i) w s of + s -> go mwa (i `plusWord#` 1##) s + + in case newWordArray# (word2Int# nw +# (word2Int# nb /=# 0#)) s of + (# s, mwa #) -> case readMSB mwa s of + s -> case go mwa 0## s of + s -> case mwaTrimZeroes# mwa s of + s -> unsafeFreezeByteArray# mwa s + +-- | Read a BigNat in base-256 big-endian representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- Null higher limbs are automatically trimed. +bigNatFromByteArrayBE# :: Word# -> ByteArray# -> Word# -> State# s -> (# State# s, BigNat #) +bigNatFromByteArrayBE# 0## _ _ s = (# s, bigNatZero void# #) +bigNatFromByteArrayBE# sz ba moff s = + let + !nw = sz `uncheckedShiftRL#` WORD_SIZE_BYTES_SHIFT# + !nb = sz `and#` WORD_SIZE_BYTES_MASK## + + goMSB mwa s + | 0## <- nb + = s + + | True + = case wordFromByteArrayBE# nb ba moff of + w -> mwaWrite# mwa (word2Int# nw) w s + + go mwa i s + | isTrue# (i `eqWord#` nw) + = s + + | k <- nw `minusWord#` 1## `minusWord#` i + , off <- (k `uncheckedShiftL#` WORD_SIZE_BYTES_SHIFT#) `plusWord#` nb + = case wordFromByteArrayBE# WORD_SIZE_IN_BYTES## ba (moff `plusWord#` off) of + w -> case mwaWrite# mwa (word2Int# i) w s of + s -> go mwa (i `plusWord#` 1##) s + + in case newWordArray# (word2Int# nw +# (word2Int# nb /=# 0#)) s of + (# s, mwa #) -> case goMSB mwa s of + s -> case go mwa 0## s of + s -> case mwaTrimZeroes# mwa s of + s -> unsafeFreezeByteArray# mwa s + +-- | Read a BigNat in base-256 representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +bigNatFromByteArray# :: Word# -> ByteArray# -> Word# -> Bool# -> State# s -> (# State# s, BigNat #) +bigNatFromByteArray# sz ba off 0# s = bigNatFromByteArrayLE# sz ba off s +bigNatFromByteArray# sz ba off _ s = bigNatFromByteArrayBE# sz ba off s diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs-boot b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs-boot new file mode 100644 index 0000000000..5c325d074f --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs-boot @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Num.BigNat where + +import GHC.Num.WordArray +import GHC.Prim + +type BigNat = WordArray# + +bigNatSubUnsafe :: BigNat -> BigNat -> BigNat +bigNatMulWord# :: BigNat -> Word# -> BigNat +bigNatRem :: BigNat -> BigNat -> BigNat +bigNatRemWord# :: BigNat -> Word# -> Word# +bigNatShiftR# :: BigNat -> Word# -> BigNat +bigNatShiftL# :: BigNat -> Word# -> BigNat +bigNatCtz# :: BigNat -> Word# +bigNatCtzWord# :: BigNat -> Word# diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs new file mode 100644 index 0000000000..aad7d903ff --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} + +-- | Check Native implementation against another backend +module GHC.Num.BigNat.Check where + +import GHC.Prim +import GHC.Types +import GHC.Num.WordArray +import GHC.Num.Primitives +import qualified GHC.Num.BigNat.Native as Native + +#if defined(BIGNUM_NATIVE) +#error You can't validate Native backed against itself. Choose another backend (e.g. gmp, ffi) + +#elif defined(BIGNUM_FFI) +import qualified GHC.Num.BigNat.FFI as Other + +#elif defined(BIGNUM_GMP) +import qualified GHC.Num.BigNat.GMP as Other + +#else +#error Undefined BigNat backend. Use a flag to select it (e.g. gmp, native, ffi)` +#endif + +default () + +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# -> case unexpectedValue of I# x -> x + _ -> 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 + (# 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 + _ -> 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 #) + _ -> case (ra ==# 1#) of -- don't compare MWAs if overflow signaled! + 1# -> (# s, ra #) + _ -> 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 #) + _ -> (# 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 #) + _ -> (# 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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> gr + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs new file mode 100644 index 0000000000..3ef2f7046c --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs @@ -0,0 +1,581 @@ +{-# 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.Num.BigNat.FFI where + +import GHC.Prim +import GHC.Types +import GHC.Num.WordArray +import GHC.Num.Primitives + +default () + +-- | 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 True to indicate overflow. +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 True to indicate overflow. +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# + diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs new file mode 100644 index 0000000000..cb1fe500d9 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE BlockArguments #-} + +-- | Backend based on the GNU GMP library. +-- +-- This has been adapted from the legacy `integer-gmp` package written by +-- Herbert Valerio Riedel. +module GHC.Num.BigNat.GMP where + +#include "MachDeps.h" +#include "WordSize.h" + +import GHC.Num.WordArray +import GHC.Num.Primitives +import GHC.Prim +import GHC.Types + +default () + +---------------------------------------------------------------------------- +-- type definitions + +-- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS +-- The C99 code in cbits/gmp_wrappers.c will fail to compile if this doesn't hold + +-- | Type representing a GMP Limb +type GmpLimb = Word -- actually, 'CULong' +type GmpLimb# = Word# + +-- | Count of 'GmpLimb's, must be positive (unless specified otherwise). +type GmpSize = Int -- actually, a 'CLong' +type GmpSize# = Int# + +narrowGmpSize# :: Int# -> Int# +#if SIZEOF_LONG == SIZEOF_HSWORD +narrowGmpSize# x = x +#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) +-- On IL32P64 (i.e. Win64), we have to be careful with CLong not being +-- 64bit. This is mostly an issue on values returned from C functions +-- due to sign-extension. +narrowGmpSize# = narrow32Int# +#endif + +narrowCInt# :: Int# -> Int# +narrowCInt# = narrow32Int# + +bignat_compare :: WordArray# -> WordArray# -> Int# +bignat_compare x y = narrowCInt# (c_mpn_cmp x y (wordArraySize# x)) + +bignat_add + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_add #-} +bignat_add mwa wa wb s + -- weird GMP requirement + | isTrue# (wordArraySize# wb ># wordArraySize# wa) + = bignat_add mwa wb wa s + + | True + = do + case ioWord# (c_mpn_add mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_add_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_add_word #-} +bignat_add_word mwa wa b s = do + case ioWord# (c_mpn_add_1 mwa wa (wordArraySize# wa) b) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_sub + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +{-# INLINE bignat_sub #-} +bignat_sub mwa wa wb s = + case ioWord# (c_mpn_sub mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', 0## #) -> (# s', 0# #) + (# s', _ #) -> (# s', 1# #) + +bignat_sub_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +{-# INLINE bignat_sub_word #-} +bignat_sub_word mwa wa b s = + case ioWord# (c_mpn_sub_1 mwa wa (wordArraySize# wa) b) s of + (# s', 0## #) -> (# s', 0# #) + (# s', _ #) -> (# s', 1# #) + +bignat_mul + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_mul #-} +bignat_mul mwa wa wb s = do + case ioWord# (c_mpn_mul mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_mul_word #-} +bignat_mul_word mwa wa b s = + case ioWord# (c_mpn_mul_1 mwa wa (wordArraySize# wa) b) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_popcount :: WordArray# -> Word# +{-# INLINE bignat_popcount #-} +bignat_popcount wa = c_mpn_popcount wa (wordArraySize# wa) + + +bignat_shiftl + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_shiftl #-} +bignat_shiftl mwa wa n s = + case ioWord# (c_mpn_lshift mwa wa (wordArraySize# wa) n) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_shiftr + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_shiftr #-} +bignat_shiftr mwa wa n s = + case ioWord# (c_mpn_rshift mwa wa (wordArraySize# wa) n) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_or + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_or #-} +bignat_or mwa wa wb s1 + | isTrue# (szA >=# szB) = go wa szA wb szB s1 + | True = go wb szB wa szA s1 + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + -- nx >= ny + go wx nx wy ny s = case ioVoid (c_mpn_ior_n mwa wx wy ny) s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_xor + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_xor #-} +bignat_xor mwa wa wb s1 + | isTrue# (szA >=# szB) = go wa szA wb szB s1 + | True = go wb szB wa szA s1 + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + -- nx >= ny + go wx nx wy ny s = case ioVoid (c_mpn_xor_n mwa wx wy ny) s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_and + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and #-} +bignat_and mwa wa wb s = ioVoid (c_mpn_and_n mwa wa wb sz) s + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !sz = minI# szA szB + +bignat_and_not + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and_not #-} +bignat_and_not mwa wa wb s = + case ioVoid (c_mpn_andn_n mwa wa wb n) s of + s' -> mwaArrayCopy# mwa szB wa szB (szA -# szB) s' + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !n = minI# szA szB + +bignat_quotrem + :: MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quotrem mwq mwr wa wb s = + ioVoid (c_mpn_tdiv_qr mwq mwr 0# wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_quot + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quot mwq wa wb s = + ioVoid (c_mpn_tdiv_q mwq wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_rem + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_rem mwr wa wb s = + ioVoid (c_mpn_tdiv_r mwr wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_quotrem_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Word# #) +bignat_quotrem_word mwq wa b s = + ioWord# (c_mpn_divrem_1 mwq 0# wa szA b) s + where + szA = wordArraySize# wa + +bignat_quot_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_quot_word mwq wa b s = + case bignat_quotrem_word mwq wa b s of + (# s', _ #) -> s' + +bignat_rem_word + :: WordArray# + -> Word# + -> Word# +bignat_rem_word wa b = + c_mpn_mod_1 wa (wordArraySize# wa) b + + +bignat_gcd + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_gcd mwr wa wb s = + -- wa > wb + case ioInt# (c_mpn_gcd# mwr wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', sz #) -> mwaSetSize# mwr (narrowGmpSize# sz) s' + +bignat_gcd_word + :: WordArray# + -> Word# + -> Word# +bignat_gcd_word wa b = c_mpn_gcd_1# wa (wordArraySize# wa) b + +bignat_gcd_word_word + :: Word# + -> Word# + -> Word# +bignat_gcd_word_word = integer_gmp_gcd_word + + +bignat_encode_double :: WordArray# -> Int# -> Double# +bignat_encode_double wa e = c_mpn_get_d wa (wordArraySize# wa) e + +bignat_shiftr_neg + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr_neg mwa wa n s = + ioVoid (c_mpn_rshift_2c mwa wa (wordArraySize# wa) n) s + +bignat_powmod_word + :: WordArray# + -> WordArray# + -> Word# + -> Word# +bignat_powmod_word b e m = + integer_gmp_powm1# b (wordArraySize# b) e (wordArraySize# e) m + +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words = integer_gmp_powm_word + +bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_powmod r b e m s = + ioVoid (integer_gmp_powm# r b (wordArraySize# b) e (wordArraySize# e) m (wordArraySize# m)) s + + +---------------------------------------------------------------------- +-- FFI ccall imports + +foreign import ccall unsafe "integer_gmp_gcd_word" + integer_gmp_gcd_word :: GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd_1" + c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd" + c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +foreign import ccall unsafe "integer_gmp_gcdext" + integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s + -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +-- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_add_1" + c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_sub_1" + c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mul_1" + c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_add" + c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_sub" + c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_mul" + c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_cmp" + c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> Int# + +-- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, +-- const mp_limb_t *np, mp_size_t nn, +-- const mp_limb_t *dp, mp_size_t dn) +foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" + c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" + c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" + c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +-- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, +-- mp_size_t s2n, mp_limb_t s3limb) +foreign import ccall unsafe "gmp.h __gmpn_divrem_1" + c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> IO GmpLimb + +-- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mod_1" + c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift" + c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" + c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_lshift" + c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_and_n" + c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_andn_n" + c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_ior_n" + c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_xor_n" + c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_popcount" + c_mpn_popcount :: ByteArray# -> GmpSize# -> Word# + +-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) +foreign import ccall unsafe "integer_gmp_mpn_get_d" + c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# + +foreign import ccall unsafe "integer_gmp_powm" + integer_gmp_powm# :: MutableByteArray# RealWorld + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +foreign import ccall unsafe "integer_gmp_powm_word" + integer_gmp_powm_word :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_powm1" + integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> GmpLimb# diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs new file mode 100644 index 0000000000..a25b36eaec --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module GHC.Num.BigNat.Native where + +#include "MachDeps.h" +#include "WordSize.h" + +#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) +import {-# SOURCE #-} GHC.Num.BigNat +import {-# SOURCE #-} GHC.Num.Natural +#else +import GHC.Num.BigNat +import GHC.Num.Natural +#endif +import GHC.Num.WordArray +import GHC.Num.Primitives +import GHC.Prim +import GHC.Types + +default () + +count_words_bits :: Word# -> (# Word#, Word# #) +count_words_bits n = (# nw, nb #) + where + nw = n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT# + nb = n `and#` WORD_SIZE_BITS_MASK## + +count_words_bits_int :: Word# -> (# Int#, Int# #) +count_words_bits_int n = case count_words_bits n of + (# nw, nb #) -> (# word2Int# nw, word2Int# nb #) + +bignat_compare :: WordArray# -> WordArray# -> Int# +bignat_compare wa wb = go (sz -# 1#) + where + sz = wordArraySize# wa + go i + | isTrue# (i <# 0#) = 0# + | a <- indexWordArray# wa i + , b <- indexWordArray# wb i + = if | isTrue# (a `eqWord#` b) -> go (i -# 1#) + | isTrue# (a `gtWord#` b) -> 1# + | True -> -1# + +bignat_add + :: MutableWordArray# s -- ^ Result + -> WordArray# + -> WordArray# + -> State# s + -> State# s +bignat_add mwa wa wb = addABc 0# 0## + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !szMin = minI# szA szB + + -- we have four cases: + -- 1) we have a digit in A and in B + a potential carry + -- => perform triple addition + -- => result in (carry,word) + -- 2) we have a digit only in A or B and a carry + -- => perform double addition from a single array + -- => result in (carry,word) + -- 3) we have a digit only in A or B and no carry + -- => perform array copy and shrink the array + -- 4) We only have a potential carry + -- => write the carry or shrink the array + + addABc i carry s + | isTrue# (i <# szMin) = + let + !(# carry', r #) = plusWord3# + (indexWordArray# wa i) + (indexWordArray# wb i) + carry + in case mwaWrite# mwa i r s of + s' -> addABc (i +# 1#) carry' s' + + | isTrue# ((i ==# szA) &&# (i ==# szB)) + = mwaWriteOrShrink mwa carry i s + + | isTrue# (i ==# szA) + = addAoBc wb i carry s + + | True + = addAoBc wa i carry s + + addAoBc wab i carry s + | isTrue# (i ==# wordArraySize# wab) + = mwaWriteOrShrink mwa carry i s + + | 0## <- carry + = -- copy the remaining words and remove the word allocated for the + -- potential carry + case mwaArrayCopy# mwa i wab i (wordArraySize# wab -# i) s of + s' -> mwaShrink# mwa 1# s' + + | True + = let !(# carry', r #) = plusWord2# (indexWordArray# wab i) carry + in case mwaWrite# mwa i r s of + s' -> addAoBc wab (i +# 1#) carry' s' + +bignat_add_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_add_word mwa wa b s = mwaInitArrayPlusWord mwa wa b s + +bignat_sub_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub_word mwa wa b = go b 0# + where + !sz = wordArraySize# wa + go carry i s + | isTrue# (i >=# sz) + = (# s, carry `neWord#` 0## #) + + | 0## <- carry + = case mwaArrayCopy# mwa i wa i (sz -# i) s of + s' -> (# s', 0# #) + + | True + = case subWordC# (indexWordArray# wa i) carry of + (# 0##, 0# #) + | isTrue# (i ==# sz) -> case mwaShrink# mwa 1# s of + s' -> (# s', 0# #) + + (# l , c #) -> case mwaWrite# mwa i l s of + s1 -> go (int2Word# c) (i +# 1#) s1 + +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_mul_word mwa wa b = go 0# 0## + where + !szA = wordArraySize# wa + go i carry s + | isTrue# (i ==# szA) = mwaWriteOrShrink mwa carry i s + | True = + let + ai = indexWordArray# wa i + !(# carry', r #) = plusWord12# carry (timesWord2# ai b) + in case mwaWrite# mwa i r s of + s' -> go (i +# 1#) carry' s' + + +bignat_mul + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_mul mwa wa wb s1 = + -- initialize the resulting WordArray + case mwaFill# mwa 0## 0## (int2Word# sz) s1 of + s' -> mulEachB ctzB s' -- loop on b Words + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !sz = szA +# szB + + !ctzA = word2Int# (bigNatCtzWord# wa) + !ctzB = word2Int# (bigNatCtzWord# wb) + + -- multiply a single bj Word# to the whole wa WordArray + mul bj j i carry s + | isTrue# (i ==# szA) + -- write the carry + = mwaAddInplaceWord# mwa (i +# j) carry s + + | True = let + ai = indexWordArray# wa i + !(# c',r' #) = timesWord2# ai bj + !(# c'',r #) = plusWord2# r' carry + carry' = plusWord# c' c'' + in case mwaAddInplaceWord# mwa (i +# j) r s of + s' -> mul bj j (i +# 1#) carry' s' + + -- for each bj in wb, call `mul bj wa` + mulEachB i s + | isTrue# (i ==# szB) = s + | True = case indexWordArray# wb i of + -- detect bj == 0## and skip the loop + 0## -> mulEachB (i +# 1#) s + bi -> case mul bi i ctzA 0## s of + s' -> mulEachB (i +# 1#) s' + +bignat_sub + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub mwa wa wb s = + -- initialize the resulting WordArray + -- Note: we could avoid the copy by subtracting the first non-zero + -- less-significant word of b... + case mwaArrayCopy# mwa 0# wa 0# (wordArraySize# wa) s of + s' -> mwaSubInplaceArray mwa 0# wb s' + +bignat_popcount :: WordArray# -> Word# +bignat_popcount wa = go 0# 0## + where + !sz = wordArraySize# wa + go i c + | isTrue# (i ==# sz) = c + | True = go (i +# 1#) (c `plusWord#` popCnt# (indexWordArray# wa i)) + +bignat_shiftl + :: MutableWordArray# s + -> WordArray# + -> Word# + -> State# s + -> State# s +bignat_shiftl mwa wa n s1 = + -- set the lower words to 0 + case mwaFill# mwa 0## 0## (int2Word# nw) s1 of + s2 -> if + | 0# <- nb -> mwaArrayCopy# mwa nw wa 0# szA s2 + | True -> mwaBitShift 0# 0## s2 + where + !szA = wordArraySize# wa + !(# nw, nb #) = count_words_bits_int n + !sh = WORD_SIZE_IN_BITS# -# nb + + -- Bit granularity (c is the carry from the previous shift) + mwaBitShift i c s + -- write the carry + | isTrue# (i ==# szA) + = mwaWriteOrShrink mwa c (i +# nw) s + + | True = + let + !ai = indexWordArray# wa i + !v = c `or#` (ai `uncheckedShiftL#` nb) + !c' = ai `uncheckedShiftRL#` sh + in case mwaWrite# mwa (i +# nw) v s of + s' -> mwaBitShift (i +# 1#) c' s' + + +bignat_shiftr + :: MutableWordArray# s + -> WordArray# + -> Word# + -> State# s + -> State# s +bignat_shiftr mwa wa n s1 + | isTrue# (nb ==# 0#) = mwaArrayCopy# mwa 0# wa nw sz s1 + | True = mwaBitShift (sz -# 1#) 0## s1 + where + !szA = wordArraySize# wa + !(# nw, nb #) = count_words_bits_int n + !sz = szA -# nw + !sh = WORD_SIZE_IN_BITS# -# nb + + -- Bit granularity (c is the carry from the previous shift) + mwaBitShift i c s + | isTrue# (i <# 0#) = s + | True = + let + !ai = indexWordArray# wa (i +# nw) + !v = c `or#` (ai `uncheckedShiftRL#` nb) + !c' = ai `uncheckedShiftL#` sh + in case mwaWrite# mwa i v s of + s' -> mwaBitShift (i -# 1#) c' s' + +bignat_shiftr_neg + :: MutableWordArray# s + -> WordArray# + -> Word# + -> State# s + -> State# s +bignat_shiftr_neg mwa wa n s1 + -- initialize higher limb + = case mwaWrite# mwa (szA -# 1#) 0## s1 of + s2 -> case bignat_shiftr mwa wa n s2 of + s3 -> if nz_shifted_out + -- round if non-zero bits were shifted out + then mwaAddInplaceWord# mwa 0# 1## s3 + else s3 + where + !szA = wordArraySize# wa + !(# nw, nb #) = count_words_bits_int n + + -- non-zero bits are shifted out? + nz_shifted_out + -- test nb bits + | isTrue# ( + (nb /=# 0#) + &&# (indexWordArray# wa nw `uncheckedShiftL#` + (WORD_SIZE_IN_BITS# -# nb) `neWord#` 0##)) + = True + -- test nw words + | True + = let + go j + | isTrue# (j ==# nw) = False + | isTrue# (indexWordArray# wa j `neWord#` 0##) = True + | True = go (j +# 1#) + in go 0# + + +bignat_or + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_or mwa wa wb s1 + | isTrue# (szA >=# szB) = go wa szA wb szB s1 + | True = go wb szB wa szA s1 + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + -- nx >= ny + go wx nx wy ny s = + case mwaInitArrayBinOp mwa wx wy or# s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_xor + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_xor mwa wa wb s1 + | isTrue# (szA >=# szB) = go wa szA wb szB s1 + | True = go wb szB wa szA s1 + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + -- nx >= ny + go wx nx wy ny s = + case mwaInitArrayBinOp mwa wx wy xor# s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_and + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s + +bignat_and_not + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_and_not mwa wa wb s = + case mwaInitArrayBinOp mwa wa wb (\x y -> x `and#` not# y) s of + s' -> mwaArrayCopy# mwa szB wa szB (szA -# szB) s' + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + +bignat_quotrem + :: MutableWordArray# s + -> MutableWordArray# s + -> WordArray# + -> WordArray# + -> State# s + -> State# s +bignat_quotrem mwq mwr uwa uwb s0 = + -- Normalization consists in left-shifting bits in B and A so that the + -- most-significant bit of the most-significant word of B is 1. It makes + -- quotient prediction much more efficient as we only use the two most + -- significant words of A and the most significant word of B to make the + -- prediction. + + -- we will left-shift A and B of "clzb" bits for normalization + let !clzb = clz# (indexWordArray# uwb (wordArraySize# uwb -# 1#)) + + -- we use a single array initially containing A (normalized) and + -- returning the remainder (normalized): mnwa (for "mutable normalized + -- wordarray A") + -- + -- We allocate it here with an additionnal Word compared to A because + -- normalizing can left shift at most (N-1) bits (on N-bit arch). + in case newWordArray# (wordArraySize# uwa +# 1#) s0 of { (# s1, mnwa #) -> + + -- normalized A in mnwa + let normalizeA s = case mwaWrite# mnwa (wordArraySize# uwa) 0## s of -- init potential carry + s -> case bignat_shiftl mnwa uwa clzb s of -- left shift + s -> mwaTrimZeroes# mnwa s -- remove null carry if any + in case normalizeA s1 of { s2 -> + + -- normalize B. We don't do it in a MutableWordArray because it will remain + -- constant during the whole computation. + let !nwb = bigNatShiftL# uwb clzb in + + -- perform quotrem on normalized inputs + case bignat_quotrem_normalized mwq mnwa nwb s2 of { s3 -> + + -- denormalize the remainder now stored in mnwa. We just have to right shift + -- of "clzb" bits. We copy the result into "mwr" array. + let denormalizeR s = case mwaTrimZeroes# mnwa s of + s -> case unsafeFreezeByteArray# mnwa s of + (# s, wr #) -> case mwaSetSize# mwr (wordArraySize# wr) s of + s -> case bignat_shiftr mwr wr clzb s of + s -> mwaTrimZeroes# mwr s + in denormalizeR s3 + }}} + + + +bignat_quot + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quot mwq wa wb s = + -- allocate a temporary array for the remainder and call quotrem + case newWordArray# (wordArraySize# wb) s of + (# s, mwr #) -> bignat_quotrem mwq mwr wa wb s + +bignat_rem + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_rem mwr wa wb s = + -- allocate a temporary array for the quotient and call quotrem + -- (we could avoid allocating it as it is not used to compute the result but + -- it would require non trivial modification of bignat_quotrem) + case newWordArray# szQ s of + (# s, mwq #) -> bignat_quotrem mwq mwr wa wb s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + szQ = 1# +# szA -# szB + +-- | Perform quotRem on normalized inputs: +-- * highest bit of B is set +-- * A is trimmed +-- * A >= B +-- * B > 1 +bignat_quotrem_normalized + :: MutableWordArray# s + -> MutableWordArray# s + -> WordArray# + -> State# s + -> State# s +bignat_quotrem_normalized mwq mwa b s0 = + + -- n is the size of B + let !n = wordArraySize# b + + -- m+n is the size of A (m >= 0) + in case mwaSize# mwa s0 of { (# s1, szA #) -> + let !m = szA -# n in + + -- Definitions: + -- MSW(x) is the most-significant word of x + -- MSB(x) the most-significant bit of x + + -- We first compute MSW(Q). Thanks to the normalization of B, MSW(Q) can + -- only be 0 or 1 so we only have to perform a prefix comparison to compute + -- MSW(Q). + -- + -- Proof MSW(Q) < 2: + -- * MSB(MSW(B)) = 1 thanks to normalization. + -- * MSW(B) * MSW(Q) <= MSW(A) by definition + -- * suppose MSW(Q) >= 2: + -- MSW(B) * MSW(Q) >= MSW(B) << 1 { MSW(Q) >= 2 } + -- > MAX_WORD_VALUE { MSB(MSW(B)) = 1 } + -- > MSW(A) { MSW(A) <= MAX_WORD_VALUE } + -- contradiction. + -- + -- If A >= (B << m words) + -- then Qm = 1 + -- A := A - (B << m words) + -- else Qm = 0 + -- A unchanged + let computeQm s = case mwaTrimCompare m mwa b s of + (# s, LT #) -> (# s, 0## #) + (# s, _ #) -> (# s, 1## #) + + updateQj j qj qjb s = case mwaWrite# mwq j qj s of -- write Qj + s | 0## <- qj -> s + | True -> case mwaSubInplaceArray mwa j qjb s of -- subtract (qjB << j words) + (# s, _ #) -> s + + -- update the highest word of Q + updateQm s = case computeQm s of + (# s, qm #) -> updateQj m qm b s + + -- the size of Q is szA+szB+1 BEFORE normalization. Normalization may add + -- an additional higher word to A. + -- * If A has an additional limb: + -- * MSW(A) < MSW(B). Because MSB(MSW(A)) can't be set (it would + -- mean that we shifted a whole word, which we didn't) + -- * hence MSW(Q) = 0 but we don't have to write it (and we mustn't) + -- because of the size of Q + -- * If A has no additional limb: + -- * We have to check if MSW(A) >= MSW(B) and to adjust A and MSW(Q) + -- accordingly + -- + -- We detect if A has an additional limb by comparing the size of Q with m + updateQmMaybe s = case mwaSize# mwq s of + (# s, szQ #) | isTrue# (m <# szQ) -> updateQm s + | True -> s + + in case updateQmMaybe s1 of { s2 -> + + + -- main loop: for j from (m-1) downto 0 + -- We estimate a one Word quotient qj: + -- e1e0 <- a(n+j)a(n+j-1) `div` b(n-1) + -- qj | e1 == 0 = e0 + -- | otherwise = maxBound + -- We loop until we find the real quotient: + -- while (A < ((qj*B) << j words)) qj-- + -- We update A and Qj: + -- Qj := qj + -- A := A - (qj*B << j words) + + let bmsw = wordArrayLast# b -- most significant word of B + + estimateQj j s = + case mwaRead# mwa (n +# j) s of + (# s, a1 #) -> case mwaRead# mwa (n +# j -# 1#) s of + (# s, a0 #) -> case quotRemWord3# (# a1, a0 #) bmsw of + (# (# 0##, qj #), _ #) -> (# s, qj #) + (# (# _, _ #), _ #) -> (# s, WORD_MAXBOUND## #) + + -- we perform the qj*B multiplication once and then we subtract B from + -- qj*B as much as needed until (qj'*B << j words) <= A + findRealQj j qj s = findRealQj' j qj (bigNatMulWord# b qj) s + + findRealQj' j qj qjB s = case mwaTrimCompare j mwa qjB s of + (# s, LT #) -> findRealQj' j (qj `minusWord#` 1##) (bigNatSubUnsafe qjB b) s + -- TODO: we could do the sub inplace to + -- reduce allocations + (# s, _ #) -> (# s, qj, qjB #) + + loop j s = case estimateQj j s of + (# s, qj #) -> case findRealQj j qj s of + (# s, qj, qjB #) -> case updateQj j qj qjB s of + s | 0# <- j -> s + | True -> loop (j -# 1#) s + + + in if | 0# <- m -> s2 + | True -> loop (m -# 1#) s2 + }} + +bignat_quotrem_word + :: MutableWordArray# s -- ^ Quotient + -> WordArray# + -> Word# + -> State# s + -> (# State# s, Word# #) +bignat_quotrem_word mwq wa b s = go (sz -# 1#) 0## s + where + sz = wordArraySize# wa + go i r s + | isTrue# (i <# 0#) = (# s, r #) + | True = + let + ai = indexWordArray# wa i + !(# q,r' #) = quotRemWord2# r ai b + in case mwaWrite# mwq i q s of + s' -> go (i -# 1#) r' s' + +bignat_quot_word + :: MutableWordArray# s -- ^ Quotient + -> WordArray# + -> Word# + -> State# s + -> State# s +bignat_quot_word mwq wa b s = go (sz -# 1#) 0## s + where + sz = wordArraySize# wa + go i r s + | isTrue# (i <# 0#) = s + | True = + let + ai = indexWordArray# wa i + !(# q,r' #) = quotRemWord2# r ai b + in case mwaWrite# mwq i q s of + s' -> go (i -# 1#) r' s' + +bignat_rem_word + :: WordArray# + -> Word# + -> Word# +bignat_rem_word wa b = go (sz -# 1#) 0## + where + sz = wordArraySize# wa + go i r + | isTrue# (i <# 0#) = r + | True = + let + ai = indexWordArray# wa i + !(# _,r' #) = quotRemWord2# r ai b + in go (i -# 1#) r' + + +bignat_gcd + :: MutableWordArray# s + -> WordArray# + -> WordArray# + -> State# s + -> State# s +bignat_gcd mwr = go + where + go wmax wmin s + | isTrue# (wordArraySize# wmin ==# 0#) + = mwaInitCopyShrink# mwr wmax s + + | True + = let + wmax' = wmin + !wmin' = bigNatRem wmax wmin + in go wmax' wmin' s + +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 +-- than this simple implementation (basic Euclid algorithm). +-- +-- Ideally we should make an implementation as fast as GMP's one and put it into +-- GHC.Num.Primitives. +bignat_gcd_word_word + :: Word# + -> Word# + -> Word# +bignat_gcd_word_word a 0## = a +bignat_gcd_word_word a b = bignat_gcd_word_word b (a `remWord#` b) + +bignat_encode_double :: WordArray# -> Int# -> Double# +bignat_encode_double wa e0 = go 0.0## e0 0# + where + sz = wordArraySize# wa + go acc e i + | isTrue# (i >=# sz) = acc + | True + = go (acc +## wordEncodeDouble# (indexWordArray# wa i) e) + (e +# WORD_SIZE_IN_BITS#) -- FIXME: we assume that e doesn't overflow... + (i +# 1#) + +bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# +bignat_powmod_word b0 e0 m = go (naturalFromBigNat b0) (naturalFromBigNat e0) (naturalFromWord# 1##) + where + go !b e !r + | isTrue# (e `naturalTestBit#` 0##) + = go b' e' ((r `naturalMul` b) `naturalRem` m') + + | naturalIsZero e + = naturalToWord# r + + | True + = go b' e' r + where + b' = (b `naturalMul` b) `naturalRem` m' + m' = naturalFromWord# m + e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" + +bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_powmod r b0 e0 m s = mwaInitCopyShrink# r r' s + where + !r' = go (naturalFromBigNat b0) + (naturalFromBigNat e0) + (naturalFromWord# 1##) + + go !b e !r + | isTrue# (e `naturalTestBit#` 0##) + = go b' e' ((r `naturalMul` b) `naturalRem` m') + + | naturalIsZero e + = naturalToBigNat r + + | True + = go b' e' r + where + b' = (b `naturalMul` b) `naturalRem` m' + m' = naturalFromBigNat m + e' = e `naturalShiftR#` 1## -- slightly faster than "e `div` 2" + +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words b e m = + bignat_powmod_word (wordArrayFromWord# b) + (wordArrayFromWord# e) + m diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs new file mode 100644 index 0000000000..b4f6ee0c54 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs @@ -0,0 +1,1169 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE BlockArguments #-} + +-- | +-- Module : GHC.Num.Integer +-- Copyright : (c) Sylvain Henry 2019, +-- (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : sylvain@haskus.fr +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Integer' type. + +module GHC.Num.Integer where + +#include "MachDeps.h" +#include "WordSize.h" + +import GHC.Prim +import GHC.Types +import GHC.Classes +import GHC.Magic +import GHC.Num.Primitives +import GHC.Num.BigNat +import GHC.Num.Natural + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +default () + +-- | Arbitrary precision integers. In contrast with fixed-size integral types +-- such as 'Int', the 'Integer' type represents the entire infinite range of +-- integers. +-- +-- Integers are stored in a kind of sign-magnitude form, hence do not expect +-- two's complement form when using bit operations. +-- +-- If the value is small (fit into an 'Int'), 'IS' constructor is used. +-- Otherwise 'IP' and 'IN' constructors are used to store a 'BigNat' +-- representing respectively the positive or the negative value magnitude. +-- +-- Invariant: 'IP' and 'IN' are used iff value doesn't fit in 'IS' +data Integer + = IS !Int# -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range + | IP !BigNat -- ^ iff value in @]maxBound::'Int', +inf[@ range + | IN !BigNat -- ^ iff value in @]-inf, minBound::'Int'[@ range + + +-- | Check Integer invariants +integerCheck# :: Integer -> Bool# +integerCheck# (IS _) = 1# +integerCheck# (IP bn) = bigNatCheck# bn &&# (bn `bigNatGtWord#` INT_MAXBOUND##) +integerCheck# (IN bn) = bigNatCheck# bn &&# (bn `bigNatGtWord#` ABS_INT_MINBOUND##) + +-- | Check Integer invariants +integerCheck :: Integer -> Bool +integerCheck i = isTrue# (integerCheck# i) + +-- | Integer Zero +integerZero :: Integer +integerZero = IS 0# + +-- | Integer One +integerOne :: Integer +integerOne = IS 1# + +--------------------------------------------------------------------- +-- Conversions +--------------------------------------------------------------------- + +-- | Create a positive Integer from a BigNat +integerFromBigNat :: BigNat -> Integer +integerFromBigNat !bn + | bigNatIsZero bn + = integerZero + + | isTrue# (bn `bigNatLeWord#` INT_MAXBOUND##) + = IS (word2Int# (bigNatIndex# bn 0#)) + + | True + = IP bn + +-- | Create a negative Integer from a BigNat +integerFromBigNatNeg :: BigNat -> Integer +integerFromBigNatNeg !bn + | bigNatIsZero bn + = integerZero + + | 1# <- bigNatSize# bn + , i <- negateInt# (word2Int# (bigNatIndex# bn 0#)) + , isTrue# (i <=# 0#) + = IS i + + | True + = IN bn + +-- | Create an Integer from a sign-bit and a BigNat +integerFromBigNatSign :: Int# -> BigNat -> Integer +integerFromBigNatSign !sign !bn + | 0# <- sign + = integerFromBigNat bn + + | True + = integerFromBigNatNeg bn + +-- | Convert an Integer into a BigNat. +-- +-- Return 0 for negative Integers. +integerToBigNatClamp :: Integer -> BigNat +integerToBigNatClamp (IP x) = x +integerToBigNatClamp (IS x) + | isTrue# (x >=# 0#) = bigNatFromWord# (int2Word# x) +integerToBigNatClamp _ = bigNatZero void# + +-- | Create an Integer from an Int# +integerFromInt# :: Int# -> Integer +integerFromInt# i = IS i + +-- | Create an Integer from an Int +integerFromInt :: Int -> Integer +integerFromInt (I# i) = IS i + +-- | Truncates 'Integer' to least-significant 'Int#' +integerToInt# :: Integer -> Int# +{-# NOINLINE integerToInt# #-} +integerToInt# (IS i) = i +integerToInt# (IP b) = word2Int# (bigNatToWord# b) +integerToInt# (IN b) = negateInt# (word2Int# (bigNatToWord# b)) + +-- | Truncates 'Integer' to least-significant 'Int#' +integerToInt :: Integer -> Int +integerToInt i = I# (integerToInt# i) + +-- | Convert a Word# into an Integer +integerFromWord# :: Word# -> Integer +{-# NOINLINE integerFromWord# #-} +integerFromWord# w + | i <- word2Int# w + , isTrue# (i >=# 0#) + = IS i + + | True + = IP (bigNatFromWord# w) + +-- | Convert a Word into an Integer +integerFromWord :: Word -> Integer +integerFromWord (W# w) = integerFromWord# w + +-- | Create a negative Integer with the given Word magnitude +integerFromWordNeg# :: Word# -> Integer +integerFromWordNeg# w + | isTrue# (w `leWord#` ABS_INT_MINBOUND##) + = IS (negateInt# (word2Int# w)) + + | True + = IN (bigNatFromWord# w) + +-- | Create an Integer from a sign and a Word magnitude +integerFromWordSign# :: Int# -> Word# -> Integer +integerFromWordSign# 0# w = integerFromWord# w +integerFromWordSign# _ w = integerFromWordNeg# w + +-- | Truncate an Integer into a Word +integerToWord# :: Integer -> Word# +{-# NOINLINE integerToWord# #-} +integerToWord# (IS i) = int2Word# i +integerToWord# (IP bn) = bigNatToWord# bn +integerToWord# (IN bn) = int2Word# (negateInt# (word2Int# (bigNatToWord# bn))) + +-- | Truncate an Integer into a Word +integerToWord :: Integer -> Word +integerToWord !i = W# (integerToWord# i) + +-- | Convert a Natural into an Integer +integerFromNatural :: Natural -> Integer +{-# NOINLINE integerFromNatural #-} +integerFromNatural (NS x) = integerFromWord# x +integerFromNatural (NB x) = integerFromBigNat x + +-- | Convert a list of Word into an Integer +integerFromWordList :: Bool -> [Word] -> Integer +integerFromWordList True ws = integerFromBigNatNeg (bigNatFromWordList ws) +integerFromWordList False ws = integerFromBigNat (bigNatFromWordList ws) + +-- | Convert a Integer into a Natural +-- +-- Return 0 for negative Integers. +integerToNaturalClamp :: Integer -> Natural +{-# NOINLINE integerToNaturalClamp #-} +integerToNaturalClamp (IS x) + | isTrue# (x <# 0#) = naturalZero + | True = naturalFromWord# (int2Word# x) +integerToNaturalClamp (IP x) = naturalFromBigNat x +integerToNaturalClamp (IN _) = naturalZero + +-- | Convert a Integer into a Natural +-- +-- Return absolute value +integerToNatural :: Integer -> Natural +{-# NOINLINE integerToNatural #-} +integerToNatural (IS x) = naturalFromWord# (wordFromAbsInt# x) +integerToNatural (IP x) = naturalFromBigNat x +integerToNatural (IN x) = naturalFromBigNat x + +--------------------------------------------------------------------- +-- Predicates +--------------------------------------------------------------------- + +-- | Negative predicate +integerIsNegative# :: Integer -> Bool# +integerIsNegative# (IS i#) = i# <# 0# +integerIsNegative# (IP _) = 0# +integerIsNegative# (IN _) = 1# + +-- | Negative predicate +integerIsNegative :: Integer -> Bool +integerIsNegative !i = isTrue# (integerIsNegative# i) + +-- | Zero predicate +integerIsZero :: Integer -> Bool +integerIsZero (IS 0#) = True +integerIsZero _ = False + +-- | Not-equal predicate. +integerNe :: Integer -> Integer -> Bool +integerNe !x !y = isTrue# (integerNe# x y) + +-- | Equal predicate. +integerEq :: Integer -> Integer -> Bool +integerEq !x !y = isTrue# (integerEq# x y) + +-- | Lower-or-equal predicate. +integerLe :: Integer -> Integer -> Bool +integerLe !x !y = isTrue# (integerLe# x y) + +-- | Lower predicate. +integerLt :: Integer -> Integer -> Bool +integerLt !x !y = isTrue# (integerLt# x y) + +-- | Greater predicate. +integerGt :: Integer -> Integer -> Bool +integerGt !x !y = isTrue# (integerGt# x y) + +-- | Greater-or-equal predicate. +integerGe :: Integer -> Integer -> Bool +integerGe !x !y = isTrue# (integerGe# x y) + +-- | Equal predicate. +integerEq# :: Integer -> Integer -> Bool# +{-# NOINLINE integerEq# #-} +integerEq# (IS x) (IS y) = x ==# y +integerEq# (IN x) (IN y) = bigNatEq# x y +integerEq# (IP x) (IP y) = bigNatEq# x y +integerEq# _ _ = 0# + +-- | Not-equal predicate. +integerNe# :: Integer -> Integer -> Bool# +{-# NOINLINE integerNe# #-} +integerNe# (IS x) (IS y) = x /=# y +integerNe# (IN x) (IN y) = bigNatNe# x y +integerNe# (IP x) (IP y) = bigNatNe# x y +integerNe# _ _ = 1# + +-- | Greater predicate. +integerGt# :: Integer -> Integer -> Bool# +{-# NOINLINE integerGt# #-} +integerGt# (IS x) (IS y) = x ># y +integerGt# x y | GT <- integerCompare x y = 1# +integerGt# _ _ = 0# + +-- | Lower-or-equal predicate. +integerLe# :: Integer -> Integer -> Bool# +{-# NOINLINE integerLe# #-} +integerLe# (IS x) (IS y) = x <=# y +integerLe# x y | GT <- integerCompare x y = 0# +integerLe# _ _ = 1# + +-- | Lower predicate. +integerLt# :: Integer -> Integer -> Bool# +{-# NOINLINE integerLt# #-} +integerLt# (IS x) (IS y) = x <# y +integerLt# x y | LT <- integerCompare x y = 1# +integerLt# _ _ = 0# + +-- | Greater-or-equal predicate. +integerGe# :: Integer -> Integer -> Bool# +{-# NOINLINE integerGe# #-} +integerGe# (IS x) (IS y) = x >=# y +integerGe# x y | LT <- integerCompare x y = 0# +integerGe# _ _ = 1# + +instance Eq Integer where + (==) = integerEq + (/=) = integerNe + +-- | Compare two Integer +integerCompare :: Integer -> Integer -> Ordering +{-# NOINLINE integerCompare #-} +integerCompare (IS x) (IS y) = compareInt# x y +integerCompare (IP x) (IP y) = bigNatCompare x y +integerCompare (IN x) (IN y) = bigNatCompare y x +integerCompare (IS _) (IP _) = LT +integerCompare (IS _) (IN _) = GT +integerCompare (IP _) (IS _) = GT +integerCompare (IN _) (IS _) = LT +integerCompare (IP _) (IN _) = GT +integerCompare (IN _) (IP _) = LT + +instance Ord Integer where + compare = integerCompare + +--------------------------------------------------------------------- +-- Operations +--------------------------------------------------------------------- + +-- | Subtract one 'Integer' from another. +integerSub :: Integer -> Integer -> Integer +{-# NOINLINE integerSub #-} +integerSub !x (IS 0#) = x +integerSub (IS x#) (IS y#) + = case subIntC# x# y# of + (# z#, 0# #) -> IS z# + (# 0#, _ #) -> IN (bigNatFromWord2# 1## 0##) + (# z#, _ #) + | isTrue# (z# ># 0#) + -> IN (bigNatFromWord# ( (int2Word# (negateInt# z#)))) + | True + -> IP (bigNatFromWord# ( (int2Word# z#))) +integerSub (IS x#) (IP y) + | isTrue# (x# >=# 0#) + = integerFromBigNatNeg (bigNatSubWordUnsafe# y (int2Word# x#)) + | True + = IN (bigNatAddWord# y (int2Word# (negateInt# x#))) +integerSub (IS x#) (IN y) + | isTrue# (x# >=# 0#) + = IP (bigNatAddWord# y (int2Word# x#)) + | True + = integerFromBigNat (bigNatSubWordUnsafe# y (int2Word# (negateInt# x#))) +integerSub (IP x) (IP y) + = case bigNatCompare x y of + LT -> integerFromBigNatNeg (bigNatSubUnsafe y x) + EQ -> IS 0# + GT -> integerFromBigNat (bigNatSubUnsafe x y) +integerSub (IP x) (IN y) = IP (bigNatAdd x y) +integerSub (IN x) (IP y) = IN (bigNatAdd x y) +integerSub (IN x) (IN y) + = case bigNatCompare x y of + LT -> integerFromBigNat (bigNatSubUnsafe y x) + EQ -> IS 0# + GT -> integerFromBigNatNeg (bigNatSubUnsafe x y) +integerSub (IP x) (IS y#) + | isTrue# (y# >=# 0#) + = integerFromBigNat (bigNatSubWordUnsafe# x (int2Word# y#)) + | True + = IP (bigNatAddWord# x (int2Word# (negateInt# y#))) +integerSub (IN x) (IS y#) + | isTrue# (y# >=# 0#) + = IN (bigNatAddWord# x (int2Word# y#)) + | True + = integerFromBigNatNeg (bigNatSubWordUnsafe# x (int2Word# (negateInt# y#))) + +-- | Add two 'Integer's +integerAdd :: Integer -> Integer -> Integer +{-# NOINLINE integerAdd #-} +integerAdd !x (IS 0#) = x +integerAdd (IS 0#) y = y +integerAdd (IS x#) (IS y#) + = case addIntC# x# y# of + (# z#, 0# #) -> IS z# + (# 0#, _ #) -> IN (bigNatFromWord2# 1## 0##) -- 2*minBound::Int + (# z#, _ #) + | isTrue# (z# ># 0#) -> IN (bigNatFromWord# ( (int2Word# (negateInt# z#)))) + | True -> IP (bigNatFromWord# ( (int2Word# z#))) +integerAdd y@(IS _) x = integerAdd x y +integerAdd (IP x) (IP y) = IP (bigNatAdd x y) +integerAdd (IN x) (IN y) = IN (bigNatAdd x y) +integerAdd (IP x) (IS y#) -- edge-case: @(maxBound+1) + minBound == 0@ + | isTrue# (y# >=# 0#) = IP (bigNatAddWord# x (int2Word# y#)) + | True = integerFromBigNat (bigNatSubWordUnsafe# x (int2Word# + (negateInt# y#))) +integerAdd (IN x) (IS y#) -- edge-case: @(minBound-1) + maxBound == -2@ + | isTrue# (y# >=# 0#) = integerFromBigNatNeg (bigNatSubWordUnsafe# x (int2Word# y#)) + | True = IN (bigNatAddWord# x (int2Word# (negateInt# y#))) +integerAdd y@(IN _) x@(IP _) = integerAdd x y +integerAdd (IP x) (IN y) + = case bigNatCompare x y of + LT -> integerFromBigNatNeg (bigNatSubUnsafe y x) + EQ -> IS 0# + GT -> integerFromBigNat (bigNatSubUnsafe x y) + +-- | Multiply two 'Integer's +integerMul :: Integer -> Integer -> Integer +{-# NOINLINE integerMul #-} +integerMul !_ (IS 0#) = IS 0# +integerMul (IS 0#) _ = IS 0# +integerMul x (IS 1#) = x +integerMul (IS 1#) y = y +integerMul x (IS -1#) = integerNegate x +integerMul (IS -1#) y = integerNegate y +#if __GLASGOW_HASKELL__ < 809 +integerMul (IS x) (IS y) = case mulIntMayOflo# x y of + 0# -> IS (x *# y) + _ -> case (# isTrue# (x >=# 0#), isTrue# (y >=# 0#) #) of + (# False, False #) -> case timesWord2# (int2Word# (negateInt# x)) + (int2Word# (negateInt# y)) of + (# 0##,l #) -> integerFromWord# l + (# h ,l #) -> IP (bigNatFromWord2# h l) + + (# True, False #) -> case timesWord2# (int2Word# x) + (int2Word# (negateInt# y)) of + (# 0##,l #) -> integerFromWordNeg# l + (# h ,l #) -> IN (bigNatFromWord2# h l) + + (# False, True #) -> case timesWord2# (int2Word# (negateInt# x)) + (int2Word# y) of + (# 0##,l #) -> integerFromWordNeg# l + (# h ,l #) -> IN (bigNatFromWord2# h l) + + (# True, True #) -> case timesWord2# (int2Word# x) + (int2Word# y) of + (# 0##,l #) -> integerFromWord# l + (# h ,l #) -> IP (bigNatFromWord2# h l) +#else +integerMul (IS x) (IS y) = case timesInt2# x y of + (# 0#, _h, l #) -> IS l + (# _ , h, l #) + | isTrue# (h >=# 0#) + -> IP (bigNatFromWord2# (int2Word# h) (int2Word# l)) + | True + -> let + -- two's complement of a two-word negative Int: + -- l' = complement l + 1 + -- h' = complement h + carry + !(# l',c #) = addWordC# (not# (int2Word# l)) 1## + !h' = int2Word# c `plusWord#` not# (int2Word# h) + in IN (bigNatFromWord2# h' l') +#endif +integerMul x@(IS _) y = integerMul y x +integerMul (IP x) (IP y) = IP (bigNatMul x y) +integerMul (IP x) (IN y) = IN (bigNatMul x y) +integerMul (IP x) (IS y) + | isTrue# (y >=# 0#) = IP (bigNatMulWord# x (int2Word# y)) + | True = IN (bigNatMulWord# x (int2Word# (negateInt# y))) +integerMul (IN x) (IN y) = IP (bigNatMul x y) +integerMul (IN x) (IP y) = IN (bigNatMul x y) +integerMul (IN x) (IS y) + | isTrue# (y >=# 0#) = IN (bigNatMulWord# x (int2Word# y)) + | True = IP (bigNatMulWord# x (int2Word# (negateInt# y))) + +-- | Negate 'Integer'. +-- +-- One edge-case issue to take into account is that Int's range is not +-- symmetric around 0. I.e. @minBound+maxBound = -1@ +-- +-- IP is used iff n > maxBound::Int +-- IN is used iff n < minBound::Int +integerNegate :: Integer -> Integer +{-# NOINLINE integerNegate #-} +integerNegate (IN b) = IP b +integerNegate (IS INT_MINBOUND#) = IP (bigNatFromWord# ABS_INT_MINBOUND##) +integerNegate (IS i) = IS (negateInt# i) +integerNegate (IP b) + | isTrue# (bigNatEqWord# b ABS_INT_MINBOUND##) = IS INT_MINBOUND# + | True = IN b + + +-- | Compute absolute value of an 'Integer' +integerAbs :: Integer -> Integer +{-# NOINLINE integerAbs #-} +integerAbs (IN i) = IP i +integerAbs n@(IP _) = n +integerAbs n@(IS i) + | isTrue# (i >=# 0#) = n + | INT_MINBOUND# <- i = IP (bigNatFromWord# ABS_INT_MINBOUND##) + | True = IS (negateInt# i) + + +-- | Return @-1@, @0@, and @1@ depending on whether argument is +-- negative, zero, or positive, respectively +integerSignum :: Integer -> Integer +{-# NOINLINE integerSignum #-} +integerSignum !j = IS (integerSignum# j) + +-- | Return @-1#@, @0#@, and @1#@ depending on whether argument is +-- negative, zero, or positive, respectively +integerSignum# :: Integer -> Int# +{-# NOINLINE integerSignum# #-} +integerSignum# (IN _) = -1# +integerSignum# (IS i#) = sgnI# i# +integerSignum# (IP _ ) = 1# + +-- | Count number of set bits. For negative arguments returns +-- the negated population count of the absolute value. +integerPopCount# :: Integer -> Int# +{-# NOINLINE integerPopCount# #-} +integerPopCount# (IS i) + | isTrue# (i >=# 0#) = word2Int# (popCntI# i) + | True = negateInt# (word2Int# (popCntI# (negateInt# i))) +integerPopCount# (IP bn) = word2Int# (bigNatPopCount# bn) +integerPopCount# (IN bn) = negateInt# (word2Int# (bigNatPopCount# bn)) + +-- | Positive 'Integer' for which only /n/-th bit is set +integerBit# :: Word# -> Integer +{-# NOINLINE integerBit# #-} +integerBit# i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (uncheckedIShiftL# 1# (word2Int# i)) + + | True = IP (bigNatBit# i) + +-- | 'Integer' for which only /n/-th bit is set +integerBit :: Word -> Integer +integerBit (W# i) = integerBit# i + +-- | Test if /n/-th bit is set. +-- +-- Fake 2's complement for negative values (might be slow) +integerTestBit# :: Integer -> Word# -> Bool# +{-# NOINLINE integerTestBit# #-} +integerTestBit# (IS x) i + | isTrue# (i `ltWord#` WORD_SIZE_IN_BITS##) + = testBitI# x i + | True + = x <# 0# +integerTestBit# (IP x) i = bigNatTestBit# x i +integerTestBit# (IN x) i + | isTrue# (iw >=# n) + = 1# + -- if all the limbs j with j < iw are null, then we have to consider the + -- carry of the 2's complement convertion. Otherwise we just have to return + -- the inverse of the bit test + | allZ iw = testBitW# (xi `minusWord#` 1##) ib ==# 0# + | True = testBitW# xi ib ==# 0# + where + !xi = bigNatIndex# x iw + !n = bigNatSize# x + !iw = word2Int# (i `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#) + !ib = i `and#` WORD_SIZE_BITS_MASK## + + allZ 0# = True + allZ j | isTrue# (bigNatIndex# x (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#) + | True = False + +-- | Test if /n/-th bit is set. For negative Integers it tests the n-th bit of +-- the negated argument. +-- +-- Fake 2's complement for negative values (might be slow) +integerTestBit :: Integer -> Word -> Bool +integerTestBit !i (W# n) = isTrue# (integerTestBit# i n) + +-- | Shift-right operation +-- +-- Fake 2's complement for negative values (might be slow) +integerShiftR# :: Integer -> Word# -> Integer +{-# NOINLINE integerShiftR# #-} +integerShiftR# !x 0## = x +integerShiftR# (IS i) n = IS (iShiftRA# i (word2Int# n)) + where + iShiftRA# a b + | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#) + | True = a `uncheckedIShiftRA#` b +integerShiftR# (IP bn) n = integerFromBigNat (bigNatShiftR# bn n) +integerShiftR# (IN bn) n = + case integerFromBigNatNeg (bigNatShiftRNeg# bn n) of + IS 0# -> IS -1# + r -> r + +-- | Shift-right operation +-- +-- Fake 2's complement for negative values (might be slow) +integerShiftR :: Integer -> Word -> Integer +integerShiftR !x (W# w) = integerShiftR# x w + +-- | Shift-left operation +integerShiftL# :: Integer -> Word# -> Integer +{-# NOINLINE integerShiftL# #-} +integerShiftL# !x 0## = x +integerShiftL# (IS 0#) _ = IS 0# +integerShiftL# (IS 1#) n = integerBit# n +integerShiftL# (IS i) n + | isTrue# (i >=# 0#) = integerFromBigNat (bigNatShiftL# (bigNatFromWord# (int2Word# i)) n) + | True = integerFromBigNatNeg (bigNatShiftL# (bigNatFromWord# (int2Word# (negateInt# i))) n) +integerShiftL# (IP bn) n = IP (bigNatShiftL# bn n) +integerShiftL# (IN bn) n = IN (bigNatShiftL# bn n) + +-- | Shift-left operation +-- +-- Remember that bits are stored in sign-magnitude form, hence the behavior of +-- negative Integers is different from negative Int's behavior. +integerShiftL :: Integer -> Word -> Integer +integerShiftL !x (W# w) = integerShiftL# x w + +-- | Bitwise OR operation +-- +-- Fake 2's complement for negative values (might be slow) +integerOr :: Integer -> Integer -> Integer +{-# NOINLINE integerOr #-} +integerOr a b = case a of + IS 0# -> b + IS -1# -> IS -1# + IS x -> case b of + IS 0# -> a + IS -1# -> IS -1# + IS y -> IS (orI# x y) + IP y + | isTrue# (x >=# 0#) -> integerFromBigNat (bigNatOrWord# y (int2Word# x)) + | True -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAndNot -- use De Morgan's laws + (bigNatFromWord# + (int2Word# (negateInt# x) `minusWord#` 1##)) + y) + 1##) + IN y + | isTrue# (x >=# 0#) -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAndNotWord# -- use De Morgan's laws + (bigNatSubWordUnsafe# y 1##) + (int2Word# x)) + 1##) + | True -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAndWord# -- use De Morgan's laws + (bigNatSubWordUnsafe# y 1##) + (int2Word# (negateInt# x) `minusWord#` 1##)) + 1##) + IP x -> case b of + IS _ -> integerOr b a + IP y -> integerFromBigNat (bigNatOr x y) + IN y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAndNot -- use De Morgan's laws + (bigNatSubWordUnsafe# y 1##) + x) + 1##) + IN x -> case b of + IS _ -> integerOr b a + IN y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAnd -- use De Morgan's laws + (bigNatSubWordUnsafe# x 1##) + (bigNatSubWordUnsafe# y 1##)) + 1##) + IP y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatAndNot -- use De Morgan's laws + (bigNatSubWordUnsafe# x 1##) + y) + 1##) + + +-- | Bitwise XOR operation +-- +-- Fake 2's complement for negative values (might be slow) +integerXor :: Integer -> Integer -> Integer +{-# NOINLINE integerXor #-} +integerXor a b = case a of + IS 0# -> b + IS -1# -> integerComplement b + IS x -> case b of + IS 0# -> a + IS -1# -> integerComplement a + IS y -> IS (xorI# x y) + IP y + | isTrue# (x >=# 0#) -> integerFromBigNat (bigNatXorWord# y (int2Word# x)) + | True -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatXorWord# + y + (int2Word# (negateInt# x) `minusWord#` 1##)) + 1##) + IN y + | isTrue# (x >=# 0#) -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatXorWord# + (bigNatSubWordUnsafe# y 1##) + (int2Word# x)) + 1##) + | True -> integerFromBigNat + (bigNatXorWord# -- xor (not x) (not y) = xor x y + (bigNatSubWordUnsafe# y 1##) + (int2Word# (negateInt# x) `minusWord#` 1##)) + IP x -> case b of + IS _ -> integerXor b a + IP y -> integerFromBigNat (bigNatXor x y) + IN y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatXor + x + (bigNatSubWordUnsafe# y 1##)) + 1##) + IN x -> case b of + IS _ -> integerXor b a + IN y -> integerFromBigNat + (bigNatXor -- xor (not x) (not y) = xor x y + (bigNatSubWordUnsafe# x 1##) + (bigNatSubWordUnsafe# y 1##)) + IP y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatXor + y + (bigNatSubWordUnsafe# x 1##)) + 1##) + + + +-- | Bitwise AND operation +-- +-- Fake 2's complement for negative values (might be slow) +integerAnd :: Integer -> Integer -> Integer +{-# NOINLINE integerAnd #-} +integerAnd a b = case a of + IS 0# -> IS 0# + IS -1# -> b + IS x -> case b of + IS 0# -> IS 0# + IS -1# -> a + IS y -> IS (andI# x y) + IP y -> integerFromBigNat (bigNatAndInt# y x) + IN y + | isTrue# (x >=# 0#) -> integerFromWord# (int2Word# x `andNot#` (indexWordArray# y 0# `minusWord#` 1##)) + | True -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatOrWord# -- use De Morgan's laws + (bigNatSubWordUnsafe# y 1##) + (wordFromAbsInt# x `minusWord#` 1##)) + 1##) + IP x -> case b of + IS _ -> integerAnd b a + IP y -> integerFromBigNat (bigNatAnd x y) + IN y -> integerFromBigNat (bigNatAndNot x (bigNatSubWordUnsafe# y 1##)) + IN x -> case b of + IS _ -> integerAnd b a + IN y -> integerFromBigNatNeg + (bigNatAddWord# + (bigNatOr -- use De Morgan's laws + (bigNatSubWordUnsafe# x 1##) + (bigNatSubWordUnsafe# y 1##)) + 1##) + IP y -> integerFromBigNat (bigNatAndNot y (bigNatSubWordUnsafe# x 1##)) + + + +-- | Binary complement of the +integerComplement :: Integer -> Integer +{-# NOINLINE integerComplement #-} +integerComplement (IS x) = IS (notI# x) +integerComplement (IP x) = IN (bigNatAddWord# x 1##) +integerComplement (IN x) = IP (bigNatSubWordUnsafe# x 1##) + + +-- | Simultaneous 'integerQuot' and 'integerRem'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) +{-# NOINLINE integerQuotRem# #-} +integerQuotRem# !n (IS 1#) = (# n, IS 0# #) +integerQuotRem# !n (IS -1#) = let !q = integerNegate n in (# q, (IS 0#) #) +integerQuotRem# !_ (IS 0#) = (# divByZero, divByZero #) +integerQuotRem# (IS 0#) _ = (# IS 0#, IS 0# #) +integerQuotRem# (IS n#) (IS d#) = case quotRemInt# n# d# of + (# q#, r# #) -> (# IS q#, IS r# #) +integerQuotRem# (IP n) (IP d) = case bigNatQuotRem# n d of + (# q, r #) -> (# integerFromBigNat q, integerFromBigNat r #) +integerQuotRem# (IP n) (IN d) = case bigNatQuotRem# n d of + (# q, r #) -> (# integerFromBigNatNeg q, integerFromBigNat r #) +integerQuotRem# (IN n) (IN d) = case bigNatQuotRem# n d of + (# q, r #) -> (# integerFromBigNat q, integerFromBigNatNeg r #) +integerQuotRem# (IN n) (IP d) = case bigNatQuotRem# n d of + (# q, r #) -> (# integerFromBigNatNeg q, integerFromBigNatNeg r #) +integerQuotRem# (IP n) (IS d#) + | isTrue# (d# >=# 0#) = case bigNatQuotRemWord# n (int2Word# d#) of + (# q, r# #) -> (# integerFromBigNat q, integerFromWord# r# #) + | True = case bigNatQuotRemWord# n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# integerFromBigNatNeg q, integerFromWord# r# #) +integerQuotRem# (IN n) (IS d#) + | isTrue# (d# >=# 0#) = case bigNatQuotRemWord# n (int2Word# d#) of + (# q, r# #) -> (# integerFromBigNatNeg q, integerFromWordNeg# r# #) + | True = case bigNatQuotRemWord# n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# integerFromBigNat q, integerFromWordNeg# r# #) +integerQuotRem# n@(IS _) (IN _) = (# IS 0#, n #) -- since @n < d@ +integerQuotRem# n@(IS n#) (IP d) -- need to account for (IS minBound) + | isTrue# (n# ># 0#) = (# IS 0#, n #) + | isTrue# (bigNatGtWord# d (int2Word# (negateInt# n#))) = (# IS 0#, n #) + | True {- abs(n) == d -} = (# IS -1#, IS 0# #) + +-- | Simultaneous 'integerQuot' and 'integerRem'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +integerQuotRem :: Integer -> Integer -> (Integer, Integer) +integerQuotRem !x !y = case integerQuotRem# x y of + (# q, r #) -> (q, r) + + +integerQuot :: Integer -> Integer -> Integer +{-# NOINLINE integerQuot #-} +integerQuot !n (IS 1#) = n +integerQuot !n (IS -1#) = integerNegate n +integerQuot !_ (IS 0#) = divByZero +integerQuot (IS 0#) _ = IS 0# +integerQuot (IS n#) (IS d#) = IS (quotInt# n# d#) +integerQuot (IP n) (IS d#) + | isTrue# (d# >=# 0#) = integerFromBigNat (bigNatQuotWord# n (int2Word# d#)) + | True = integerFromBigNatNeg (bigNatQuotWord# n + (int2Word# (negateInt# d#))) +integerQuot (IN n) (IS d#) + | isTrue# (d# >=# 0#) = integerFromBigNatNeg (bigNatQuotWord# n (int2Word# d#)) + | True = integerFromBigNat (bigNatQuotWord# n + (int2Word# (negateInt# d#))) +integerQuot (IP n) (IP d) = integerFromBigNat (bigNatQuot n d) +integerQuot (IP n) (IN d) = integerFromBigNatNeg (bigNatQuot n d) +integerQuot (IN n) (IP d) = integerFromBigNatNeg (bigNatQuot n d) +integerQuot (IN n) (IN d) = integerFromBigNat (bigNatQuot n d) +integerQuot n d = case integerQuotRem# n d of (# q, _ #) -> q + +integerRem :: Integer -> Integer -> Integer +{-# NOINLINE integerRem #-} +integerRem !_ (IS 1#) = IS 0# +integerRem _ (IS -1#) = IS 0# +integerRem _ (IS 0#) = IS (remInt# 0# 0#) +integerRem (IS 0#) _ = IS 0# +integerRem (IS n#) (IS d#) = IS (remInt# n# d#) +integerRem (IP n) (IS d#) + = integerFromWord# (bigNatRemWord# n (int2Word# (absI# d#))) +integerRem (IN n) (IS d#) + = integerFromWordNeg# (bigNatRemWord# n (int2Word# (absI# d#))) +integerRem (IP n) (IP d) = integerFromBigNat (bigNatRem n d) +integerRem (IP n) (IN d) = integerFromBigNat (bigNatRem n d) +integerRem (IN n) (IP d) = integerFromBigNatNeg (bigNatRem n d) +integerRem (IN n) (IN d) = integerFromBigNatNeg (bigNatRem n d) +integerRem n d = case integerQuotRem# n d of (# _, r #) -> r + + +-- | Simultaneous 'integerDiv' and 'integerMod'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +integerDivMod# :: Integer -> Integer -> (# Integer, Integer #) +{-# NOINLINE integerDivMod# #-} +integerDivMod# !n !d + | isTrue# (integerSignum# r ==# negateInt# (integerSignum# d)) + = let !q' = integerAdd q (IS -1#) -- TODO: optimize + !r' = integerAdd r d + in (# q', r' #) + | True = qr + where + !qr@(# q, r #) = integerQuotRem# n d + +-- | Simultaneous 'integerDiv' and 'integerMod'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +integerDivMod :: Integer -> Integer -> (Integer, Integer) +integerDivMod !n !d = case integerDivMod# n d of + (# q,r #) -> (q,r) + + +integerDiv :: Integer -> Integer -> Integer +{-# NOINLINE integerDiv #-} +integerDiv !n !d + -- same-sign ops can be handled by more efficient 'integerQuot' + | isTrue# (integerIsNegative# n ==# integerIsNegative# d) = integerQuot n d + | True = case integerDivMod# n d of (# q, _ #) -> q + + +integerMod :: Integer -> Integer -> Integer +{-# NOINLINE integerMod #-} +integerMod !n !d + -- same-sign ops can be handled by more efficient 'integerRem' + | isTrue# (integerIsNegative# n ==# integerIsNegative# d) = integerRem n d + | True = case integerDivMod# n d of (# _, r #) -> r + +-- | Compute greatest common divisor. +integerGcd :: Integer -> Integer -> Integer +{-# NOINLINE integerGcd #-} +integerGcd (IS 0#) !b = integerAbs b +integerGcd a (IS 0#) = integerAbs a +integerGcd (IS 1#) _ = IS 1# +integerGcd (IS -1#) _ = IS 1# +integerGcd _ (IS 1#) = IS 1# +integerGcd _ (IS -1#) = IS 1# +integerGcd (IS a) (IS b) = integerFromWord# (gcdWord# + (int2Word# (absI# a)) + (int2Word# (absI# b))) +integerGcd a@(IS _) b = integerGcd b a +integerGcd (IN a) b = integerGcd (IP a) b +integerGcd (IP a) (IP b) = integerFromBigNat (bigNatGcd a b) +integerGcd (IP a) (IN b) = integerFromBigNat (bigNatGcd a b) +integerGcd (IP a) (IS b) = integerFromWord# (bigNatGcdWord# a (int2Word# (absI# b))) + +-- | Compute least common multiple. +integerLcm :: Integer -> Integer -> Integer +{-# NOINLINE integerLcm #-} +integerLcm (IS 0#) !_ = IS 0# +integerLcm (IS 1#) b = integerAbs b +integerLcm (IS -1#) b = integerAbs b +integerLcm _ (IS 0#) = IS 0# +integerLcm a (IS 1#) = integerAbs a +integerLcm a (IS -1#) = integerAbs a +integerLcm a b = (aa `integerQuot` (aa `integerGcd` ab)) `integerMul` ab + where -- TODO: use extended GCD to get a's factor directly + aa = integerAbs a + ab = integerAbs b + +-- | Square a Integer +integerSqr :: Integer -> Integer +integerSqr !a = integerMul a a + + +-- | Base 2 logarithm (floor) +-- +-- For numbers <= 0, return 0 +integerLog2# :: Integer -> Word# +integerLog2# (IS i) + | isTrue# (i <=# 0#) = 0## + | True = wordLog2# (int2Word# i) +integerLog2# (IN _) = 0## +integerLog2# (IP b) = bigNatLog2# b + +-- | Base 2 logarithm (floor) +-- +-- For numbers <= 0, return 0 +integerLog2 :: Integer -> Word +integerLog2 !i = W# (integerLog2# i) + +-- | Logarithm (floor) for an arbitrary base +-- +-- For numbers <= 0, return 0 +integerLogBaseWord# :: Word# -> Integer -> Word# +integerLogBaseWord# base !i + | integerIsNegative i = 0## + | True = naturalLogBaseWord# base (integerToNatural i) + +-- | Logarithm (floor) for an arbitrary base +-- +-- For numbers <= 0, return 0 +integerLogBaseWord :: Word -> Integer -> Word +integerLogBaseWord (W# base) !i = W# (integerLogBaseWord# base i) + +-- | Logarithm (floor) for an arbitrary base +-- +-- For numbers <= 0, return 0 +integerLogBase# :: Integer -> Integer -> Word# +integerLogBase# !base !i + | integerIsNegative i = 0## + | True = naturalLogBase# (integerToNatural base) + (integerToNatural i) + +-- | Logarithm (floor) for an arbitrary base +-- +-- For numbers <= 0, return 0 +integerLogBase :: Integer -> Integer -> Word +integerLogBase !base !i = W# (integerLogBase# base i) + +-- | Indicate if the value is a power of two and which one +integerIsPowerOf2# :: Integer -> (# () | Word# #) +integerIsPowerOf2# (IS i) + | isTrue# (i <=# 0#) = (# () | #) + | True = wordIsPowerOf2# (int2Word# i) +integerIsPowerOf2# (IN _) = (# () | #) +integerIsPowerOf2# (IP w) = bigNatIsPowerOf2# w + +#if WORD_SIZE_IN_BITS == 32 + +-- | Convert an Int64# into an Integer on 32-bit architectures +integerFromInt64# :: Int64# -> Integer +{-# NOINLINE integerFromInt64# #-} +integerFromInt64# !i + | isTrue# ((i `leInt64#` intToInt64# 0x7FFFFFFF#) + &&# (i `geInt64#` intToInt64# -0x80000000#)) + = IS (int64ToInt# i) + + | isTrue# (i `geInt64#` intToInt64# 0#) + = IP (bigNatFromWord64# (int64ToWord64# i)) + + | True + = IN (bigNatFromWord64# (int64ToWord64# (negateInt64# i))) + +-- | Convert a Word64# into an Integer on 32-bit architectures +integerFromWord64# :: Word64# -> Integer +{-# NOINLINE integerFromWord64# #-} +integerFromWord64# !w + | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##) + = IS (int64ToInt# (word64ToInt64# w)) + | True + = IP (bigNatFromWord64# w) + +-- | Convert an Integer into an Int64# on 32-bit architectures +integerToInt64# :: Integer -> Int64# +{-# NOINLINE integerToInt64# #-} +integerToInt64# (IS i) = intToInt64# i +integerToInt64# (IP b) = word64ToInt64# (bigNatToWord64# b) +integerToInt64# (IN b) = negateInt64# (word64ToInt64# (bigNatToWord64# b)) + +-- | Convert an Integer into a Word64# on 32-bit architectures +integerToWord64# :: Integer -> Word64# +{-# NOINLINE integerToWord64# #-} +integerToWord64# (IS i) = int64ToWord64# (intToInt64# i) +integerToWord64# (IP b) = bigNatToWord64# b +integerToWord64# (IN b) = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64# b))) + +#else + +-- | Convert an Int64# into an Integer on 64-bit architectures +integerFromInt64# :: Int# -> Integer +integerFromInt64# !x = IS x + +#endif + +---------------------------------------------------------------------------- +-- Conversions to/from floating point +---------------------------------------------------------------------------- + +-- | Decode a Double# into (# Integer mantissa, Int# exponent #) +integerDecodeDouble# :: Double# -> (# Integer, Int# #) +{-# NOINLINE integerDecodeDouble# #-} +integerDecodeDouble# !x = case decodeDouble_Int64# x of + (# m, e #) -> (# integerFromInt64# m, e #) + +-- | Decode a Double# into (# Integer mantissa, Int# exponent #) +integerDecodeDouble :: Double -> (Integer, Int) +integerDecodeDouble (D# x) = case integerDecodeDouble# x of + (# m, e #) -> (m, I# e) + +-- | Encode (# Integer mantissa, Int# exponent #) into a Double# +integerEncodeDouble# :: Integer -> Int# -> Double# +{-# NOINLINE integerEncodeDouble# #-} +integerEncodeDouble# (IS i) 0# = int2Double# i +integerEncodeDouble# (IS i) e = intEncodeDouble# i e +integerEncodeDouble# (IP b) e = bigNatEncodeDouble# b e +integerEncodeDouble# (IN b) e = negateDouble# (bigNatEncodeDouble# b e) + +-- | Encode (Integer mantissa, Int exponent) into a Double +integerEncodeDouble :: Integer -> Int -> Double +integerEncodeDouble !m (I# e) = D# (integerEncodeDouble# m e) + +-- | Encode an Integer (mantissa) into a Double# +integerToDouble# :: Integer -> Double# +{-# NOINLINE integerToDouble# #-} +integerToDouble# !i = integerEncodeDouble# i 0# + +-- | Encode an Integer (mantissa) into a Float# +integerToFloat# :: Integer -> Float# +{-# NOINLINE integerToFloat# #-} +integerToFloat# !i = integerEncodeFloat# i 0# + +-- | Encode (# Integer mantissa, Int# exponent #) into a Float# +-- +-- TODO: Not sure if it's worth to write 'Float' optimized versions here +integerEncodeFloat# :: Integer -> Int# -> Float# +{-# NOINLINE integerEncodeFloat# #-} +integerEncodeFloat# !m 0# = double2Float# (integerToDouble# m) +integerEncodeFloat# !m e = double2Float# (integerEncodeDouble# m e) + +-- | Compute the number of digits of the Integer (without the sign) in the given base. +-- +-- `base` must be > 1 +integerSizeInBase# :: Word# -> Integer -> Word# +integerSizeInBase# base (IS i) = wordSizeInBase# base (int2Word# (absI# i)) +integerSizeInBase# base (IP n) = bigNatSizeInBase# base n +integerSizeInBase# base (IN n) = bigNatSizeInBase# base n + +-- | Write an 'Integer' (without sign) to @/addr/@ in base-256 representation +-- and return the number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +integerToAddr# :: Integer -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +integerToAddr# (IS i) = wordToAddr# (int2Word# (absI# i)) +integerToAddr# (IP n) = bigNatToAddr# n +integerToAddr# (IN n) = bigNatToAddr# n + +-- | Write an 'Integer' (without sign) to @/addr/@ in base-256 representation +-- and return the number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +integerToAddr :: Integer -> Addr# -> Bool# -> IO Word +integerToAddr a addr e = IO \s -> case integerToAddr# a addr e s of + (# s', w #) -> (# s', W# w #) + +-- | Read an 'Integer' (without sign) in base-256 representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +integerFromAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, Integer #) +integerFromAddr# sz addr e s = + case bigNatFromAddr# sz addr e s of + (# s', n #) -> (# s', integerFromBigNat n #) + +-- | Read an 'Integer' (without sign) in base-256 representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +integerFromAddr :: Word# -> Addr# -> Bool# -> IO Integer +integerFromAddr sz addr e = IO (integerFromAddr# sz addr e) + + + +-- | Write an 'Integer' (without sign) in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +integerToMutableByteArray# :: Integer -> MutableByteArray# s -> Word# -> Bool# -> State# s -> (# State# s, Word# #) +integerToMutableByteArray# (IS i) = wordToMutableByteArray# (int2Word# (absI# i)) +integerToMutableByteArray# (IP a) = bigNatToMutableByteArray# a +integerToMutableByteArray# (IN a) = bigNatToMutableByteArray# a + +-- | Write an 'Integer' (without sign) in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +integerToMutableByteArray :: Integer -> MutableByteArray# RealWorld -> Word# -> Bool# -> IO Word +integerToMutableByteArray i mba w e = IO \s -> case integerToMutableByteArray# i mba w e s of + (# s', r #) -> (# s', W# r #) + +-- | Read an 'Integer' (without sign) in base-256 representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +integerFromByteArray# :: Word# -> ByteArray# -> Word# -> Bool# -> State# s -> (# State# s, Integer #) +integerFromByteArray# sz ba off e s = case bigNatFromByteArray# sz ba off e s of + (# s', a #) -> (# s', integerFromBigNat a #) + +-- | Read an 'Integer' (without sign) in base-256 representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +integerFromByteArray :: Word# -> ByteArray# -> Word# -> Bool# -> Integer +integerFromByteArray sz ba off e = case runRW# (integerFromByteArray# sz ba off e) of + (# _, i #) -> i diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs b/libraries/ghc-bignum/src/GHC/Num/Natural.hs new file mode 100644 index 0000000000..1adb02181d --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} + +#include "MachDeps.h" +#include "WordSize.h" + +module GHC.Num.Natural where + +import GHC.Prim +import GHC.Types +import GHC.Classes + +import GHC.Num.BigNat +import GHC.Num.Primitives + +default () + +-- | Natural number +-- +-- Invariant: numbers <= WORD_MAXBOUND use the `NS` constructor +data Natural + = NS !Word# + | NB !BigNat + +instance Eq Natural where + (==) = naturalEq + (/=) = naturalNe + +instance Ord Natural where + compare = naturalCompare + + +-- | Check Natural invariants +naturalCheck# :: Natural -> Bool# +naturalCheck# (NS _) = 1# +naturalCheck# (NB bn) = bigNatCheck# bn &&# bigNatSize# bn ># 1# + +-- | Check Natural invariants +naturalCheck :: Natural -> Bool +naturalCheck !n = isTrue# (naturalCheck# n) + +-- | Zero Natural +naturalZero :: Natural +naturalZero = NS 0## + +-- | One Natural +naturalOne :: Natural +naturalOne = NS 1## + +-- | Test Zero Natural +naturalIsZero :: Natural -> Bool +naturalIsZero (NS 0##) = True +naturalIsZero _ = False + +-- | Test One Natural +naturalIsOne :: Natural -> Bool +naturalIsOne (NS 1##) = True +naturalIsOne _ = False + +-- | Indicate if the value is a power of two and which one +naturalIsPowerOf2# :: Natural -> (# () | Word# #) +naturalIsPowerOf2# (NS w) = wordIsPowerOf2# w +naturalIsPowerOf2# (NB w) = bigNatIsPowerOf2# w + +-- | Create a Natural from a BigNat (respect the invariants) +naturalFromBigNat :: BigNat -> Natural +naturalFromBigNat x = case bigNatSize# x of + 0# -> naturalZero + 1# -> NS (bigNatIndex# x 0#) + _ -> NB x + +-- | Convert a Natural into a BigNat +naturalToBigNat :: Natural -> BigNat +naturalToBigNat (NS w) = bigNatFromWord# w +naturalToBigNat (NB bn) = bn + +-- | Create a Natural from a Word# +naturalFromWord# :: Word# -> Natural +{-# NOINLINE naturalFromWord# #-} +naturalFromWord# x = NS x + +-- | Convert two Word# (most-significant first) into a Natural +naturalFromWord2# :: Word# -> Word# -> Natural +naturalFromWord2# 0## 0## = naturalZero +naturalFromWord2# 0## n = NS n +naturalFromWord2# w1 w2 = NB (bigNatFromWord2# w2 w1) + +-- | Create a Natural from a Word +naturalFromWord :: Word -> Natural +naturalFromWord (W# x) = NS x + +-- | Create a Natural from a list of Word +naturalFromWordList :: [Word] -> Natural +naturalFromWordList xs = naturalFromBigNat (bigNatFromWordList xs) + +-- | Convert the lower bits of a Natural into a Word# +naturalToWord# :: Natural -> Word# +{-# NOINLINE naturalToWord# #-} +naturalToWord# (NS x) = x +naturalToWord# (NB b) = bigNatIndex# b 0# + +-- | Convert the lower bits of a Natural into a Word +naturalToWord :: Natural -> Word +naturalToWord !n = W# (naturalToWord# n) + + +-- | Try downcasting 'Natural' to 'Word' value. +-- Returns '()' if value doesn't fit in 'Word'. +naturalToWordMaybe# :: Natural -> (# Word# | () #) +naturalToWordMaybe# (NS w) = (# w | #) +naturalToWordMaybe# _ = (# | () #) + +-- | Create a Natural from an Int# (unsafe: silently converts negative values +-- into positive ones) +naturalFromIntUnsafe# :: Int# -> Natural +naturalFromIntUnsafe# !i = NS (int2Word# i) + +-- | Create a Natural from an Int (unsafe: silently converts negative values +-- into positive ones) +naturalFromIntUnsafe :: Int -> Natural +naturalFromIntUnsafe (I# i) = naturalFromIntUnsafe# i + +-- | Create a Natural from an Int# +-- +-- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. +naturalFromIntThrow# :: Int# -> Natural +naturalFromIntThrow# i + | isTrue# (i <# 0#) = case underflow of _ -> NS 0## + | True = naturalFromIntUnsafe# i + +-- | Create a Natural from an Int +-- +-- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. +naturalFromIntThrow :: Int -> Natural +naturalFromIntThrow (I# i) = naturalFromIntThrow# i + +-- | Create an Int# from a Natural (can overflow the int and give a negative +-- number) +naturalToInt# :: Natural -> Int# +naturalToInt# !n = word2Int# (naturalToWord# n) + +-- | Create an Int# from a Natural (can overflow the int and give a negative +-- number) +naturalToInt :: Natural -> Int +naturalToInt !n = I# (naturalToInt# n) + +-- | Create a Natural from an Int# +-- +-- Underflow exception if Int# is negative +naturalFromInt# :: Int# -> Natural +naturalFromInt# !i + | isTrue# (i >=# 0#) = NS (int2Word# i) + | True = case underflow of _ -> NS 0## + +-- | Create a Natural from an Int +-- +-- Underflow exception if Int# is negative +naturalFromInt :: Int -> Natural +naturalFromInt (I# i) = naturalFromInt# i + +-- | Encode (# Natural mantissa, Int# exponent #) into a Double# +naturalEncodeDouble# :: Natural -> Int# -> Double# +naturalEncodeDouble# (NS w) 0# = word2Double# w +naturalEncodeDouble# (NS w) e = wordEncodeDouble# w e +naturalEncodeDouble# (NB b) e = bigNatEncodeDouble# b e + +-- | Encode a Natural (mantissa) into a Double# +naturalToDouble# :: Natural -> Double# +naturalToDouble# !n = naturalEncodeDouble# n 0# + +-- | Encode an Natural (mantissa) into a Float# +naturalToFloat# :: Natural -> Float# +naturalToFloat# !i = naturalEncodeFloat# i 0# + +-- | Encode (# Natural mantissa, Int# exponent #) into a Float# +-- +-- TODO: Not sure if it's worth to write 'Float' optimized versions here +naturalEncodeFloat# :: Natural -> Int# -> Float# +naturalEncodeFloat# !m 0# = double2Float# (naturalToDouble# m) +naturalEncodeFloat# !m e = double2Float# (naturalEncodeDouble# m e) + +-- | Equality test for Natural +naturalEq# :: Natural -> Natural -> Bool# +naturalEq# (NS x) (NS y) = x `eqWord#` y +naturalEq# (NB x) (NB y) = bigNatEq# x y +naturalEq# _ _ = 0# + +-- | Equality test for Natural +naturalEq :: Natural -> Natural -> Bool +naturalEq !x !y = isTrue# (naturalEq# x y) + +-- | Inequality test for Natural +naturalNe# :: Natural -> Natural -> Bool# +naturalNe# (NS x) (NS y) = x `neWord#` y +naturalNe# (NB x) (NB y) = bigNatNe# x y +naturalNe# _ _ = 1# + +-- | Inequality test for Natural +naturalNe :: Natural -> Natural -> Bool +naturalNe !x !y = isTrue# (naturalNe# x y) + +-- | Compare two Natural +naturalCompare :: Natural -> Natural -> Ordering +naturalCompare (NS x) (NS y) = compare (W# x) (W# y) +naturalCompare (NB x) (NB y) = bigNatCompare x y +naturalCompare (NS _) (NB _) = LT +naturalCompare (NB _) (NS _) = GT + +-- | PopCount for Natural +naturalPopCount# :: Natural -> Word# +naturalPopCount# (NS x) = popCnt# x +naturalPopCount# (NB x) = bigNatPopCount# x + +-- | PopCount for Natural +naturalPopCount :: Natural -> Word +naturalPopCount (NS x) = W# (popCnt# x) +naturalPopCount (NB x) = bigNatPopCount x + +-- | Right shift for Natural +naturalShiftR# :: Natural -> Word# -> Natural +naturalShiftR# (NS x) n = NS (x `shiftRW#` n) +naturalShiftR# (NB x) n = naturalFromBigNat (x `bigNatShiftR#` n) + +-- | Right shift for Natural +naturalShiftR :: Natural -> Word -> Natural +naturalShiftR x (W# n) = naturalShiftR# x n + +-- | Left shift +naturalShiftL# :: Natural -> Word# -> Natural +naturalShiftL# (NS x) n + | isTrue# (clz# x `geWord#` n) = NS (x `uncheckedShiftL#` word2Int# n) + | True = NB (bigNatFromWord# x `bigNatShiftL#` n) +naturalShiftL# (NB x) n = NB (x `bigNatShiftL#` n) + +-- | Left shift +naturalShiftL :: Natural -> Word -> Natural +naturalShiftL !x (W# n) = naturalShiftL# x n + +-- | Add two naturals +naturalAdd :: Natural -> Natural -> Natural +{-# NOINLINE naturalAdd #-} +naturalAdd (NS x) (NB y) = NB (bigNatAddWord# y x) +naturalAdd (NB x) (NS y) = NB (bigNatAddWord# x y) +naturalAdd (NB x) (NB y) = NB (bigNatAdd x y) +naturalAdd (NS x) (NS y) = + case addWordC# x y of + (# l,0# #) -> NS l + (# l,c #) -> NB (bigNatFromWord2# (int2Word# c) l) + +-- | Sub two naturals +naturalSub :: Natural -> Natural -> (# () | Natural #) +{-# NOINLINE naturalSub #-} +naturalSub (NS _) (NB _) = (# () | #) +naturalSub (NB x) (NS y) = (# | naturalFromBigNat (bigNatSubWordUnsafe# x y) #) +naturalSub (NS x) (NS y) = + case subWordC# x y of + (# l,0# #) -> (# | NS l #) + (# _,_ #) -> (# () | #) +naturalSub (NB x) (NB y) = + case bigNatSub x y of + (# () | #) -> (# () | #) + (# | z #) -> (# | naturalFromBigNat z #) + +-- | Sub two naturals +-- +-- Throw an Underflow exception if x < y +naturalSubThrow :: Natural -> Natural -> Natural +naturalSubThrow (NS _) (NB _) = case underflow of _ -> NS 0## +naturalSubThrow (NB x) (NS y) = naturalFromBigNat (bigNatSubWordUnsafe# x y) +naturalSubThrow (NS x) (NS y) = + case subWordC# x y of + (# l,0# #) -> NS l + (# _,_ #) -> case underflow of _ -> NS 0## +naturalSubThrow (NB x) (NB y) = + case bigNatSub x y of + (# () | #) -> case underflow of _ -> NS 0## + (# | z #) -> naturalFromBigNat z + +-- | Sub two naturals +-- +-- Unsafe: don't check that x >= y +-- Undefined results if it happens +naturalSubUnsafe :: Natural -> Natural -> Natural +{-# NOINLINE naturalSubUnsafe #-} +naturalSubUnsafe (NS x) (NS y) = NS (minusWord# x y) +naturalSubUnsafe (NS _) (NB _) = naturalZero +naturalSubUnsafe (NB x) (NS y) = naturalFromBigNat (bigNatSubWordUnsafe# x y) +naturalSubUnsafe (NB x) (NB y) = + case bigNatSub x y of + (# () | #) -> naturalZero + (# | z #) -> naturalFromBigNat z + +-- | Multiplication +naturalMul :: Natural -> Natural -> Natural +{-# NOINLINE naturalMul #-} +naturalMul a b = case a of + NS 0## -> NS 0## + NS 1## -> b + NS x -> case b of + NS 0## -> NS 0## + NS 1## -> a + NS y -> case timesWord2# x y of + (# h,l #) -> naturalFromWord2# h l + NB y -> NB (bigNatMulWord# y x) + NB x -> case b of + NS 0## -> NS 0## + NS 1## -> a + NS y -> NB (bigNatMulWord# x y) + NB y -> NB (bigNatMul x y) + +-- | Square a Natural +naturalSqr :: Natural -> Natural +naturalSqr !a = naturalMul a a + +-- | Signum for Natural +naturalSignum :: Natural -> Natural +naturalSignum (NS 0##) = NS 0## +naturalSignum _ = NS 1## + +-- | Negate for Natural +naturalNegate :: Natural -> Natural +{-# NOINLINE naturalNegate #-} +naturalNegate (NS 0##) = NS 0## +naturalNegate _ = case underflow of _ -> NS 0## + +-- | Return division quotient and remainder +-- +-- Division by zero is handled by BigNat +naturalQuotRem# :: Natural -> Natural -> (# Natural, Natural #) +{-# NOINLINE naturalQuotRem# #-} +naturalQuotRem# (NS n) (NS d) = case quotRemWord# n d of + (# q, r #) -> (# NS q, NS r #) +naturalQuotRem# (NB n) (NS d) = case bigNatQuotRemWord# n d of + (# q, r #) -> (# naturalFromBigNat q, NS r #) +naturalQuotRem# (NS n) (NB d) = case bigNatQuotRem# (bigNatFromWord# n) d of + (# q, r #) -> (# naturalFromBigNat q, naturalFromBigNat r #) +naturalQuotRem# (NB n) (NB d) = case bigNatQuotRem# n d of + (# q, r #) -> (# naturalFromBigNat q, naturalFromBigNat r #) + +-- | Return division quotient and remainder +naturalQuotRem :: Natural -> Natural -> (Natural, Natural) +naturalQuotRem !n !d = case naturalQuotRem# n d of + (# q, r #) -> (q,r) + +-- | Return division quotient +naturalQuot :: Natural -> Natural -> Natural +{-# NOINLINE naturalQuot #-} +naturalQuot (NS n) (NS d) = case quotWord# n d of + q -> NS q +naturalQuot (NB n) (NS d) = case bigNatQuotWord# n d of + q -> naturalFromBigNat q +naturalQuot (NS n) (NB d) = case bigNatQuot (bigNatFromWord# n) d of + q -> naturalFromBigNat q +naturalQuot (NB n) (NB d) = case bigNatQuot n d of + q -> naturalFromBigNat q + +-- | Return division remainder +naturalRem :: Natural -> Natural -> Natural +{-# NOINLINE naturalRem #-} +naturalRem (NS n) (NS d) = case remWord# n d of + r -> NS r +naturalRem (NB n) (NS d) = case bigNatRemWord# n d of + r -> NS r +naturalRem (NS n) (NB d) = case bigNatRem (bigNatFromWord# n) d of + r -> naturalFromBigNat r +naturalRem (NB n) (NB d) = case bigNatRem n d of + r -> naturalFromBigNat r + +naturalAnd :: Natural -> Natural -> Natural +naturalAnd (NS n) (NS m) = NS (n `and#` m) +naturalAnd (NS n) (NB m) = NS (n `and#` bigNatToWord# m) +naturalAnd (NB n) (NS m) = NS (bigNatToWord# n `and#` m) +naturalAnd (NB n) (NB m) = naturalFromBigNat (bigNatAnd n m) + +naturalAndNot :: Natural -> Natural -> Natural +naturalAndNot (NS n) (NS m) = NS (n `and#` not# m) +naturalAndNot (NS n) (NB m) = NS (n `and#` not# (bigNatToWord# m)) +naturalAndNot (NB n) (NS m) = NS (bigNatToWord# n `and#` not# m) +naturalAndNot (NB n) (NB m) = naturalFromBigNat (bigNatAndNot n m) + +naturalOr :: Natural -> Natural -> Natural +naturalOr (NS n) (NS m) = NS (n `or#` m) +naturalOr (NS n) (NB m) = NB (bigNatOrWord# m n) +naturalOr (NB n) (NS m) = NB (bigNatOrWord# n m) +naturalOr (NB n) (NB m) = NB (bigNatOr n m) + +naturalXor :: Natural -> Natural -> Natural +naturalXor (NS n) (NS m) = NS (n `xor#` m) +naturalXor (NS n) (NB m) = NB (bigNatXorWord# m n) +naturalXor (NB n) (NS m) = NB (bigNatXorWord# n m) +naturalXor (NB n) (NB m) = naturalFromBigNat (bigNatXor n m) + +naturalTestBit# :: Natural -> Word# -> Bool# +naturalTestBit# (NS w) i = (i `ltWord#` WORD_SIZE_IN_BITS##) &&# + ((w `and#` (1## `uncheckedShiftL#` word2Int# i)) `neWord#` 0##) +naturalTestBit# (NB bn) i = bigNatTestBit# bn i + +naturalTestBit :: Natural -> Word -> Bool +naturalTestBit !n (W# i) = isTrue# (naturalTestBit# n i) + +naturalBit# :: Word# -> Natural +naturalBit# i + | isTrue# (i `ltWord#` WORD_SIZE_IN_BITS##) = NS (1## `uncheckedShiftL#` word2Int# i) + | True = NB (bigNatBit# i) + +naturalBit :: Word -> Natural +naturalBit (W# i) = naturalBit# i + +-- | Compute greatest common divisor. +naturalGcd :: Natural -> Natural -> Natural +naturalGcd (NS 0##) !y = y +naturalGcd x (NS 0##) = x +naturalGcd (NS 1##) _ = NS 1## +naturalGcd _ (NS 1##) = NS 1## +naturalGcd (NB x) (NB y) = naturalFromBigNat (bigNatGcd x y) +naturalGcd (NB x) (NS y) = NS (bigNatGcdWord# x y) +naturalGcd (NS x) (NB y) = NS (bigNatGcdWord# y x) +naturalGcd (NS x) (NS y) = NS (gcdWord# x y) + +-- | Compute least common multiple. +naturalLcm :: Natural -> Natural -> Natural +naturalLcm (NS 0##) !_ = NS 0## +naturalLcm _ (NS 0##) = NS 0## +naturalLcm (NS 1##) y = y +naturalLcm x (NS 1##) = x +naturalLcm (NS a ) (NS b ) = naturalFromBigNat (bigNatLcmWordWord# a b) +naturalLcm (NB a ) (NS b ) = naturalFromBigNat (bigNatLcmWord# a b) +naturalLcm (NS a ) (NB b ) = naturalFromBigNat (bigNatLcmWord# b a) +naturalLcm (NB a ) (NB b ) = naturalFromBigNat (bigNatLcm a b) + +-- | Base 2 logarithm +naturalLog2# :: Natural -> Word# +naturalLog2# (NS w) = wordLog2# w +naturalLog2# (NB b) = bigNatLog2# b + +-- | Base 2 logarithm +naturalLog2 :: Natural -> Word +naturalLog2 !n = W# (naturalLog2# n) + +-- | Logarithm for an arbitrary base +naturalLogBaseWord# :: Word# -> Natural -> Word# +naturalLogBaseWord# base (NS a) = wordLogBase# base a +naturalLogBaseWord# base (NB a) = bigNatLogBaseWord# base a + +-- | Logarithm for an arbitrary base +naturalLogBaseWord :: Word -> Natural -> Word +naturalLogBaseWord (W# base) !a = W# (naturalLogBaseWord# base a) + +-- | Logarithm for an arbitrary base +naturalLogBase# :: Natural -> Natural -> Word# +naturalLogBase# (NS base) !a = naturalLogBaseWord# base a +naturalLogBase# (NB _ ) (NS _) = 0## +naturalLogBase# (NB base) (NB a) = bigNatLogBase# base a + +-- | Logarithm for an arbitrary base +naturalLogBase :: Natural -> Natural -> Word +naturalLogBase !base !a = W# (naturalLogBase# base a) + +-- | \"@'naturalPowMod' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +naturalPowMod :: Natural -> Natural -> Natural -> Natural +naturalPowMod !_ !_ (NS 0##) = case divByZero of _ -> naturalZero +naturalPowMod _ _ (NS 1##) = NS 0## +naturalPowMod _ (NS 0##) _ = NS 1## +naturalPowMod (NS 0##) _ _ = NS 0## +naturalPowMod (NS 1##) _ _ = NS 1## +naturalPowMod (NS b) (NS e) (NS m) = NS (powModWord# b e m) +naturalPowMod b e (NS m) = NS (bigNatPowModWord# + (naturalToBigNat b) + (naturalToBigNat e) + m) +naturalPowMod b e (NB m) = naturalFromBigNat + (bigNatPowMod (naturalToBigNat b) + (naturalToBigNat e) + m) + +-- | Compute the number of digits of the Natural in the given base. +-- +-- `base` must be > 1 +naturalSizeInBase# :: Word# -> Natural -> Word# +naturalSizeInBase# base (NS w) = wordSizeInBase# base w +naturalSizeInBase# base (NB n) = bigNatSizeInBase# base n + +-- | Write a 'Natural' to @/addr/@ in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +naturalToAddr# :: Natural -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +naturalToAddr# (NS i) = wordToAddr# i +naturalToAddr# (NB n) = bigNatToAddr# n + +-- | Write a 'Natural' to @/addr/@ in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +naturalToAddr :: Natural -> Addr# -> Bool# -> IO Word +naturalToAddr a addr e = IO \s -> case naturalToAddr# a addr e s of + (# s', w #) -> (# s', W# w #) + + +-- | Read a Natural in base-256 representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +naturalFromAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, Natural #) +naturalFromAddr# sz addr e s = + case bigNatFromAddr# sz addr e s of + (# s', n #) -> (# s', naturalFromBigNat n #) + +-- | Read a Natural in base-256 representation from an Addr#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +naturalFromAddr :: Word# -> Addr# -> Bool# -> IO Natural +naturalFromAddr sz addr e = IO (naturalFromAddr# sz addr e) + + +-- | Write a Natural in base-256 representation and return the +-- number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +naturalToMutableByteArray# :: Natural -> MutableByteArray# s -> Word# -> Bool# -> State# s -> (# State# s, Word# #) +naturalToMutableByteArray# (NS w) = wordToMutableByteArray# w +naturalToMutableByteArray# (NB a) = bigNatToMutableByteArray# a + +-- | Read a Natural in base-256 representation from a ByteArray#. +-- +-- The size is given in bytes. +-- +-- The endianness is selected with the Bool# parameter: most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- Null higher limbs are automatically trimed. +naturalFromByteArray# :: Word# -> ByteArray# -> Word# -> Bool# -> State# s -> (# State# s, Natural #) +naturalFromByteArray# sz ba off e s = case bigNatFromByteArray# sz ba off e s of + (# s', a #) -> (# s', naturalFromBigNat a #) diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs-boot b/libraries/ghc-bignum/src/GHC/Num/Natural.hs-boot new file mode 100644 index 0000000000..28cf5d1771 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs-boot @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Num.Natural where + +import {-# SOURCE #-} GHC.Num.BigNat +import GHC.Num.Primitives +import GHC.Prim +import GHC.Types + +data Natural + = NS !Word# + | NB !BigNat + +naturalToWord# :: Natural -> Word# +naturalFromWord# :: Word# -> Natural +naturalToBigNat :: Natural -> BigNat +naturalFromBigNat :: BigNat -> Natural +naturalMul :: Natural -> Natural -> Natural +naturalRem :: Natural -> Natural -> Natural +naturalIsZero :: Natural -> Bool +naturalShiftR# :: Natural -> Word# -> Natural +naturalTestBit# :: Natural -> Word# -> Bool# diff --git a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs new file mode 100644 index 0000000000..2c1a0b6955 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BinaryLiterals #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} + +module GHC.Num.Primitives + ( + -- * Bool# + Bool# + , (&&#) + , (||#) + , notB# + -- * Int# + , testBitI# + , minI# + , maxI# + , sgnI# + , absI# + , cmpI# + , intEncodeDouble# + , popCntI# + -- * Word# + , andNot# + , cmpW# + , bitW# + , maxW# + , minW# + , testBitW# + , shiftRW# + , plusWord3# + , plusWord12# + , quotRemWord3# + , wordFromAbsInt# + , wordLog2# + , wordLogBase# + , wordSizeInBase# + , wordIsPowerOf2# + , wordEncodeDouble# + , wordReverseBits# + , wordReverseBits32# + , wordReverseBytes# + -- ** Addr import/export + , wordFromAddr# + , wordFromAddrLE# + , wordFromAddrBE# + , wordToAddr# + , wordToAddrLE# + , wordToAddrBE# + , wordWriteAddrLE# + , wordWriteAddrBE# + -- ** ByteArray import/export + , wordFromByteArray# + , wordFromByteArrayLE# + , wordFromByteArrayBE# + , wordToMutableByteArray# + , wordToMutableByteArrayLE# + , wordToMutableByteArrayBE# + , wordWriteMutableByteArrayLE# + , wordWriteMutableByteArrayBE# + -- * Exception + , underflow + , divByZero + , unexpectedValue + -- * IO + , ioWord# + , ioInt# + , ioVoid + , ioBool + ) +where + +#include "MachDeps.h" +#include "WordSize.h" + +-- Required for WORDS_BIGENDIAN +#include <ghcautoconf.h> + +#if (__GLASGOW_HASKELL__ < 811) +import GHC.Magic +#endif + +import GHC.Prim +import GHC.Types +import GHC.Tuple () -- See Note [Depend on GHC.Tuple] in GHC.Base + +default () + +---------------------------------- +-- Bool# +---------------------------------- + +type Bool# = Int# + +(&&#) :: Bool# -> Bool# -> Bool# +(&&#) = andI# + +(||#) :: Bool# -> Bool# -> Bool# +(||#) = orI# + +notB# :: Bool# -> Bool# +notB# x = x `xorI#` 1# + +infixr 3 &&# +infixr 2 ||# + + +---------------------------------- +-- Int# +---------------------------------- + +-- | Branchless `abs` +absI# :: Int# -> Int# +absI# i# = (i# `xorI#` nsign) -# nsign + where + -- nsign = negateInt# (i# <# 0#) + nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#) + +-- | Branchless `signum` +sgnI# :: Int# -> Int# +sgnI# x# = (x# ># 0#) -# (x# <# 0#) + +-- | Population count +popCntI# :: Int# -> Word# +popCntI# i = popCnt# (int2Word# i) + +-- | Branchless comparison +cmpI# :: Int# -> Int# -> Int# +cmpI# x# y# = (x# ># y#) -# (x# <# y#) + +testBitI# :: Int# -> Word# -> Bool# +testBitI# x i = ((uncheckedIShiftL# 1# (word2Int# i)) `andI#` x) /=# 0# + +minI# :: Int# -> Int# -> Int# +minI# x y | isTrue# (x <=# y) = x + | True = y + +maxI# :: Int# -> Int# -> Int# +maxI# x y | isTrue# (x >=# y) = x + | True = y + +-- | Encode (# Int# mantissa, Int# exponent #) into a Double#. +-- +-- (provided by GHC's RTS) +foreign import ccall unsafe "__int_encodeDouble" + intEncodeDouble# :: Int# -> Int# -> Double# + +---------------------------------- +-- Word# +---------------------------------- + +andNot# :: Word# -> Word# -> Word# +andNot# x y = x `and#` (not# y) + +cmpW# :: Word# -> Word# -> Ordering +{-# INLINE cmpW# #-} +cmpW# x# y# + | isTrue# (x# `ltWord#` y#) = LT + | isTrue# (x# `eqWord#` y#) = EQ + | True = GT + +-- | Return the absolute value of the Int# in a Word# +wordFromAbsInt# :: Int# -> Word# +wordFromAbsInt# i + | isTrue# (i >=# 0#) = int2Word# i + | True = int2Word# (negateInt# i) + +minW# :: Word# -> Word# -> Word# +minW# x# y# | isTrue# (x# `leWord#` y#) = x# + | True = y# + +maxW# :: Word# -> Word# -> Word# +maxW# x# y# | isTrue# (x# `gtWord#` y#) = x# + | True = y# + +bitW# :: Int# -> Word# +bitW# k = 1## `uncheckedShiftL#` k + +testBitW# :: Word# -> Word# -> Bool# +testBitW# w k = w `and#` (1## `uncheckedShiftL#` word2Int# k) `neWord#` 0## + +-- | Safe right shift for Word# +shiftRW# :: Word# -> Word# -> Word# +shiftRW# a b + | isTrue# (b `geWord#` WORD_SIZE_IN_BITS##) = 0## + | True = a `uncheckedShiftRL#` (word2Int# b) + +-- | (h,l) <- a + (hb,lb) +plusWord12# :: Word# -> (# Word#,Word# #) -> (# Word#,Word# #) +{-# INLINABLE plusWord12# #-} +plusWord12# a0 (# b1,b0 #) = (# m1, m0 #) + where + !(# t, m0 #) = plusWord2# a0 b0 + !m1 = plusWord# t b1 + +-- | Add 3 values together +plusWord3# :: Word# -> Word# -> Word# -> (# Word#, Word# #) +{-# INLINABLE plusWord3# #-} +plusWord3# a b c = (# r1, r0 #) + where + !(# t1, t0 #) = plusWord2# a b + !(# t2, r0 #) = plusWord2# t0 c + !r1 = plusWord# t1 t2 + + +-- | 2-by-1 large division +-- +-- Requires: +-- b0 /= 0 +-- a1 >= b0 (not required, but if not q1=0) +quotRemWord3# :: (# Word#,Word# #) -> Word# -> (# (# Word#,Word# #),Word# #) +quotRemWord3# (# a1,a0 #) b0 = (# (# q1, q0 #), r0 #) + where + !(# q1, r' #) = quotRemWord# a1 b0 + !(# q0, r0 #) = quotRemWord2# r' a0 b0 + + + +-- | Encode (# Word# mantissa, Int# exponent #) into a Double#. +-- +-- (provided by GHC's RTS) +foreign import ccall unsafe "__word_encodeDouble" + wordEncodeDouble# :: Word# -> Int# -> Double# + +-- | Compute base-2 log of 'Word#' +-- +-- This is internally implemented as count-leading-zeros machine instruction. +wordLog2# :: Word# -> Word# +wordLog2# w = (WORD_SIZE_IN_BITS## `minusWord#` 1##) `minusWord#` (clz# w) + +-- | Logarithm for an arbitrary base +wordLogBase# :: Word# -> Word# -> Word# +wordLogBase# base a + | isTrue# (base `leWord#` 1##) + = case unexpectedValue of _ -> 0## + + | 2## <- base + = wordLog2# a + + | True + = case go base of (# _, e' #) -> e' + where + goSqr pw = case timesWord2# pw pw of + (# 0##, l #) -> go l + (# _ , _ #) -> (# a, 0## #) + go pw = if isTrue# (a `ltWord#` pw) + then (# a, 0## #) + else case goSqr pw of + (# q, e #) -> if isTrue# (q `ltWord#` pw) + then (# q, 2## `timesWord#` e #) + else (# q `quotWord#` pw + , 2## `timesWord#` e `plusWord#` 1## #) + +wordSizeInBase# :: Word# -> Word# -> Word# +wordSizeInBase# _ 0## = 0## +wordSizeInBase# base w = 1## `plusWord#` wordLogBase# base w + +-- | Indicate if the value is a power of two and which one +wordIsPowerOf2# :: Word# -> (# () | Word# #) +wordIsPowerOf2# w + | isTrue# (popCnt# w `neWord#` 1##) = (# () | #) + | True = (# | ctz# w #) + +-- | Reverse bytes in a Word# +wordReverseBytes# :: Word# -> Word# +wordReverseBytes# x0 = r + where +#if WORD_SIZE_IN_BITS == 64 + x1 = ((x0 `and#` 0x00FF00FF00FF00FF##) `uncheckedShiftL#` 8#) `or#` ((x0 `and#` 0xFF00FF00FF00FF00##) `uncheckedShiftRL#` 8#) + x2 = ((x1 `and#` 0x0000FFFF0000FFFF##) `uncheckedShiftL#` 16#) `or#` ((x1 `and#` 0xFFFF0000FFFF0000##) `uncheckedShiftRL#` 16#) + r = ((x2 `and#` 0x00000000FFFFFFFF##) `uncheckedShiftL#` 32#) `or#` ((x2 `and#` 0xFFFFFFFF00000000##) `uncheckedShiftRL#` 32#) +#else + x1 = ((x0 `and#` 0x00FF00FF##) `uncheckedShiftL#` 8#) `or#` ((x0 `and#` 0xFF00FF00##) `uncheckedShiftRL#` 8#) + r = ((x1 `and#` 0x0000FFFF##) `uncheckedShiftL#` 16#) `or#` ((x1 `and#` 0xFFFF0000##) `uncheckedShiftRL#` 16#) +#endif + + +-- | Reverse bits in a Word# +wordReverseBits# :: Word# -> Word# +wordReverseBits# x0 = r + where +#if WORD_SIZE_IN_BITS == 64 + x1 = ((x0 `and#` 0x5555555555555555##) `uncheckedShiftL#` 1#) `or#` ((x0 `and#` 0xAAAAAAAAAAAAAAAA##) `uncheckedShiftRL#` 1#) + x2 = ((x1 `and#` 0x3333333333333333##) `uncheckedShiftL#` 2#) `or#` ((x1 `and#` 0xCCCCCCCCCCCCCCCC##) `uncheckedShiftRL#` 2#) + x3 = ((x2 `and#` 0x0F0F0F0F0F0F0F0F##) `uncheckedShiftL#` 4#) `or#` ((x2 `and#` 0xF0F0F0F0F0F0F0F0##) `uncheckedShiftRL#` 4#) + x4 = ((x3 `and#` 0x00FF00FF00FF00FF##) `uncheckedShiftL#` 8#) `or#` ((x3 `and#` 0xFF00FF00FF00FF00##) `uncheckedShiftRL#` 8#) + x5 = ((x4 `and#` 0x0000FFFF0000FFFF##) `uncheckedShiftL#` 16#) `or#` ((x4 `and#` 0xFFFF0000FFFF0000##) `uncheckedShiftRL#` 16#) + r = ((x5 `and#` 0x00000000FFFFFFFF##) `uncheckedShiftL#` 32#) `or#` ((x5 `and#` 0xFFFFFFFF00000000##) `uncheckedShiftRL#` 32#) +#else + x1 = ((x0 `and#` 0x55555555##) `uncheckedShiftL#` 1#) `or#` ((x0 `and#` 0xAAAAAAAA##) `uncheckedShiftRL#` 1#) + x2 = ((x1 `and#` 0x33333333##) `uncheckedShiftL#` 2#) `or#` ((x1 `and#` 0xCCCCCCCC##) `uncheckedShiftRL#` 2#) + x3 = ((x2 `and#` 0x0F0F0F0F##) `uncheckedShiftL#` 4#) `or#` ((x2 `and#` 0xF0F0F0F0##) `uncheckedShiftRL#` 4#) + x4 = ((x3 `and#` 0x00FF00FF##) `uncheckedShiftL#` 8#) `or#` ((x3 `and#` 0xFF00FF00##) `uncheckedShiftRL#` 8#) + r = ((x4 `and#` 0x0000FFFF##) `uncheckedShiftL#` 16#) `or#` ((x4 `and#` 0xFFFF0000##) `uncheckedShiftRL#` 16#) +#endif + +-- | Reverse bits in the Word32 subwords composing a Word# +wordReverseBits32# :: Word# -> Word# +#if WORD_SIZE_IN_BITS == 64 +wordReverseBits32# x0 = r + where + x1 = ((x0 `and#` 0x5555555555555555##) `uncheckedShiftL#` 1#) `or#` ((x0 `and#` 0xAAAAAAAAAAAAAAAA##) `uncheckedShiftRL#` 1#) + x2 = ((x1 `and#` 0x3333333333333333##) `uncheckedShiftL#` 2#) `or#` ((x1 `and#` 0xCCCCCCCCCCCCCCCC##) `uncheckedShiftRL#` 2#) + x3 = ((x2 `and#` 0x0F0F0F0F0F0F0F0F##) `uncheckedShiftL#` 4#) `or#` ((x2 `and#` 0xF0F0F0F0F0F0F0F0##) `uncheckedShiftRL#` 4#) + x4 = ((x3 `and#` 0x00FF00FF00FF00FF##) `uncheckedShiftL#` 8#) `or#` ((x3 `and#` 0xFF00FF00FF00FF00##) `uncheckedShiftRL#` 8#) + r = ((x4 `and#` 0x0000FFFF0000FFFF##) `uncheckedShiftL#` 16#) `or#` ((x4 `and#` 0xFFFF0000FFFF0000##) `uncheckedShiftRL#` 16#) +#else +wordReverseBits32# x0 = wordReverseBits# x0 +#endif + + +-- | Write a Word to @/addr/@ in base-256 little-endian representation and +-- return the number of bytes written. +wordToAddrLE# :: Word# -> Addr# -> State# s -> (# State# s, Word# #) +wordToAddrLE# x addr = go x 0# + where + go w c s + | 0## <- w + = (# s, int2Word# c #) + + | True + = case writeWord8OffAddr# addr c (w `and#` 0xFF##) s of + s' -> go (w `uncheckedShiftRL#` 8#) (c +# 1#) s' + +-- | Write a Word to @/addr/@ in base-256 big-endian representation and +-- return the number of bytes written. +wordToAddrBE# :: Word# -> Addr# -> State# s -> (# State# s, Word# #) +wordToAddrBE# w addr = go 0# (WORD_SIZE_IN_BITS# -# clz) + where + !clz = word2Int# (clz# w `and#` (not# 0b0111##)) -- keep complete bytes + + go c sh s + | 0# <- sh + = (# s, int2Word# c #) + + | True + , w' <- (w `uncheckedShiftRL#` (sh -# 8#)) `and#` 0xFF## + = case writeWord8OffAddr# addr c w' s of + s' -> go (c +# 1#) (sh -# 8#) s' + +-- | Write a Word to @/addr/@ in base-256 representation and +-- return the number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +wordToAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +wordToAddr# a addr 0# s = wordToAddrLE# a addr s +wordToAddr# a addr _ s = wordToAddrBE# a addr s + + +-- | Read a Word from @/addr/@ in base-256 little-endian representation. +-- +-- @'n' is the number of bytes to read. +wordFromAddrLE# :: Word# -> Addr# -> State# s -> (# State# s, Word# #) +wordFromAddrLE# n addr s + -- Optimize when we read a full word + | WORD_SIZE_IN_BYTES## <- n + = case readWordOffAddr# addr 0# s of +#if defined(WORDS_BIGENDIAN) + (# s', w #) -> (# s', wordReverseBytes# w #) +#else + (# s', w #) -> (# s', w #) +#endif + +wordFromAddrLE# n addr s0 = go 0## 0# s0 + where + go w c s + | isTrue# (c ==# word2Int# n) + = (# s, w #) + + | True + = case readWord8OffAddr# addr c s of + (# s', b #) -> go (w `or#` (b `uncheckedShiftL#` (c `uncheckedIShiftL#` 3#))) + (c +# 1#) + s' + +-- | Read a Word from @/addr/@ in base-256 big-endian representation. +-- +-- @'n' is the number of bytes to read. +wordFromAddrBE# :: Word# -> Addr# -> State# s -> (# State# s, Word# #) +wordFromAddrBE# n addr s + -- Optimize when we read a full word + | WORD_SIZE_IN_BYTES## <- n + = case readWordOffAddr# addr 0# s of +#if defined(WORDS_BIGENDIAN) + (# s', w #) -> (# s', w #) +#else + (# s', w #) -> (# s', wordReverseBytes# w #) +#endif + +wordFromAddrBE# n addr s0 = go 0## 0# s0 + where + go w c s + | isTrue# (c ==# word2Int# n) + = (# s, w #) + + | True + = case readWord8OffAddr# addr c s of + (# s', b #) -> go ((w `uncheckedShiftL#` 8#) `or#` b) + (c +# 1#) + s' + +-- | Read a Word from @/addr/@ in base-256 representation. +-- +-- @'n' is the number of bytes to read. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +wordFromAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +wordFromAddr# a addr 0# s = wordFromAddrLE# a addr s +wordFromAddr# a addr _ s = wordFromAddrBE# a addr s + + + +-- | Write a full word with little-endian encoding +wordWriteAddrLE# :: Word# -> Addr# -> State# s -> State# s +wordWriteAddrLE# w addr = writeWordOffAddr# addr 0# +#if defined(WORDS_BIGENDIAN) + (wordReverseBytes# w) +#else + w +#endif + +-- | Write a full word with little-endian encoding +wordWriteAddrBE# :: Word# -> Addr# -> State# s -> State# s +wordWriteAddrBE# w addr = writeWordOffAddr# addr 0# +#if defined(WORDS_BIGENDIAN) + w +#else + (wordReverseBytes# w) +#endif + +-- | Write a Word to @/MutableByteArray/@ in base-256 little-endian +-- representation and return the number of bytes written. +-- +-- The offset is in bytes. +wordToMutableByteArrayLE# :: Word# -> MutableByteArray# s -> Word# -> State# s -> (# State# s, Word# #) +wordToMutableByteArrayLE# x mba off = go x 0# + where + go w c s + | 0## <- w + = (# s, int2Word# c #) + + | True + = case writeWord8Array# mba (word2Int# off +# c) (w `and#` 0xFF##) s of + s' -> go (w `uncheckedShiftRL#` 8#) (c +# 1#) s' + +-- | Write a Word to @/MutableByteArray/@ in base-256 big-endian representation and +-- return the number of bytes written. +-- +-- The offset is in bytes. +wordToMutableByteArrayBE# :: Word# -> MutableByteArray# s -> Word# -> State# s -> (# State# s, Word# #) +wordToMutableByteArrayBE# w mba off = go 0# (WORD_SIZE_IN_BITS# -# clz) + where + !clz = word2Int# (clz# w `and#` (not# 0b0111##)) -- keep complete bytes + + go c sh s + | 0# <- sh + = (# s, int2Word# c #) + + | True + , w' <- (w `uncheckedShiftRL#` (sh -# 8#)) `and#` 0xFF## + = case writeWord8Array# mba (word2Int# off +# c) w' s of + s' -> go (c +# 1#) (sh -# 8#) s' + +-- | Write a Word to @/MutableByteArray/@ in base-256 representation and +-- return the number of bytes written. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +-- +-- The offset is in bytes. +wordToMutableByteArray# :: Word# -> MutableByteArray# s -> Word# -> Bool# -> State# s -> (# State# s, Word# #) +wordToMutableByteArray# a mba off 0# s = wordToMutableByteArrayLE# a mba off s +wordToMutableByteArray# a mba off _ s = wordToMutableByteArrayBE# a mba off s + +-- | Write a full word with little-endian encoding +wordWriteMutableByteArrayLE# :: Word# -> MutableByteArray# s -> Word# -> State# s -> State# s +wordWriteMutableByteArrayLE# w mba off = writeWord8ArrayAsWord# mba (word2Int# off) +#if defined(WORDS_BIGENDIAN) + (wordReverseBytes# w) +#else + w +#endif + +-- | Write a full word with little-endian encoding +wordWriteMutableByteArrayBE# :: Word# -> MutableByteArray# s -> Word# -> State# s -> State# s +wordWriteMutableByteArrayBE# w mba off = writeWord8ArrayAsWord# mba (word2Int# off) +#if defined(WORDS_BIGENDIAN) + w +#else + (wordReverseBytes# w) +#endif + +-- | Read a Word from @/ByteArray/@ in base-256 little-endian representation. +-- +-- @'n' is the number of bytes to read. +wordFromByteArrayLE# :: Word# -> ByteArray# -> Word# -> Word# +wordFromByteArrayLE# n ba off = + case n of + -- Optimize when we read a full word + WORD_SIZE_IN_BYTES## -> case indexWord8ArrayAsWord# ba (word2Int# off) of +#if defined(WORDS_BIGENDIAN) + w -> wordReverseBytes# w +#else + w -> w +#endif + + _ -> let + go w c + | isTrue# (c ==# word2Int# n) + = w + + | True + = case indexWord8Array# ba (word2Int# off +# c) of + b -> go (w `or#` (b `uncheckedShiftL#` (c `uncheckedIShiftL#` 3#))) + (c +# 1#) + in go 0## 0# + +-- | Read a Word from @/ByteArray/@ in base-256 big-endian representation. +-- +-- @'n' is the number of bytes to read. +wordFromByteArrayBE# :: Word# -> ByteArray# -> Word# -> Word# +wordFromByteArrayBE# n ba off + -- Optimize when we read a full word + | WORD_SIZE_IN_BYTES## <- n + = case indexWord8ArrayAsWord# ba (word2Int# off) of +#if defined(WORDS_BIGENDIAN) + w -> w +#else + w -> wordReverseBytes# w +#endif + +wordFromByteArrayBE# n ba off = go 0## 0# + where + go w c + | isTrue# (c ==# word2Int# n) + = w + + | True + = case indexWord8Array# ba (word2Int# off +# c) of + b -> go ((w `uncheckedShiftL#` 8#) `or#` b) (c +# 1#) + +-- | Read a Word from @/ByteArray/@ in base-256 representation. +-- +-- @'n' is the number of bytes to read. +-- +-- The endianness is selected with the Bool# parameter: write most significant +-- byte first (big-endian) if @1#@ or least significant byte first +-- (little-endian) if @0#@. +wordFromByteArray# :: Word# -> ByteArray# -> Word# -> Bool# -> Word# +wordFromByteArray# a ba off 0# = wordFromByteArrayLE# a ba off +wordFromByteArray# a ba off _ = wordFromByteArrayBE# a ba off + +---------------------------------- +-- IO +---------------------------------- + +ioVoid :: IO a -> State# RealWorld -> State# RealWorld +ioVoid (IO io) s = case io s of + (# s', _ #) -> s' + +ioWord# :: IO Word -> State# RealWorld -> (# State# RealWorld, Word# #) +ioWord# (IO io) s = case io s of + (# s', W# w #) -> (# s', w #) + +ioInt# :: IO Int -> State# RealWorld -> (# State# RealWorld, Int# #) +ioInt# (IO io) s = case io s of + (# s', I# i #) -> (# s', i #) + +ioBool :: IO Bool -> State# RealWorld -> (# State# RealWorld, Bool# #) +ioBool (IO io) s = case io s of + (# s', False #) -> (# s', 0# #) + (# s', True #) -> (# s', 1# #) + + +---------------------------------- +-- Exception +---------------------------------- + +#if (__GLASGOW_HASKELL__ >= 811) + +underflow :: a +underflow = raiseUnderflow# void# + +divByZero :: a +divByZero = raiseDivZero# void# + +unexpectedValue :: a +unexpectedValue = raiseOverflow# void# + +#else + +-- Before GHC 8.11 we use the exception trick taken from #14664 +exception :: a +exception = runRW# \s -> + case atomicLoop s of + (# _, a #) -> a + where + atomicLoop s = atomically# atomicLoop s + +underflow :: a +underflow = exception + +divByZero :: a +divByZero = exception + +unexpectedValue :: a +unexpectedValue = exception + +#endif diff --git a/libraries/ghc-bignum/src/GHC/Num/WordArray.hs b/libraries/ghc-bignum/src/GHC/Num/WordArray.hs new file mode 100644 index 0000000000..78c450b55e --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/WordArray.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module GHC.Num.WordArray where + +import GHC.Prim +import GHC.Magic +import GHC.Types +import GHC.Num.Primitives + +#include "MachDeps.h" +#include "WordSize.h" + +default () + +-- | Unlifted array of Word +type WordArray# = ByteArray# +type MutableWordArray# = MutableByteArray# + +data WordArray = WordArray WordArray# +data MutableWordArray s = MutableWordArray (MutableWordArray# s) + +-- | Convert limb count into byte count +wordsToBytes# :: Int# -> Int# +wordsToBytes# i = i `uncheckedIShiftL#` WORD_SIZE_BYTES_SHIFT# + +-- | Convert byte count into limb count +bytesToWords# :: Int# -> Int# +bytesToWords# i = i `uncheckedIShiftRL#` WORD_SIZE_BYTES_SHIFT# + + +-- | Create a new WordArray# of the given size (*in Word#*) and apply the +-- action to it before returning it frozen +withNewWordArray# + :: Int# -- ^ Size in Word + -> (MutableWordArray# RealWorld -> State# RealWorld -> State# RealWorld) + -> WordArray# +withNewWordArray# sz act = case runRW# io of (# _, a #) -> a + where + io s = + case newWordArray# sz s of { (# s, mwa #) -> + case act mwa s of { s -> + unsafeFreezeByteArray# mwa s + }} + +-- | Create two new WordArray# of the given sizes (*in Word#*) and apply the +-- action to them before returning them frozen +withNewWordArray2# + :: Int# -- ^ Size in Word + -> Int# -- ^ Ditto + -> (MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> State# RealWorld + -> State# RealWorld) + -> (# WordArray#, WordArray# #) +withNewWordArray2# sz1 sz2 act = case runRW# io of (# _, a #) -> a + where + io s = + case newWordArray# sz1 s of { (# s, mwa1 #) -> + case newWordArray# sz2 s of { (# s, mwa2 #) -> + case act mwa1 mwa2 s of { s -> + case unsafeFreezeByteArray# mwa1 s of { (# s, wa1 #) -> + case unsafeFreezeByteArray# mwa2 s of { (# s, wa2 #) -> + (# s, (# wa1, wa2 #) #) + }}}}} + +-- | Create a new WordArray# +newWordArray# :: Int# -> State# s -> (# State# s, MutableWordArray# s #) +newWordArray# sz s = newByteArray# (wordsToBytes# sz) s + +-- | Create a new WordArray# of the given size (*in Word#*), apply the action to +-- it, trim its most significant zeroes, then return it frozen +withNewWordArrayTrimed# + :: Int# -- ^ Size in Word + -> (MutableWordArray# RealWorld -> State# RealWorld -> State# RealWorld) + -> WordArray# +withNewWordArrayTrimed# sz act = withNewWordArray# sz \mwa s -> + case act mwa s of + s' -> mwaTrimZeroes# mwa s' + +-- | Create two new WordArray# of the given sizes (*in Word#*), apply the action +-- to them, trim their most significant zeroes, then return them frozen +withNewWordArray2Trimed# + :: Int# -- ^ Size in Word + -> Int# -- ^ Ditto + -> (MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> State# RealWorld + -> State# RealWorld) + -> (# WordArray#, WordArray# #) +withNewWordArray2Trimed# sz1 sz2 act = withNewWordArray2# sz1 sz2 \mwa1 mwa2 s -> + case act mwa1 mwa2 s of + s' -> case mwaTrimZeroes# mwa1 s' of + s'' -> mwaTrimZeroes# mwa2 s'' + +-- | Create a new WordArray# of the given size (*in Word#*), apply the action to +-- it. If the action returns true#, trim its most significant zeroes, then +-- return it frozen. Otherwise, return (). +withNewWordArrayTrimedMaybe# + :: Int# -- ^ Size in Word + -> (MutableWordArray# RealWorld -> State# RealWorld -> (# State# RealWorld, Bool# #)) + -> (# () | WordArray# #) +withNewWordArrayTrimedMaybe# sz act = case runRW# io of (# _, a #) -> a + where + io s = + case newWordArray# sz s of + (# s, mwa #) -> case act mwa s of + (# s, 0# #) -> (# s, (# () | #) #) + (# s, _ #) -> case mwaTrimZeroes# mwa s of + s -> case unsafeFreezeByteArray# mwa s of + (# s, ba #) -> (# s, (# | ba #) #) + +-- | Create a WordArray# from two Word# +-- +-- `byteArrayFromWord2# msw lsw = lsw:msw` +wordArrayFromWord2# :: Word# -> Word# -> WordArray# +wordArrayFromWord2# msw lsw = + withNewWordArray# 2# \mwa s -> + case mwaWrite# mwa 0# lsw s of + s -> mwaWrite# mwa 1# msw s + +-- | Create a WordArray# from one Word# +wordArrayFromWord# :: Word# -> WordArray# +wordArrayFromWord# w = + withNewWordArray# 1# \mwa s -> + mwaWrite# mwa 0# w s + +-- | Word array size +wordArraySize# :: WordArray# -> Int# +wordArraySize# ba = bytesToWords# (sizeofByteArray# ba) + + +-- | Equality test for WordArray# + +-- | Get size in Words +mwaSize# :: MutableWordArray# s-> State# s -> (# State# s, Int# #) +mwaSize# mba s = case getSizeofMutableByteArray# mba s of + (# s2, sz #) -> (# s2, bytesToWords# sz #) + +-- | Get the last Word (must be non empty!) +wordArrayLast# :: WordArray# -> Word# +wordArrayLast# a = indexWordArray# a (wordArraySize# a -# 1#) + +-- | Copy Words from a WordArray +-- +-- Don't do anything if the number of words to copy is <= 0 +mwaArrayCopy# :: MutableByteArray# s -> Int# -> WordArray# -> Int# -> Int# -> State# s -> State# s +mwaArrayCopy# dst dstIdx src srcIdx n s + | isTrue# (n <=# 0#) = s + | True = copyByteArray# + src (wordsToBytes# srcIdx) + dst (wordsToBytes# dstIdx) + (wordsToBytes# n) s + +-- | Shrink last words of a WordArray +mwaShrink# :: MutableByteArray# s -> Int# -> State# s -> State# s +mwaShrink# _mwa 0# s = s +mwaShrink# mwa i s = + case mwaSize# mwa s of + (# s, n #) -> shrinkMutableByteArray# mwa (wordsToBytes# (n -# i)) s + +-- | Set size +mwaSetSize# :: MutableByteArray# s -> Int# -> State# s -> State# s +mwaSetSize# mwa n s = shrinkMutableByteArray# mwa (wordsToBytes# n) s + +-- | Copy the WordArray into the MWA and shrink the size of MWA to the one of +-- the WordArray +mwaInitCopyShrink# :: MutableByteArray# s -> WordArray# -> State# s -> State# s +mwaInitCopyShrink# mwa wa s = + case mwaArrayCopy# mwa 0# wa 0# (wordArraySize# wa) s of + s -> mwaSetSize# mwa (wordArraySize# wa) s + +-- | Trim ending zeroes +mwaTrimZeroes# :: MutableByteArray# s -> State# s -> State# s +mwaTrimZeroes# mwa s1 = + case mwaClz mwa s1 of + (# s2, 0# #) -> s2 + (# s2, c #) -> mwaShrink# mwa c s2 + +-- | Count leading zero Words +mwaClz :: MutableWordArray# s -> State# s -> (# State# s, Int# #) +mwaClz mwa s1 = case mwaSize# mwa s1 of + (# s2,sz #) -> mwaClzAt mwa (sz -# 1#) s2 + +-- | Count leading zero Words starting at given position +mwaClzAt :: MutableWordArray# s -> Int# -> State# s -> (# State# s, Int# #) +mwaClzAt mwa = go 0# + where + go c i s + | isTrue# (i <# 0#) = (# s, c #) + | True = case readWordArray# mwa i s of + (# s', 0## #) -> go (c +# 1#) (i -# 1#) s' + (# s', _ #) -> (# s', c #) + +-- | Count leading zero Words starting at given position +waClzAt :: WordArray# -> Int# -> Int# +waClzAt wa = go 0# + where + go c i + | isTrue# (i <# 0#) + = c + + | 0## <- indexWordArray# wa i + = go (c +# 1#) (i -# 1#) + + | True + = c + +-- | Compare the most signiciant limbs of a and b. The comparison stops (i.e. +-- returns EQ) when there isn't enough lims in a or b to perform another +-- comparison. +wordArrayCompareMSWords :: WordArray# -> WordArray# -> Ordering +wordArrayCompareMSWords wa wb + | 0# <- szA + , 0# <- szB + = EQ + + | 0# <- szA + = LT + + | 0# <- szB + = GT + + | True + = go (szA -# 1#) (szB -# 1#) + where + szA = wordArraySize# wa + szB = wordArraySize# wb + + go i j + | isTrue# (i <# 0#) = EQ + | isTrue# (j <# 0#) = EQ + | True = + let + a = indexWordArray# wa i + b = indexWordArray# wb j + in if | isTrue# (a `gtWord#` b) -> GT + | isTrue# (b `gtWord#` a) -> LT + | True -> go (i -# 1#) (j -# 1#) + + +-- | Compute MutableWordArray <- WordArray + Word +-- +-- The MutableWordArray may not be initialized and will be erased anyway. +-- +-- Input: Size(MutableWordArray) = Size(WordArray) + 1 +-- Output: Size(MutableWordArray) = Size(WordArray) [+ 1] +mwaInitArrayPlusWord :: MutableWordArray# s -> WordArray# -> Word# -> State# s -> State#s +mwaInitArrayPlusWord mwa wa = go 0# + where + sz = wordArraySize# wa + go i carry s + | isTrue# (i ># sz) = s + | isTrue# (i ==# sz) = mwaWriteOrShrink mwa carry i s + | 0## <- carry = -- copy higher remaining words and shrink the mwa + case mwaArrayCopy# mwa i wa i (sz -# i) s of + s2 -> mwaShrink# mwa 1# s2 + | True = let !(# l,c #) = addWordC# (indexWordArray# wa i) carry + in case mwaWrite# mwa i l s of + s2 -> go (i +# 1#) (int2Word# c) s2 + +-- | Write the most-significant Word: +-- * if it is 0: shrink the array of 1 Word +-- * otherwise: write it +mwaWriteOrShrink :: MutableWordArray# s -> Word# -> Int# -> State# s -> State# s +mwaWriteOrShrink mwa 0## _i s = mwaShrink# mwa 1# s +mwaWriteOrShrink mwa w i s = mwaWrite# mwa i w s + +-- | Compute the index of the most-significant Word and write it. +mwaWriteMostSignificant :: MutableWordArray# s -> Word# -> State# s -> State# s +mwaWriteMostSignificant mwa w s = + case mwaSize# mwa s of + (# s', sz #) -> mwaWriteOrShrink mwa w (sz -# 1#) s' + +-- | MutableWordArray <- zipWith op wa1 wa2 +-- +-- Required output: Size(MutableWordArray) = min Size(wa1) Size(wa2) +mwaInitArrayBinOp :: MutableWordArray# s -> WordArray# -> WordArray# -> (Word# -> Word# -> Word#) -> State# s -> State#s +mwaInitArrayBinOp mwa wa wb op s = go 0# s + where + !sz = minI# (wordArraySize# wa) (wordArraySize# wb) + go i s' + | isTrue# (i ==# sz) = s' + | True = + case indexWordArray# wa i `op` indexWordArray# wb i of + v -> case mwaWrite# mwa i v s' of + s'' -> go (i +# 1#) s'' + +-- | Write an element of the MutableWordArray +mwaWrite# :: MutableWordArray# s -> Int# -> Word# -> State# s -> State# s +mwaWrite# = writeWordArray# + +-- | Fill some part of a MutableWordArray with the given Word# +mwaFill# :: MutableWordArray# s -> Word# -> Word# -> Word# -> State# s -> State# s +mwaFill# _ _ _ 0## s = s +mwaFill# mwa v off n s = case mwaWrite# mwa (word2Int# off) v s of + s' -> mwaFill# mwa v (off `plusWord#` 1##) (n `minusWord#` 1##) s' + +-- | Add Word# inplace (a the specified offset) in the mwa with carry propagation. +mwaAddInplaceWord# :: MutableWordArray# d -> Int# -> Word# -> State# d -> State# d +mwaAddInplaceWord# _ _ 0## s = s +mwaAddInplaceWord# mwa i y s = case readWordArray# mwa i s of + (# s1, x #) -> let !(# h,l #) = plusWord2# x y + in case mwaWrite# mwa i l s1 of + s2 -> mwaAddInplaceWord# mwa (i +# 1#) h s2 + +-- | Sub Word# inplace (at the specified offset) in the mwa with carry +-- propagation. +-- +-- Return True# on overflow +mwaSubInplaceWord# + :: MutableWordArray# d + -> Int# + -> Word# + -> State# d + -> (# State# d, Bool# #) +mwaSubInplaceWord# mwa ii iw s1 = case mwaSize# mwa s1 of + (# is, sz #) -> + let + go _ 0## s = (# s, 0# #) -- no overflow + go i y s + | isTrue# (i >=# sz) = (# s, 1# #) -- overflow + | True = case readWordArray# mwa i s of + (# s1, x #) -> let !(# l,h #) = subWordC# x y + in case mwaWrite# mwa i l s1 of + s2 -> go (i +# 1#) (int2Word# h) s2 + in go ii iw is + + +-- | Trim `a` of `k` less significant limbs and then compare the result with `b` +-- +-- "mwa" doesn't need to be trimmed +mwaTrimCompare :: Int# -> MutableWordArray# s -> WordArray# -> State# s -> (# State# s, Ordering #) +mwaTrimCompare k mwa wb s1 + | (# s, szA #) <- mwaSize# mwa s1 + , szB <- wordArraySize# wb + = + let + go i s + | isTrue# (i <# 0#) = (# s, EQ #) + | True = case readWordArray# mwa (i +# k) s of + (# s2, ai #) -> + let bi = if isTrue# (i >=# szB) + then 0## + else indexWordArray# wb i + in if | isTrue# (ai `gtWord#` bi) -> (# s2, GT #) + | isTrue# (bi `gtWord#` ai) -> (# s2, LT #) + | True -> go (i -# 1#) s2 + + szTrimA = szA -# k + + in if | isTrue# (szTrimA <# szB) -> (# s, LT #) + | True -> go (szA -# k -# 1#) s + + +-- | Sub array inplace (at the specified offset) in the mwa with carry propagation. +-- +-- We don't trim the resulting array! +-- +-- Return True# on overflow. +mwaSubInplaceArray :: MutableWordArray# d -> Int# -> WordArray# -> State# d -> (# State# d, Bool# #) +mwaSubInplaceArray mwa off wb = go (wordArraySize# wb -# 1#) + where + go i s + | isTrue# (i <# 0#) = (# s, 0# #) -- no overflow + | True + = case mwaSubInplaceWord# mwa (off +# i) (indexWordArray# wb i) s of + (# s2, 0# #) -> go (i -# 1#) s2 + (# s2, _ #) -> (# s2, 1# #) -- overflow + +-- | Add array inplace (a the specified offset) in the mwa with carry propagation. +-- +-- Upper bound of the result mutable aray is not checked against overflow. +mwaAddInplaceArray :: MutableWordArray# d -> Int# -> WordArray# -> State# d -> State# d +mwaAddInplaceArray mwa off wb = go 0# 0## + where + !maxi = wordArraySize# wb + go i c s + | isTrue# (i ==# maxi) = mwaAddInplaceWord# mwa (i +# off) c s + | True + = case readWordArray# mwa (i +# off) s of + (# s, v #) -> case plusWord3# v (indexWordArray# wb i) c of + (# c', v' #) -> case writeWordArray# mwa (i +# off) v' s of + s -> go (i +# 1#) c' s + +-- | Sub array inplace (at the specified offset) in the mwa with carry propagation. +-- +-- We don't trim the resulting array! +-- +-- Return True# on overflow. +mwaSubInplaceMutableArray :: MutableWordArray# d -> Int# -> MutableWordArray# d -> State# d -> (# State# d, Bool# #) +mwaSubInplaceMutableArray mwa off mwb s0 = + case mwaSize# mwb s0 of + (# s1, szB #) -> go (szB -# 1#) s1 + where + go i s + | isTrue# (i <# 0#) = (# s, 0# #) -- no overflow + | True + = case readWordArray# mwb i s of + (# s1, bi #) -> case mwaSubInplaceWord# mwa (off +# i) bi s1 of + (# s2, 0# #) -> go (i -# 1#) s2 + (# s2, _ #) -> (# s2, 1# #) -- overflow + +-- | Sub an array inplace and then trim zeroes +-- +-- Don't check overflow. The caller must ensure that a>=b +mwaSubInplaceArrayTrim :: MutableWordArray# d -> Int# -> WordArray# -> State# d -> State# d +mwaSubInplaceArrayTrim mwa off wb s = + case mwaSubInplaceArray mwa off wb s of + (# s', _ #) -> mwaTrimZeroes# mwa s' + + +-- | Read an indexed Word in the MutableWordArray. If the index is out-of-bound, +-- return zero. +mwaReadOrZero :: MutableWordArray# s -> Int# -> State# s -> (# State# s, Word# #) +mwaReadOrZero mwa i s = case mwaSize# mwa s of + (# s2, sz #) + | isTrue# (i >=# sz) -> (# s2, 0## #) + | isTrue# (i <# 0#) -> (# s2, 0## #) + | True -> readWordArray# mwa i s2 + +mwaRead# :: MutableWordArray# s -> Int# -> State# s -> (# State# s, Word# #) +mwaRead# = readWordArray# diff --git a/libraries/ghc-boot/GHC/Platform.hs b/libraries/ghc-boot/GHC/Platform.hs index 69978387ae..6c1be92512 100644 --- a/libraries/ghc-boot/GHC/Platform.hs +++ b/libraries/ghc-boot/GHC/Platform.hs @@ -29,13 +29,11 @@ module GHC.Platform , platformInIntRange , platformInWordRange , PlatformMisc(..) - , IntegerLibrary(..) , stringEncodeArch , stringEncodeOS , SseVersion (..) , BmiVersion (..) -) - + ) where import Prelude -- See Note [Why do we import Prelude here?] @@ -292,8 +290,6 @@ osSubsectionsViaSymbols _ = False data PlatformMisc = PlatformMisc { -- TODO Recalculate string from richer info? platformMisc_targetPlatformString :: String - , platformMisc_integerLibrary :: String - , platformMisc_integerLibraryType :: IntegerLibrary , platformMisc_ghcWithInterpreter :: Bool , platformMisc_ghcWithNativeCodeGen :: Bool , platformMisc_ghcWithSMP :: Bool @@ -309,11 +305,6 @@ data PlatformMisc = PlatformMisc , platformMisc_llvmTarget :: String } -data IntegerLibrary - = IntegerGMP - | IntegerSimple - deriving (Read, Show, Eq) - -- | Minimum representable Int value for the given platform platformMinInt :: Platform -> Integer platformMinInt p = case platformWordSize p of diff --git a/libraries/integer-gmp/changelog.md b/libraries/integer-gmp/changelog.md index 9ff56e104c..51f7d0cf21 100644 --- a/libraries/integer-gmp/changelog.md +++ b/libraries/integer-gmp/changelog.md @@ -1,5 +1,10 @@ # Changelog for [`integer-gmp` package](http://hackage.haskell.org/package/integer-gmp) +## 1.1 *2020* + + * integer-gmp is now a shallow backward compatibility package on top of + ghc-bignum + ## 1.0.3.0 *January 2019* * Bundled with GHC 8.10.1 diff --git a/libraries/integer-gmp/configure.ac b/libraries/integer-gmp/configure.ac deleted file mode 100644 index 1ccd48e698..0000000000 --- a/libraries/integer-gmp/configure.ac +++ /dev/null @@ -1,115 +0,0 @@ -AC_PREREQ(2.69) -AC_INIT([Haskell integer (GMP)], [1.0], [libraries@haskell.org], [integer]) - -# Safety check: Ensure that we are in the correct source directory. -AC_CONFIG_SRCDIR([cbits/wrappers.c]) - -AC_CANONICAL_TARGET - -AC_PROG_CC -dnl make extensions visible to allow feature-tests to detect them lateron -AC_USE_SYSTEM_EXTENSIONS - - -dnl-------------------------------------------------------------------- -dnl * Deal with arguments telling us gmp is somewhere odd -dnl-------------------------------------------------------------------- - -AC_ARG_WITH([gmp-includes], - [AC_HELP_STRING([--with-gmp-includes], - [directory containing gmp.h])], - [GMP_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval"], - [GMP_INCLUDE_DIRS=]) - -AC_ARG_WITH([gmp-libraries], - [AC_HELP_STRING([--with-gmp-libraries], - [directory containing gmp library])], - [GMP_LIB_DIRS=$withval; LDFLAGS="-L$withval"], - [GMP_LIB_DIRS=]) - -AC_ARG_WITH([gmp-framework-preferred], - [AC_HELP_STRING([--with-gmp-framework-preferred], - [on OSX, prefer the GMP framework to the gmp lib])], - [GMP_PREFER_FRAMEWORK=YES], - [GMP_PREFER_FRAMEWORK=NO]) - -AC_ARG_WITH([intree-gmp], - [AC_HELP_STRING([--with-intree-gmp], - [force using the in-tree GMP])], - [GMP_FORCE_INTREE=YES], - [GMP_FORCE_INTREE=NO]) - -dnl-------------------------------------------------------------------- -dnl * Detect gmp -dnl-------------------------------------------------------------------- - -HaveLibGmp=NO -GMP_LIBS= -HaveFrameworkGMP=NO -GMP_FRAMEWORK= -HaveSecurePowm=0 - -if test "$GMP_FORCE_INTREE" != "YES" -then - if test "$GMP_PREFER_FRAMEWORK" = "YES" - then - LOOK_FOR_GMP_FRAMEWORK - LOOK_FOR_GMP_LIB - else - LOOK_FOR_GMP_LIB - LOOK_FOR_GMP_FRAMEWORK - fi -fi - -AC_MSG_CHECKING([whether to use in-tree GMP]) -if test "$HaveFrameworkGMP" = "YES" || test "$HaveLibGmp" = "YES" -then - AC_MSG_RESULT([no]) - UseIntreeGmp=0 - AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Cannot find gmp.h])]) - - AC_MSG_CHECKING([GMP version]) - AC_COMPUTE_INT(GhcGmpVerMj, __GNU_MP_VERSION, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION])) - AC_COMPUTE_INT(GhcGmpVerMi, __GNU_MP_VERSION_MINOR, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_MINOR])) - AC_COMPUTE_INT(GhcGmpVerPl, __GNU_MP_VERSION_PATCHLEVEL, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_PATCHLEVEL])) - AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) - -else - AC_MSG_RESULT([yes]) - UseIntreeGmp=1 - HaveSecurePowm=1 - - AC_MSG_CHECKING([GMP version]) - GhcGmpVerMj=5 - GhcGmpVerMi=0 - GhcGmpVerPl=4 - AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) -fi - - -dnl-------------------------------------------------------------------- -dnl * Make sure we got some form of gmp -dnl-------------------------------------------------------------------- - -AC_SUBST(GMP_INCLUDE_DIRS) -AC_SUBST(GMP_LIBS) -AC_SUBST(GMP_LIB_DIRS) -AC_SUBST(GMP_FRAMEWORK) -AC_SUBST(HaveLibGmp) -AC_SUBST(HaveFrameworkGMP) -AC_SUBST(HaveSecurePowm) -AC_SUBST(UseIntreeGmp) -AC_SUBST(GhcGmpVerMj) -AC_SUBST(GhcGmpVerMi) -AC_SUBST(GhcGmpVerPl) - -AC_CONFIG_FILES([integer-gmp.buildinfo config.mk include/HsIntegerGmp.h]) - -dnl-------------------------------------------------------------------- -dnl * Generate output files -dnl-------------------------------------------------------------------- - -AC_OUTPUT diff --git a/libraries/integer-gmp/ghc.mk b/libraries/integer-gmp/ghc.mk new file mode 100644 index 0000000000..cd8a1d89e8 --- /dev/null +++ b/libraries/integer-gmp/ghc.mk @@ -0,0 +1,5 @@ +libraries/integer-gmp_PACKAGE = integer-gmp +libraries/integer-gmp_dist-install_GROUP = libraries +$(if $(filter integer-gmp,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/integer-gmp,dist-boot,0))) +$(if $(filter integer-gmp,$(PACKAGES_STAGE1)),$(eval $(call build-package,libraries/integer-gmp,dist-install,1))) +$(if $(filter integer-gmp,$(PACKAGES_STAGE2)),$(eval $(call build-package,libraries/integer-gmp,dist-install,2))) diff --git a/libraries/integer-gmp/integer-gmp.cabal b/libraries/integer-gmp/integer-gmp.cabal index 77e98180c2..4092b828fd 100644 --- a/libraries/integer-gmp/integer-gmp.cabal +++ b/libraries/integer-gmp/integer-gmp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: integer-gmp -version: 1.0.3.0 +version: 1.1 synopsis: Integer library based on GMP license: BSD3 @@ -8,74 +8,24 @@ license-file: LICENSE author: Herbert Valerio Riedel maintainer: hvr@gnu.org category: Numeric, Algebra -build-type: Configure +build-type: Simple description: - This package provides the low-level implementation of the standard - 'Integer' type based on the + This package used to provide an implementation of the standard 'Integer' + type based on the <http://gmplib.org/ GNU Multiple Precision Arithmetic Library (GMP)>. . - This package provides access to the internal representation of - 'Integer' as well as primitive operations with no proper error - handling, and should only be used directly with the utmost care. - -extra-source-files: - aclocal.m4 - cbits/wrappers.c - changelog.md - config.guess - config.sub - configure - configure.ac - config.mk.in - include/HsIntegerGmp.h.in - install-sh - integer-gmp.buildinfo.in - --- NB: Many of these tmp files no longer ever actually get plopped in --- the root directory post Cabal 2.4, thanks to a change that causes --- autoconf/configure to get run inside the dist directory. -extra-tmp-files: - autom4te.cache - config.log - config.status - config.mk - integer-gmp.buildinfo - include/HsIntegerGmp.h + It is now deprecated in favor of the 'ghc-bignum' package. + . + Its purpose is to provide backward compatibility for codes directly + depending on the `integer-gmp` package. library default-language: Haskell2010 - other-extensions: - BangPatterns - CApiFFI - CPP - DeriveDataTypeable - ExplicitForAll - GHCForeignImportPrim - MagicHash - NegativeLiterals - NoImplicitPrelude - RebindableSyntax - StandaloneDeriving - UnboxedTuples - UnliftedFFITypes - build-depends: ghc-prim >= 0.5.1.0 && < 0.7 hs-source-dirs: src/ - -- We need to set the unit ID to integer-wired-in - -- (without a version number) as it's magic. - -- See Note [The integer library] in PrelNames - ghc-options: -this-unit-id integer-wired-in -Wall - cc-options: -std=c99 -Wall - - include-dirs: include - c-sources: - cbits/wrappers.c + ghc-options: -Wall + build-depends: + base >= 4.11 && < 5 + , ghc-prim exposed-modules: - GHC.Integer - GHC.Integer.Logarithms - GHC.Integer.Logarithms.Internals - GHC.Integer.GMP.Internals - - other-modules: - GHC.Integer.Type diff --git a/libraries/integer-gmp/src/GHC/Integer.hs b/libraries/integer-gmp/src/GHC/Integer.hs deleted file mode 100644 index 6a0d16d553..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} - -#include "MachDeps.h" - --- | --- Module : GHC.Integer.Type --- Copyright : (c) Herbert Valerio Riedel 2014 --- License : BSD3 --- --- Maintainer : ghc-devs@haskell.org --- Stability : provisional --- Portability : non-portable (GHC Extensions) --- --- The 'Integer' type. --- --- This module exposes the /portable/ 'Integer' API. See --- "GHC.Integer.GMP.Internals" for the @integer-gmp@-specific internal --- representation of 'Integer' as well as optimized GMP-specific --- operations. - -module GHC.Integer ( - Integer, - - -- * Construct 'Integer's - mkInteger, smallInteger, wordToInteger, -#if WORD_SIZE_IN_BITS < 64 - word64ToInteger, int64ToInteger, -#endif - -- * Conversion to other integral types - integerToWord, integerToInt, -#if WORD_SIZE_IN_BITS < 64 - integerToWord64, integerToInt64, -#endif - - -- * Helpers for 'RealFloat' type-class operations - encodeFloatInteger, floatFromInteger, - encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger, - - -- * Arithmetic operations - plusInteger, minusInteger, timesInteger, negateInteger, - absInteger, signumInteger, - - divModInteger, divInteger, modInteger, - quotRemInteger, quotInteger, remInteger, - - -- * Comparison predicates - eqInteger, neqInteger, leInteger, gtInteger, ltInteger, geInteger, - compareInteger, - - -- ** 'Int#'-boolean valued versions of comparison predicates - -- - -- | These operations return @0#@ and @1#@ instead of 'False' and - -- 'True' respectively. See - -- <https://gitlab.haskell.org/ghc/ghc/wikis/prim-bool PrimBool wiki-page> - -- for more details - eqInteger#, neqInteger#, leInteger#, gtInteger#, ltInteger#, geInteger#, - - - -- * Bit-operations - andInteger, orInteger, xorInteger, - - complementInteger, - shiftLInteger, shiftRInteger, testBitInteger, - - popCountInteger, bitInteger, - - -- * Hashing - hashInteger, - ) where - -import GHC.Integer.Type - -default () diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs index 6eb88bd943..3af21e7e74 100644 --- a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs +++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs @@ -1,13 +1,10 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CApiFFI #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #include "MachDeps.h" @@ -20,20 +17,9 @@ -- Stability : provisional -- Portability : non-portable (GHC Extensions) -- --- This modules provides access to the 'Integer' constructors and --- exposes some highly optimized GMP-operations. --- --- Note that since @integer-gmp@ does not depend on `base`, error --- reporting via exceptions, 'error', or 'undefined' is not --- available. Instead, the low-level functions will crash the runtime --- if called with invalid arguments. --- --- See also --- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/libraries/integer GHC Commentary: Libraries/Integer>. - module GHC.Integer.GMP.Internals ( -- * The 'Integer' type - Integer(..) + Integer (S#,Jn#,Jp#) , isValidInteger# -- ** Basic 'Integer' operations @@ -42,12 +28,8 @@ module GHC.Integer.GMP.Internals -- ** Additional 'Integer' operations , gcdInteger - , gcdExtInteger , lcmInteger , sqrInteger - , powModInteger - , powModSecInteger - , recipModInteger -- ** Additional conversion operations to 'Integer' , wordToNegInteger @@ -60,305 +42,73 @@ module GHC.Integer.GMP.Internals , GmpLimb, GmpLimb# , GmpSize, GmpSize# - -- ** - - , isValidBigNat# - , sizeofBigNat# - , zeroBigNat - , oneBigNat - , nullBigNat - - -- ** Conversions to/from 'BigNat' - - , byteArrayToBigNat# - , wordToBigNat - , wordToBigNat2 - , bigNatToInt - , bigNatToWord - , indexBigNat# - - -- ** 'BigNat' arithmetic operations - , plusBigNat - , plusBigNatWord - , minusBigNat - , minusBigNatWord - , timesBigNat - , timesBigNatWord - , sqrBigNat - - , quotRemBigNat - , quotRemBigNatWord - , quotBigNatWord - , quotBigNat - , remBigNat - , remBigNatWord - - , gcdBigNat - , gcdBigNatWord - - , powModBigNat - , powModBigNatWord - - , recipModBigNat - - -- ** 'BigNat' logic operations - , shiftRBigNat - , shiftLBigNat - , testBitBigNat - , clearBitBigNat - , complementBitBigNat - , setBitBigNat - , andBigNat - , xorBigNat - , popCountBigNat - , orBigNat - , bitBigNat - - -- ** 'BigNat' comparison predicates - , isZeroBigNat - , isNullBigNat# - - , compareBigNatWord - , compareBigNat - , eqBigNatWord - , eqBigNatWord# - , eqBigNat - , eqBigNat# - , gtBigNatWord# - - -- * Miscellaneous GMP-provided operations - , gcdInt - , gcdWord - , powModWord - , recipModWord - - -- * Primality tests - , testPrimeInteger - , testPrimeBigNat - , testPrimeWord# - - , nextPrimeInteger - , nextPrimeBigNat - , nextPrimeWord# - - -- * Import/export functions - -- ** Compute size of serialisation - , sizeInBaseBigNat - , sizeInBaseInteger - , sizeInBaseWord# - - -- ** Export - , exportBigNatToAddr - , exportIntegerToAddr - , exportWordToAddr - - , exportBigNatToMutableByteArray - , exportIntegerToMutableByteArray - , exportWordToMutableByteArray - - -- ** Import - - , importBigNatFromAddr - , importIntegerFromAddr - - , importBigNatFromByteArray - , importIntegerFromByteArray ) where -import GHC.Integer.Type import GHC.Integer -import GHC.Prim +import GHC.Natural +import GHC.Num.Integer (Integer(..)) +import qualified GHC.Num.Integer as I import GHC.Types +import GHC.Prim -default () - - --- | Compute number of digits (without sign) in given @/base/@. --- --- This function wraps @mpz_sizeinbase()@ which has some --- implementation pecularities to take into account: --- --- * \"@'sizeInBaseInteger' 0 /base/ = 1@\" --- (see also comment in 'exportIntegerToMutableByteArray'). --- --- * This function is only defined if @/base/ >= 2#@ and @/base/ <= 256#@ --- (Note: the documentation claims that only @/base/ <= 62#@ is --- supported, however the actual implementation supports up to base 256). --- --- * If @/base/@ is a power of 2, the result will be exact. In other --- cases (e.g. for @/base/ = 10#@), the result /may/ be 1 digit too large --- sometimes. --- --- * \"@'sizeInBaseInteger' /i/ 2#@\" can be used to determine the most --- significant bit of @/i/@. --- --- @since 0.5.1.0 -sizeInBaseInteger :: Integer -> Int# -> Word# -sizeInBaseInteger (S# i#) = sizeInBaseWord# (int2Word# (absI# i#)) -sizeInBaseInteger (Jp# bn) = sizeInBaseBigNat bn -sizeInBaseInteger (Jn# bn) = sizeInBaseBigNat bn - --- | Version of 'sizeInBaseInteger' operating on 'BigNat' --- --- @since 1.0.0.0 -sizeInBaseBigNat :: BigNat -> Int# -> Word# -sizeInBaseBigNat bn@(BN# ba#) = c_mpn_sizeinbase# ba# (sizeofBigNat# bn) - -foreign import ccall unsafe "integer_gmp_mpn_sizeinbase" - c_mpn_sizeinbase# :: ByteArray# -> GmpSize# -> Int# -> Word# - --- | Version of 'sizeInBaseInteger' operating on 'Word#' --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_mpn_sizeinbase1" - sizeInBaseWord# :: Word# -> Int# -> Word# - --- | Dump 'Integer' (without sign) to @/addr/@ in base-256 representation. --- --- @'exportIntegerToAddr' /i/ /addr/ /e/@ --- --- See description of 'exportIntegerToMutableByteArray' for more details. --- --- @since 1.0.0.0 -exportIntegerToAddr :: Integer -> Addr# -> Int# -> IO Word -exportIntegerToAddr (S# i#) = exportWordToAddr (W# (int2Word# (absI# i#))) -exportIntegerToAddr (Jp# bn) = exportBigNatToAddr bn -exportIntegerToAddr (Jn# bn) = exportBigNatToAddr bn - --- | Version of 'exportIntegerToAddr' operating on 'BigNat's. -exportBigNatToAddr :: BigNat -> Addr# -> Int# -> IO Word -exportBigNatToAddr bn@(BN# ba#) addr e - = c_mpn_exportToAddr# ba# (sizeofBigNat# bn) addr 0# e - -foreign import ccall unsafe "integer_gmp_mpn_export" - c_mpn_exportToAddr# :: ByteArray# -> GmpSize# -> Addr# -> Int# -> Int# - -> IO Word - --- | Version of 'exportIntegerToAddr' operating on 'Word's. -exportWordToAddr :: Word -> Addr# -> Int# -> IO Word -exportWordToAddr (W# w#) addr - = c_mpn_export1ToAddr# w# addr 0# -- TODO: we don't calling GMP for that +{-# COMPLETE S#, Jp#, Jn# #-} -foreign import ccall unsafe "integer_gmp_mpn_export1" - c_mpn_export1ToAddr# :: GmpLimb# -> Addr# -> Int# -> Int# - -> IO Word +{-# DEPRECATED S# "Use IS constructor instead" #-} +pattern S# :: Int# -> Integer +pattern S# i = IS i --- | Dump 'Integer' (without sign) to mutable byte-array in base-256 --- representation. --- --- The call --- --- @'exportIntegerToMutableByteArray' /i/ /mba/ /offset/ /msbf/@ --- --- writes --- --- * the 'Integer' @/i/@ --- --- * into the 'MutableByteArray#' @/mba/@ starting at @/offset/@ --- --- * with most significant byte first if @msbf@ is @1#@ or least --- significant byte first if @msbf@ is @0#@, and --- --- * returns number of bytes written. --- --- Use \"@'sizeInBaseInteger' /i/ 256#@\" to compute the exact number of --- bytes written in advance for @/i/ /= 0@. In case of @/i/ == 0@, --- 'exportIntegerToMutableByteArray' will write and report zero bytes --- written, whereas 'sizeInBaseInteger' report one byte. --- --- It's recommended to avoid calling 'exportIntegerToMutableByteArray' for small --- integers as this function would currently convert those to big --- integers in msbf to call @mpz_export()@. --- --- @since 1.0.0.0 -exportIntegerToMutableByteArray :: Integer -> MutableByteArray# RealWorld - -> Word# -> Int# -> IO Word -exportIntegerToMutableByteArray (S# i#) - = exportWordToMutableByteArray (W# (int2Word# (absI# i#))) -exportIntegerToMutableByteArray (Jp# bn) = exportBigNatToMutableByteArray bn -exportIntegerToMutableByteArray (Jn# bn) = exportBigNatToMutableByteArray bn +fromBN# :: BigNat -> ByteArray# +fromBN# (BN# x) = x --- | Version of 'exportIntegerToMutableByteArray' operating on 'BigNat's. --- --- @since 1.0.0.0 -exportBigNatToMutableByteArray :: BigNat -> MutableByteArray# RealWorld -> Word# - -> Int# -> IO Word -exportBigNatToMutableByteArray bn@(BN# ba#) - = c_mpn_exportToMutableByteArray# ba# (sizeofBigNat# bn) +fromIP :: Integer -> (# () | BigNat #) +fromIP (IP x) = (# | BN# x #) +fromIP _ = (# () | #) -foreign import ccall unsafe "integer_gmp_mpn_export" - c_mpn_exportToMutableByteArray# :: ByteArray# -> GmpSize# - -> MutableByteArray# RealWorld -> Word# - -> Int# -> IO Word +fromIN :: Integer -> (# () | BigNat #) +fromIN (IN x) = (# | BN# x #) +fromIN _ = (# () | #) --- | Version of 'exportIntegerToMutableByteArray' operating on 'Word's. --- --- @since 1.0.0.0 -exportWordToMutableByteArray :: Word -> MutableByteArray# RealWorld -> Word# - -> Int# -> IO Word -exportWordToMutableByteArray (W# w#) = c_mpn_export1ToMutableByteArray# w# +{-# DEPRECATED Jp# "Use IP constructor instead" #-} +pattern Jp# :: BigNat -> Integer +pattern Jp# i <- (fromIP -> (# | i #)) + where + Jp# i = IP (fromBN# i) -foreign import ccall unsafe "integer_gmp_mpn_export1" - c_mpn_export1ToMutableByteArray# :: GmpLimb# -> MutableByteArray# RealWorld - -> Word# -> Int# -> IO Word +{-# DEPRECATED Jn# "Use IN constructor instead" #-} +pattern Jn# :: BigNat -> Integer +pattern Jn# i <- (fromIN -> (# | i #)) + where + Jn# i = IN (fromBN# i) +{-# DEPRECATED isValidInteger# "Use integerCheck# instead" #-} +isValidInteger# :: Integer -> Int# +isValidInteger# = I.integerCheck# --- | Probalistic Miller-Rabin primality test. --- --- \"@'testPrimeInteger' /n/ /k/@\" determines whether @/n/@ is prime --- and returns one of the following results: --- --- * @2#@ is returned if @/n/@ is definitely prime, --- --- * @1#@ if @/n/@ is a /probable prime/, or --- --- * @0#@ if @/n/@ is definitely not a prime. --- --- The @/k/@ argument controls how many test rounds are performed for --- determining a /probable prime/. For more details, see --- <http://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fprobab_005fprime_005fp-360 GMP documentation for `mpz_probab_prime_p()`>. --- --- @since 0.5.1.0 -{-# NOINLINE testPrimeInteger #-} -testPrimeInteger :: Integer -> Int# -> Int# -testPrimeInteger (S# i#) = testPrimeWord# (int2Word# (absI# i#)) -testPrimeInteger (Jp# n) = testPrimeBigNat n -testPrimeInteger (Jn# n) = testPrimeBigNat n +{-# DEPRECATED gcdInteger "Use integerGcd instead" #-} +gcdInteger :: Integer -> Integer -> Integer +gcdInteger = I.integerGcd --- | Version of 'testPrimeInteger' operating on 'BigNat's --- --- @since 1.0.0.0 -testPrimeBigNat :: BigNat -> Int# -> Int# -testPrimeBigNat bn@(BN# ba#) = c_integer_gmp_test_prime# ba# (sizeofBigNat# bn) +{-# DEPRECATED lcmInteger "Use integerLcm instead" #-} +lcmInteger :: Integer -> Integer -> Integer +lcmInteger = I.integerLcm -foreign import ccall unsafe "integer_gmp_test_prime" - c_integer_gmp_test_prime# :: ByteArray# -> GmpSize# -> Int# -> Int# +{-# DEPRECATED sqrInteger "Use integerSqr instead" #-} +sqrInteger :: Integer -> Integer +sqrInteger = I.integerSqr --- | Version of 'testPrimeInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_test_prime1" - testPrimeWord# :: GmpLimb# -> Int# -> Int# +{-# DEPRECATED wordToNegInteger "Use integerFromWordNeg# instead" #-} +wordToNegInteger :: Word# -> Integer +wordToNegInteger = I.integerFromWordNeg# +{-# DEPRECATED bigNatToInteger "Use integerFromBigNat instead" #-} +bigNatToInteger :: BigNat -> Integer +bigNatToInteger (BN# i) = I.integerFromBigNat i --- | Compute next prime greater than @/n/@ probalistically. --- --- According to the GMP documentation, the underlying function --- @mpz_nextprime()@ \"uses a probabilistic algorithm to identify --- primes. For practical purposes it's adequate, the chance of a --- composite passing will be extremely small.\" --- --- @since 0.5.1.0 -{-# NOINLINE nextPrimeInteger #-} -nextPrimeInteger :: Integer -> Integer -nextPrimeInteger (S# i#) - | isTrue# (i# ># 1#) = wordToInteger (nextPrimeWord# (int2Word# i#)) - | True = S# 2# -nextPrimeInteger (Jp# bn) = Jp# (nextPrimeBigNat bn) -nextPrimeInteger (Jn# _) = S# 2# +{-# DEPRECATED bigNatToNegInteger "Use integerFromBigNatNeg instead" #-} +bigNatToNegInteger :: BigNat -> Integer +bigNatToNegInteger (BN# i) = I.integerFromBigNatNeg i --- | Version of 'nextPrimeInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_next_prime1" - nextPrimeWord# :: GmpLimb# -> GmpLimb# +type GmpLimb = Word +type GmpLimb# = Word# +type GmpSize = Int +type GmpSize# = Int# diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs deleted file mode 100644 index 76467e18a7..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - -module GHC.Integer.Logarithms - ( wordLog2# - , integerLog2# - , integerLogBase# - ) where - -#include "MachDeps.h" - -#if WORD_SIZE_IN_BITS == 32 -# define LD_WORD_SIZE_IN_BITS 5 -#elif WORD_SIZE_IN_BITS == 64 -# define LD_WORD_SIZE_IN_BITS 6 -#else -# error unsupported WORD_SIZE_IN_BITS -#endif - -import GHC.Integer.Type - -import GHC.Prim - -default () - --- | Calculate the integer logarithm for an arbitrary base. --- --- The base must be greater than @1@, the second argument, the number --- whose logarithm is sought, shall be positive, otherwise the --- result is meaningless. --- --- The following property holds --- --- @base ^ 'integerLogBase#' base m <= m < base ^('integerLogBase#' base m + 1)@ --- --- for @base > 1@ and @m > 0@. --- --- Note: Internally uses 'integerLog2#' for base 2 -integerLogBase# :: Integer -> Integer -> Int# -integerLogBase# (S# 2#) m = integerLog2# m -integerLogBase# b m = e' - where - !(# _, e' #) = go b - - go pw | m `ltInteger` pw = (# m, 0# #) - go pw = case go (sqrInteger pw) of - (# q, e #) | q `ltInteger` pw -> (# q, 2# *# e #) - (# q, e #) -> (# q `quotInteger` pw, 2# *# e +# 1# #) - - --- | Calculate the integer base 2 logarithm of an 'Integer'. The --- calculation is more efficient than for the general case, on --- platforms with 32- or 64-bit words much more efficient. --- --- The argument must be strictly positive, that condition is /not/ checked. -integerLog2# :: Integer -> Int# -integerLog2# (S# i#) = wordLog2# (int2Word# i#) -integerLog2# (Jn# _) = -1# -integerLog2# (Jp# bn) = go (s -# 1#) - where - s = sizeofBigNat# bn - go i = case indexBigNat# bn i of - 0## -> go (i -# 1#) - w -> wordLog2# w +# (uncheckedIShiftL# i LD_WORD_SIZE_IN_BITS#) - --- | Compute base-2 log of 'Word#' --- --- This is internally implemented as count-leading-zeros machine instruction. -wordLog2# :: Word# -> Int# -wordLog2# w# = (WORD_SIZE_IN_BITS# -# 1#) -# (word2Int# (clz# w#)) diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs deleted file mode 100644 index 5f50c79e41..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_HADDOCK not-home #-} - -#include "MachDeps.h" - -#if WORD_SIZE_IN_BITS == 32 -# define WSHIFT 5 -# define MMASK 31 -#elif WORD_SIZE_IN_BITS == 64 -# define WSHIFT 6 -# define MMASK 63 -#else -# error unsupported WORD_SIZE_IN_BITS -#endif - --- | Fast 'Integer' logarithms to base 2. 'integerLog2#' and --- 'wordLog2#' are of general usefulness, the others are only needed --- for a fast implementation of 'fromRational'. Since they are needed --- in "GHC.Float", we must expose this module, but it should not show --- up in the docs. --- --- See https://gitlab.haskell.org/ghc/ghc/issues/5122 --- for the origin of the code in this module -module GHC.Integer.Logarithms.Internals - ( wordLog2# - , integerLog2IsPowerOf2# - , integerLog2# - , roundingMode# - ) where - -import GHC.Integer.Type -import GHC.Integer.Logarithms - -import GHC.Types -import GHC.Prim - -default () - --- | Extended version of 'integerLog2#' --- --- Assumption: Integer is strictly positive --- --- First component of result is @log2 n@, second is @0#@ iff /n/ is a --- power of two. -integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) --- The power of 2 test is n&(n-1) == 0, thus powers of 2 --- are indicated bythe second component being zero. -integerLog2IsPowerOf2# (S# i#) = case int2Word# i# of - w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #) -integerLog2IsPowerOf2# (Jn# _) = (# -1#, -1# #) --- Find the log2 as above, test whether that word is a power --- of 2, if so, check whether only zero bits follow. -integerLog2IsPowerOf2# (Jp# bn) = check (s -# 1#) - where - s = sizeofBigNat# bn - check :: Int# -> (# Int#, Int# #) - check i = case indexBigNat# bn i of - 0## -> check (i -# 1#) - w -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) - , case w `and#` (w `minusWord#` 1##) of - 0## -> test (i -# 1#) - _ -> 1# #) - test :: Int# -> Int# - test i = if isTrue# (i <# 0#) - then 0# - else case indexBigNat# bn i of - 0## -> test (i -# 1#) - _ -> 1# - - --- Assumption: Integer and Int# are strictly positive, Int# is less --- than logBase 2 of Integer, otherwise havoc ensues. --- Used only for the numerator in fromRational when the denominator --- is a power of 2. --- The Int# argument is log2 n minus the number of bits in the mantissa --- of the target type, i.e. the index of the first non-integral bit in --- the quotient. --- --- 0# means round down (towards zero) --- 1# means we have a half-integer, round to even --- 2# means round up (away from zero) -roundingMode# :: Integer -> Int# -> Int# -roundingMode# (S# i#) t = - case int2Word# i# `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of - k -> case uncheckedShiftL# 1## t of - c -> if isTrue# (c `gtWord#` k) - then 0# - else if isTrue# (c `ltWord#` k) - then 2# - else 1# - -roundingMode# (Jn# bn) t = roundingMode# (Jp# bn) t -- dummy -roundingMode# (Jp# bn) t = - case word2Int# (int2Word# t `and#` MMASK##) of - j -> -- index of relevant bit in word - case uncheckedIShiftRA# t WSHIFT# of - k -> -- index of relevant word - case indexBigNat# bn k `and#` - ((uncheckedShiftL# 2## j) `minusWord#` 1##) of - r -> - case uncheckedShiftL# 1## j of - c -> if isTrue# (c `gtWord#` r) - then 0# - else if isTrue# (c `ltWord#` r) - - - then 2# - else test (k -# 1#) - where - test i = if isTrue# (i <# 0#) - then 1# - else case indexBigNat# bn i of - 0## -> test (i -# 1#) - _ -> 2# diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs deleted file mode 100644 index cc94089828..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ /dev/null @@ -1,2202 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ExplicitForAll #-} - --- | --- Module : GHC.Integer.Type --- Copyright : (c) Herbert Valerio Riedel 2014 --- License : BSD3 --- --- Maintainer : ghc-devs@haskell.org --- Stability : provisional --- Portability : non-portable (GHC Extensions) --- --- GHC needs this module to be named "GHC.Integer.Type" and provide --- all the low-level 'Integer' operations. - -module GHC.Integer.Type where - -#include "MachDeps.h" -#include "HsIntegerGmp.h" - --- Sanity check as CPP defines are implicitly 0-valued when undefined -#if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \ - && defined(WORD_SIZE_IN_BITS)) -# error missing defines -#endif - -import GHC.Classes -import GHC.Magic -import GHC.Prim -import GHC.Types -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - -default () - --- Most high-level operations need to be marked `NOINLINE` as --- otherwise GHC doesn't recognize them and fails to apply constant --- folding to `Integer`-typed expression. --- --- To this end, the CPP hack below allows to write the pseudo-pragma --- --- {-# CONSTANT_FOLDED plusInteger #-} --- --- which is simply expanded into a --- --- {-# NOINLINE plusInteger #-} --- -#define CONSTANT_FOLDED NOINLINE - ----------------------------------------------------------------------------- --- type definitions - --- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS --- The C99 code in cbits/wrappers.c will fail to compile if this doesn't hold - --- | Type representing a GMP Limb -type GmpLimb = Word -- actually, 'CULong' -type GmpLimb# = Word# - --- | Count of 'GmpLimb's, must be positive (unless specified otherwise). -type GmpSize = Int -- actually, a 'CLong' -type GmpSize# = Int# - -narrowGmpSize# :: Int# -> Int# -#if SIZEOF_LONG == SIZEOF_HSWORD -narrowGmpSize# x = x -#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) --- On IL32P64 (i.e. Win64), we have to be careful with CLong not being --- 64bit. This is mostly an issue on values returned from C functions --- due to sign-extension. -narrowGmpSize# = narrow32Int# -#endif - - -type GmpBitCnt = Word -- actually, 'CULong' -type GmpBitCnt# = Word# -- actually, 'CULong' - --- Pseudo FFI CType -type CInt = Int -type CInt# = Int# - -narrowCInt# :: Int# -> Int# -narrowCInt# = narrow32Int# - --- | Bits in a 'GmpLimb'. Same as @WORD_SIZE_IN_BITS@. -gmpLimbBits :: Word -- 8 `shiftL` gmpLimbShift -gmpLimbBits = W# WORD_SIZE_IN_BITS## - -#if WORD_SIZE_IN_BITS == 64 -# define GMP_LIMB_SHIFT 3 -# define GMP_LIMB_BYTES 8 -# define GMP_LIMB_BITS 64 -# define INT_MINBOUND -0x8000000000000000 -# define INT_MAXBOUND 0x7fffffffffffffff -# define ABS_INT_MINBOUND 0x8000000000000000 -# define SQRT_INT_MAXBOUND 0xb504f333 -#elif WORD_SIZE_IN_BITS == 32 -# define GMP_LIMB_SHIFT 2 -# define GMP_LIMB_BYTES 4 -# define GMP_LIMB_BITS 32 -# define INT_MINBOUND -0x80000000 -# define INT_MAXBOUND 0x7fffffff -# define ABS_INT_MINBOUND 0x80000000 -# define SQRT_INT_MAXBOUND 0xb504 -#else -# error unsupported WORD_SIZE_IN_BITS config -#endif - --- | Type representing /raw/ arbitrary-precision Naturals --- --- This is common type used by 'Natural' and 'Integer'. As this type --- consists of a single constructor wrapping a 'ByteArray#' it can be --- unpacked. --- --- Essential invariants: --- --- - 'ByteArray#' size is an exact multiple of 'Word#' size --- - limbs are stored in least-significant-limb-first order, --- - the most-significant limb must be non-zero, except for --- - @0@ which is represented as a 1-limb. -data BigNat = BN# ByteArray# - -instance Eq BigNat where - (==) = eqBigNat - -instance Ord BigNat where - compare = compareBigNat - --- [Implementation notes] --- --- Invariant: 'Jn#' and 'Jp#' are used iff value doesn't fit in 'S#' --- --- Useful properties resulting from the invariants: --- --- - @abs ('S#' _) <= abs ('Jp#' _)@ --- - @abs ('S#' _) < abs ('Jn#' _)@ - --- | Arbitrary precision integers. In contrast with fixed-size integral types --- such as 'Int', the 'Integer' type represents the entire infinite range of --- integers. --- --- For more information about this type's representation, see the comments in --- its implementation. -data Integer = S# !Int# - -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range - | Jp# {-# UNPACK #-} !BigNat - -- ^ iff value in @]maxBound::'Int', +inf[@ range - | Jn# {-# UNPACK #-} !BigNat - -- ^ iff value in @]-inf, minBound::'Int'[@ range - --- NOTE: the above representation is baked into the GHCi debugger in --- GHC.Runtime.Heap.Inspect. If you change it here, fixes --- will be required over there too. Tests for this are in --- testsuite/tests/ghci.debugger. - --- TODO: experiment with different constructor-ordering - -instance Eq Integer where - (==) = eqInteger - (/=) = neqInteger - -instance Ord Integer where - compare = compareInteger - (>) = gtInteger - (>=) = geInteger - (<) = ltInteger - (<=) = leInteger - ----------------------------------------------------------------------------- - --- | Construct 'Integer' value from list of 'Int's. --- --- This function is used by GHC for constructing 'Integer' literals. -mkInteger :: Bool -- ^ sign of integer ('True' if non-negative) - -> [Int] -- ^ absolute value expressed in 31 bit chunks, least - -- significant first (ideally these would be machine-word - -- 'Word's rather than 31-bit truncated 'Int's) - -> Integer -mkInteger nonNegative is - | nonNegative = f is - | True = negateInteger (f is) - where - f [] = S# 0# - f (I# i : is') = smallInteger (i `andI#` 0x7fffffff#) `orInteger` - shiftLInteger (f is') 31# -{-# CONSTANT_FOLDED mkInteger #-} - --- | Test whether all internal invariants are satisfied by 'Integer' value --- --- Returns @1#@ if valid, @0#@ otherwise. --- --- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. -isValidInteger# :: Integer -> Int# -isValidInteger# (S# _) = 1# -isValidInteger# (Jp# bn) - = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` INT_MAXBOUND##) -isValidInteger# (Jn# bn) - = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` ABS_INT_MINBOUND##) - --- | Should rather be called @intToInteger@ -smallInteger :: Int# -> Integer -smallInteger i# = S# i# -{-# CONSTANT_FOLDED smallInteger #-} - ----------------------------------------------------------------------------- --- Int64/Word64 specific primitives - -#if WORD_SIZE_IN_BITS < 64 -int64ToInteger :: Int64# -> Integer -int64ToInteger i - | isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#) - , isTrue# (i `geInt64#` intToInt64# -0x80000000#) - = S# (int64ToInt# i) - | isTrue# (i `geInt64#` intToInt64# 0#) - = Jp# (word64ToBigNat (int64ToWord64# i)) - | True - = Jn# (word64ToBigNat (int64ToWord64# (negateInt64# i))) -{-# CONSTANT_FOLDED int64ToInteger #-} - -word64ToInteger :: Word64# -> Integer -word64ToInteger w - | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##) - = S# (int64ToInt# (word64ToInt64# w)) - | True - = Jp# (word64ToBigNat w) -{-# CONSTANT_FOLDED word64ToInteger #-} - -integerToInt64 :: Integer -> Int64# -integerToInt64 (S# i#) = intToInt64# i# -integerToInt64 (Jp# bn) = word64ToInt64# (bigNatToWord64 bn) -integerToInt64 (Jn# bn) = negateInt64# (word64ToInt64# (bigNatToWord64 bn)) -{-# CONSTANT_FOLDED integerToInt64 #-} - -integerToWord64 :: Integer -> Word64# -integerToWord64 (S# i#) = int64ToWord64# (intToInt64# i#) -integerToWord64 (Jp# bn) = bigNatToWord64 bn -integerToWord64 (Jn# bn) - = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64 bn))) -{-# CONSTANT_FOLDED integerToWord64 #-} - -#if GMP_LIMB_BITS == 32 -word64ToBigNat :: Word64# -> BigNat -word64ToBigNat w64 = wordToBigNat2 wh# wl# - where - wh# = word64ToWord# (uncheckedShiftRL64# w64 32#) - wl# = word64ToWord# w64 - -bigNatToWord64 :: BigNat -> Word64# -bigNatToWord64 bn - | isTrue# (sizeofBigNat# bn ># 1#) - = let wh# = wordToWord64# (indexBigNat# bn 1#) - in uncheckedShiftL64# wh# 32# `or64#` wl# - | True = wl# - where - wl# = wordToWord64# (bigNatToWord bn) -#endif -#endif - --- End of Int64/Word64 specific primitives ----------------------------------------------------------------------------- - --- | Truncates 'Integer' to least-significant 'Int#' -integerToInt :: Integer -> Int# -integerToInt (S# i#) = i# -integerToInt (Jp# bn) = bigNatToInt bn -integerToInt (Jn# bn) = negateInt# (bigNatToInt bn) -{-# CONSTANT_FOLDED integerToInt #-} - -hashInteger :: Integer -> Int# -hashInteger = integerToInt -- emulating what integer-{simple,gmp} already do - -integerToWord :: Integer -> Word# -integerToWord (S# i#) = int2Word# i# -integerToWord (Jp# bn) = bigNatToWord bn -integerToWord (Jn# bn) = int2Word# (negateInt# (bigNatToInt bn)) -{-# CONSTANT_FOLDED integerToWord #-} - -wordToInteger :: Word# -> Integer -wordToInteger w# - | isTrue# (i# >=# 0#) = S# i# - | True = Jp# (wordToBigNat w#) - where - i# = word2Int# w# -{-# CONSTANT_FOLDED wordToInteger #-} - -wordToNegInteger :: Word# -> Integer -wordToNegInteger w# - | isTrue# (i# <=# 0#) = S# i# - | True = Jn# (wordToBigNat w#) - where - i# = negateInt# (word2Int# w#) - --- we could almost auto-derive Ord if it wasn't for the Jn#-Jn# case -compareInteger :: Integer -> Integer -> Ordering -compareInteger (Jn# x) (Jn# y) = compareBigNat y x -compareInteger (S# x) (S# y) = compareInt# x y -compareInteger (Jp# x) (Jp# y) = compareBigNat x y -compareInteger (Jn# _) _ = LT -compareInteger (S# _) (Jp# _) = LT -compareInteger (S# _) (Jn# _) = GT -compareInteger (Jp# _) _ = GT -{-# CONSTANT_FOLDED compareInteger #-} - -isNegInteger# :: Integer -> Int# -isNegInteger# (S# i#) = i# <# 0# -isNegInteger# (Jp# _) = 0# -isNegInteger# (Jn# _) = 1# - --- | Not-equal predicate. -neqInteger :: Integer -> Integer -> Bool -neqInteger x y = isTrue# (neqInteger# x y) - -eqInteger, leInteger, ltInteger, gtInteger, geInteger - :: Integer -> Integer -> Bool -eqInteger x y = isTrue# (eqInteger# x y) -leInteger x y = isTrue# (leInteger# x y) -ltInteger x y = isTrue# (ltInteger# x y) -gtInteger x y = isTrue# (gtInteger# x y) -geInteger x y = isTrue# (geInteger# x y) - -eqInteger#, neqInteger#, leInteger#, ltInteger#, gtInteger#, geInteger# - :: Integer -> Integer -> Int# -eqInteger# (S# x#) (S# y#) = x# ==# y# -eqInteger# (Jn# x) (Jn# y) = eqBigNat# x y -eqInteger# (Jp# x) (Jp# y) = eqBigNat# x y -eqInteger# _ _ = 0# -{-# CONSTANT_FOLDED eqInteger# #-} - -neqInteger# (S# x#) (S# y#) = x# /=# y# -neqInteger# (Jn# x) (Jn# y) = neqBigNat# x y -neqInteger# (Jp# x) (Jp# y) = neqBigNat# x y -neqInteger# _ _ = 1# -{-# CONSTANT_FOLDED neqInteger# #-} - - -gtInteger# (S# x#) (S# y#) = x# ># y# -gtInteger# x y | inline compareInteger x y == GT = 1# -gtInteger# _ _ = 0# -{-# CONSTANT_FOLDED gtInteger# #-} - -leInteger# (S# x#) (S# y#) = x# <=# y# -leInteger# x y | inline compareInteger x y /= GT = 1# -leInteger# _ _ = 0# -{-# CONSTANT_FOLDED leInteger# #-} - -ltInteger# (S# x#) (S# y#) = x# <# y# -ltInteger# x y | inline compareInteger x y == LT = 1# -ltInteger# _ _ = 0# -{-# CONSTANT_FOLDED ltInteger# #-} - -geInteger# (S# x#) (S# y#) = x# >=# y# -geInteger# x y | inline compareInteger x y /= LT = 1# -geInteger# _ _ = 0# -{-# CONSTANT_FOLDED geInteger# #-} - --- | Compute absolute value of an 'Integer' -absInteger :: Integer -> Integer -absInteger (Jn# n) = Jp# n -absInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) -absInteger (S# i#) | isTrue# (i# <# 0#) = S# (negateInt# i#) -absInteger i@(S# _) = i -absInteger i@(Jp# _) = i -{-# CONSTANT_FOLDED absInteger #-} - --- | Return @-1@, @0@, and @1@ depending on whether argument is --- negative, zero, or positive, respectively -signumInteger :: Integer -> Integer -signumInteger j = S# (signumInteger# j) -{-# CONSTANT_FOLDED signumInteger #-} - --- | Return @-1#@, @0#@, and @1#@ depending on whether argument is --- negative, zero, or positive, respectively -signumInteger# :: Integer -> Int# -signumInteger# (Jn# _) = -1# -signumInteger# (S# i#) = sgnI# i# -signumInteger# (Jp# _ ) = 1# - --- | Negate 'Integer' -negateInteger :: Integer -> Integer -negateInteger (Jn# n) = Jp# n -negateInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) -negateInteger (S# i#) = S# (negateInt# i#) -negateInteger (Jp# bn) - | isTrue# (eqBigNatWord# bn ABS_INT_MINBOUND##) = S# INT_MINBOUND# - | True = Jn# bn -{-# CONSTANT_FOLDED negateInteger #-} - --- one edge-case issue to take into account is that Int's range is not --- symmetric around 0. I.e. @minBound+maxBound = -1@ --- --- Jp# is used iff n > maxBound::Int --- Jn# is used iff n < minBound::Int - --- | Add two 'Integer's -plusInteger :: Integer -> Integer -> Integer -plusInteger x (S# 0#) = x -plusInteger (S# 0#) y = y -plusInteger (S# x#) (S# y#) - = case addIntC# x# y# of - (# z#, 0# #) -> S# z# - (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) -- 2*minBound::Int - (# z#, _ #) - | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) - | True -> Jp# (wordToBigNat ( (int2Word# z#))) -plusInteger y@(S# _) x = plusInteger x y --- no S# as first arg from here on -plusInteger (Jp# x) (Jp# y) = Jp# (plusBigNat x y) -plusInteger (Jn# x) (Jn# y) = Jn# (plusBigNat x y) -plusInteger (Jp# x) (S# y#) -- edge-case: @(maxBound+1) + minBound == 0@ - | isTrue# (y# >=# 0#) = Jp# (plusBigNatWord x (int2Word# y#)) - | True = bigNatToInteger (minusBigNatWord x (int2Word# - (negateInt# y#))) -plusInteger (Jn# x) (S# y#) -- edge-case: @(minBound-1) + maxBound == -2@ - | isTrue# (y# >=# 0#) = bigNatToNegInteger (minusBigNatWord x (int2Word# y#)) - | True = Jn# (plusBigNatWord x (int2Word# (negateInt# y#))) -plusInteger y@(Jn# _) x@(Jp# _) = plusInteger x y -plusInteger (Jp# x) (Jn# y) - = case compareBigNat x y of - LT -> bigNatToNegInteger (minusBigNat y x) - EQ -> S# 0# - GT -> bigNatToInteger (minusBigNat x y) -{-# CONSTANT_FOLDED plusInteger #-} - --- | Subtract one 'Integer' from another. -minusInteger :: Integer -> Integer -> Integer -minusInteger x (S# 0#) = x -minusInteger (S# x#) (S# y#) - = case subIntC# x# y# of - (# z#, 0# #) -> S# z# - (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) - (# z#, _ #) - | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) - | True -> Jp# (wordToBigNat ( (int2Word# z#))) -minusInteger (S# x#) (Jp# y) - | isTrue# (x# >=# 0#) = bigNatToNegInteger (minusBigNatWord y (int2Word# x#)) - | True = Jn# (plusBigNatWord y (int2Word# (negateInt# x#))) -minusInteger (S# x#) (Jn# y) - | isTrue# (x# >=# 0#) = Jp# (plusBigNatWord y (int2Word# x#)) - | True = bigNatToInteger (minusBigNatWord y (int2Word# - (negateInt# x#))) -minusInteger (Jp# x) (Jp# y) - = case compareBigNat x y of - LT -> bigNatToNegInteger (minusBigNat y x) - EQ -> S# 0# - GT -> bigNatToInteger (minusBigNat x y) -minusInteger (Jp# x) (Jn# y) = Jp# (plusBigNat x y) -minusInteger (Jn# x) (Jp# y) = Jn# (plusBigNat x y) -minusInteger (Jn# x) (Jn# y) - = case compareBigNat x y of - LT -> bigNatToInteger (minusBigNat y x) - EQ -> S# 0# - GT -> bigNatToNegInteger (minusBigNat x y) -minusInteger (Jp# x) (S# y#) - | isTrue# (y# >=# 0#) = bigNatToInteger (minusBigNatWord x (int2Word# y#)) - | True = Jp# (plusBigNatWord x (int2Word# (negateInt# y#))) -minusInteger (Jn# x) (S# y#) - | isTrue# (y# >=# 0#) = Jn# (plusBigNatWord x (int2Word# y#)) - | True = bigNatToNegInteger (minusBigNatWord x - (int2Word# (negateInt# y#))) -{-# CONSTANT_FOLDED minusInteger #-} - --- | Multiply two 'Integer's -timesInteger :: Integer -> Integer -> Integer -timesInteger !_ (S# 0#) = S# 0# -timesInteger (S# 0#) _ = S# 0# -timesInteger x (S# 1#) = x -timesInteger (S# 1#) y = y -timesInteger x (S# -1#) = negateInteger x -timesInteger (S# -1#) y = negateInteger y -timesInteger (S# x#) (S# y#) = case timesInt2# x# y# of - (# 0#, _h, l #) -> S# l - (# _ , h, l #) -> int2ToInteger h l -timesInteger x@(S# _) y = timesInteger y x --- no S# as first arg from here on -timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y) -timesInteger (Jp# x) (Jn# y) = Jn# (timesBigNat x y) -timesInteger (Jp# x) (S# y#) - | isTrue# (y# >=# 0#) = Jp# (timesBigNatWord x (int2Word# y#)) - | True = Jn# (timesBigNatWord x (int2Word# (negateInt# y#))) -timesInteger (Jn# x) (Jn# y) = Jp# (timesBigNat x y) -timesInteger (Jn# x) (Jp# y) = Jn# (timesBigNat x y) -timesInteger (Jn# x) (S# y#) - | isTrue# (y# >=# 0#) = Jn# (timesBigNatWord x (int2Word# y#)) - | True = Jp# (timesBigNatWord x (int2Word# (negateInt# y#))) -{-# CONSTANT_FOLDED timesInteger #-} - --- | Square 'Integer' -sqrInteger :: Integer -> Integer -sqrInteger (S# INT_MINBOUND#) = timesInt2Integer INT_MINBOUND# INT_MINBOUND# -sqrInteger (S# j#) | isTrue# (absI# j# <=# SQRT_INT_MAXBOUND#) = S# (j# *# j#) -sqrInteger (S# j#) = timesInt2Integer j# j# -sqrInteger (Jp# bn) = Jp# (sqrBigNat bn) -sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) - --- | Convert two Int# (resp. high and low bits of a double-word Int#) into an --- Integer --- --- Warning: currently it doesn't handle the case where high=minBound and low=0 --- (i.e. high:low = 100......00 = minBound for a double-word Int) -int2ToInteger :: Int# -> Int# -> Integer -int2ToInteger h l - | isTrue# (h <# 0#) = - case addWordC# (not# (int2Word# l)) 1## of -- two's complement... - (# lw,c #) -> Jn# (wordToBigNat2 - -- add the carry to the high word - (int2Word# c `plusWord#` not# (int2Word# h)) - lw - ) - | True = Jp# (wordToBigNat2 (int2Word# h) (int2Word# l)) - --- | Construct 'Integer' from the product of two 'Int#'s -timesInt2Integer :: Int# -> Int# -> Integer -timesInt2Integer x# y# = case (# isTrue# (x# >=# 0#), isTrue# (y# >=# 0#) #) of - (# False, False #) -> case timesWord2# (int2Word# (negateInt# x#)) - (int2Word# (negateInt# y#)) of - (# 0##,l #) -> inline wordToInteger l - (# h ,l #) -> Jp# (wordToBigNat2 h l) - - (# True, False #) -> case timesWord2# (int2Word# x#) - (int2Word# (negateInt# y#)) of - (# 0##,l #) -> wordToNegInteger l - (# h ,l #) -> Jn# (wordToBigNat2 h l) - - (# False, True #) -> case timesWord2# (int2Word# (negateInt# x#)) - (int2Word# y#) of - (# 0##,l #) -> wordToNegInteger l - (# h ,l #) -> Jn# (wordToBigNat2 h l) - - (# True, True #) -> case timesWord2# (int2Word# x#) - (int2Word# y#) of - (# 0##,l #) -> inline wordToInteger l - (# h ,l #) -> Jp# (wordToBigNat2 h l) - -bigNatToInteger :: BigNat -> Integer -bigNatToInteger bn - | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# >=# 0#)) = S# i# - | True = Jp# bn - where - i# = word2Int# (bigNatToWord bn) - -bigNatToNegInteger :: BigNat -> Integer -bigNatToNegInteger bn - | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# <=# 0#)) = S# i# - | True = Jn# bn - where - i# = negateInt# (word2Int# (bigNatToWord bn)) - --- | Count number of set bits. For negative arguments returns negative --- population count of negated argument. -popCountInteger :: Integer -> Int# -popCountInteger (S# i#) - | isTrue# (i# >=# 0#) = popCntI# i# - | True = negateInt# (popCntI# (negateInt# i#)) -popCountInteger (Jp# bn) = popCountBigNat bn -popCountInteger (Jn# bn) = negateInt# (popCountBigNat bn) -{-# CONSTANT_FOLDED popCountInteger #-} - --- | 'Integer' for which only /n/-th bit is set. Undefined behaviour --- for negative /n/ values. -bitInteger :: Int# -> Integer -bitInteger i# - | isTrue# (i# <# (GMP_LIMB_BITS# -# 1#)) = S# (uncheckedIShiftL# 1# i#) - | True = Jp# (bitBigNat i#) -{-# CONSTANT_FOLDED bitInteger #-} - --- | Test if /n/-th bit is set. -testBitInteger :: Integer -> Int# -> Bool -testBitInteger !_ n# | isTrue# (n# <# 0#) = False -testBitInteger (S# i#) n# - | isTrue# (n# <# GMP_LIMB_BITS#) = isTrue# (((uncheckedIShiftL# 1# n#) - `andI#` i#) /=# 0#) - | True = isTrue# (i# <# 0#) -testBitInteger (Jp# bn) n = testBitBigNat bn n -testBitInteger (Jn# bn) n = testBitNegBigNat bn n -{-# CONSTANT_FOLDED testBitInteger #-} - --- | Bitwise @NOT@ operation -complementInteger :: Integer -> Integer -complementInteger (S# i#) = S# (notI# i#) -complementInteger (Jp# bn) = Jn# (plusBigNatWord bn 1##) -complementInteger (Jn# bn) = Jp# (minusBigNatWord bn 1##) -{-# CONSTANT_FOLDED complementInteger #-} - --- | Arithmetic shift-right operation --- --- Even though the shift-amount is expressed as `Int#`, the result is --- undefined for negative shift-amounts. -shiftRInteger :: Integer -> Int# -> Integer -shiftRInteger x 0# = x -shiftRInteger (S# i#) n# = S# (iShiftRA# i# n#) - where - iShiftRA# a b - | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#) - | True = a `uncheckedIShiftRA#` b -shiftRInteger (Jp# bn) n# = bigNatToInteger (shiftRBigNat bn n#) -shiftRInteger (Jn# bn) n# - = case bigNatToNegInteger (shiftRNegBigNat bn n#) of - S# 0# -> S# -1# - r -> r -{-# CONSTANT_FOLDED shiftRInteger #-} - --- | Shift-left operation --- --- Even though the shift-amount is expressed as `Int#`, the result is --- undefined for negative shift-amounts. -shiftLInteger :: Integer -> Int# -> Integer -shiftLInteger x 0# = x -shiftLInteger (S# 0#) _ = S# 0# -shiftLInteger (S# 1#) n# = bitInteger n# -shiftLInteger (S# i#) n# - | isTrue# (i# >=# 0#) = bigNatToInteger (shiftLBigNat - (wordToBigNat (int2Word# i#)) n#) - | True = bigNatToNegInteger (shiftLBigNat - (wordToBigNat (int2Word# - (negateInt# i#))) n#) -shiftLInteger (Jp# bn) n# = Jp# (shiftLBigNat bn n#) -shiftLInteger (Jn# bn) n# = Jn# (shiftLBigNat bn n#) -{-# CONSTANT_FOLDED shiftLInteger #-} - --- | Bitwise OR operation -orInteger :: Integer -> Integer -> Integer --- short-cuts -orInteger (S# 0#) y = y -orInteger x (S# 0#) = x -orInteger (S# -1#) _ = S# -1# -orInteger _ (S# -1#) = S# -1# --- base-cases -orInteger (S# x#) (S# y#) = S# (orI# x# y#) -orInteger (Jp# x) (Jp# y) = Jp# (orBigNat x y) -orInteger (Jn# x) (Jn# y) - = bigNatToNegInteger (plusBigNatWord (andBigNat - (minusBigNatWord x 1##) - (minusBigNatWord y 1##)) 1##) -orInteger x@(Jn# _) y@(Jp# _) = orInteger y x -- retry with swapped args -orInteger (Jp# x) (Jn# y) - = bigNatToNegInteger (plusBigNatWord (andnBigNat (minusBigNatWord y 1##) x) - 1##) --- TODO/FIXpromotion-hack -orInteger x@(S# _) y = orInteger (unsafePromote x) y -orInteger x y {- S# -}= orInteger x (unsafePromote y) -{-# CONSTANT_FOLDED orInteger #-} - --- | Bitwise XOR operation -xorInteger :: Integer -> Integer -> Integer --- short-cuts -xorInteger (S# 0#) y = y -xorInteger x (S# 0#) = x --- TODO: (S# -1) cases --- base-cases -xorInteger (S# x#) (S# y#) = S# (xorI# x# y#) -xorInteger (Jp# x) (Jp# y) = bigNatToInteger (xorBigNat x y) -xorInteger (Jn# x) (Jn# y) - = bigNatToInteger (xorBigNat (minusBigNatWord x 1##) - (minusBigNatWord y 1##)) -xorInteger x@(Jn# _) y@(Jp# _) = xorInteger y x -- retry with swapped args -xorInteger (Jp# x) (Jn# y) - = bigNatToNegInteger (plusBigNatWord (xorBigNat x (minusBigNatWord y 1##)) - 1##) --- TODO/FIXME promotion-hack -xorInteger x@(S# _) y = xorInteger (unsafePromote x) y -xorInteger x y {- S# -} = xorInteger x (unsafePromote y) -{-# CONSTANT_FOLDED xorInteger #-} - --- | Bitwise AND operation -andInteger :: Integer -> Integer -> Integer --- short-cuts -andInteger (S# 0#) !_ = S# 0# -andInteger _ (S# 0#) = S# 0# -andInteger (S# -1#) y = y -andInteger x (S# -1#) = x --- base-cases -andInteger (S# x#) (S# y#) = S# (andI# x# y#) -andInteger (Jp# x) (Jp# y) = bigNatToInteger (andBigNat x y) -andInteger (Jn# x) (Jn# y) - = bigNatToNegInteger (plusBigNatWord (orBigNat (minusBigNatWord x 1##) - (minusBigNatWord y 1##)) 1##) -andInteger x@(Jn# _) y@(Jp# _) = andInteger y x -andInteger (Jp# x) (Jn# y) - = bigNatToInteger (andnBigNat x (minusBigNatWord y 1##)) --- TODO/FIXME promotion-hack -andInteger x@(S# _) y = andInteger (unsafePromote x) y -andInteger x y {- S# -}= andInteger x (unsafePromote y) -{-# CONSTANT_FOLDED andInteger #-} - --- HACK warning! breaks invariant on purpose -unsafePromote :: Integer -> Integer -unsafePromote (S# x#) - | isTrue# (x# >=# 0#) = Jp# (wordToBigNat (int2Word# x#)) - | True = Jn# (wordToBigNat (int2Word# (negateInt# x#))) -unsafePromote x = x - --- | Simultaneous 'quotInteger' and 'remInteger'. --- --- Divisor must be non-zero otherwise the GHC runtime will terminate --- with a division-by-zero fault. -quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) -quotRemInteger n (S# 1#) = (# n, S# 0# #) -quotRemInteger n (S# -1#) = let !q = negateInteger n in (# q, (S# 0#) #) -quotRemInteger !_ (S# 0#) = (# S# (quotInt# 0# 0#),S# (remInt# 0# 0#) #) -quotRemInteger (S# 0#) _ = (# S# 0#, S# 0# #) -quotRemInteger (S# n#) (S# d#) = case quotRemInt# n# d# of - (# q#, r# #) -> (# S# q#, S# r# #) -quotRemInteger (Jp# n) (Jp# d) = case quotRemBigNat n d of - (# q, r #) -> (# bigNatToInteger q, bigNatToInteger r #) -quotRemInteger (Jp# n) (Jn# d) = case quotRemBigNat n d of - (# q, r #) -> (# bigNatToNegInteger q, bigNatToInteger r #) -quotRemInteger (Jn# n) (Jn# d) = case quotRemBigNat n d of - (# q, r #) -> (# bigNatToInteger q, bigNatToNegInteger r #) -quotRemInteger (Jn# n) (Jp# d) = case quotRemBigNat n d of - (# q, r #) -> (# bigNatToNegInteger q, bigNatToNegInteger r #) -quotRemInteger (Jp# n) (S# d#) - | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of - (# q, r# #) -> (# bigNatToInteger q, inline wordToInteger r# #) - | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of - (# q, r# #) -> (# bigNatToNegInteger q, inline wordToInteger r# #) -quotRemInteger (Jn# n) (S# d#) - | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of - (# q, r# #) -> (# bigNatToNegInteger q, wordToNegInteger r# #) - | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of - (# q, r# #) -> (# bigNatToInteger q, wordToNegInteger r# #) -quotRemInteger n@(S# _) (Jn# _) = (# S# 0#, n #) -- since @n < d@ -quotRemInteger n@(S# n#) (Jp# d) -- need to account for (S# minBound) - | isTrue# (n# ># 0#) = (# S# 0#, n #) - | isTrue# (gtBigNatWord# d (int2Word# (negateInt# n#))) = (# S# 0#, n #) - | True {- abs(n) == d -} = (# S# -1#, S# 0# #) -{-# CONSTANT_FOLDED quotRemInteger #-} - - -quotInteger :: Integer -> Integer -> Integer -quotInteger n (S# 1#) = n -quotInteger n (S# -1#) = negateInteger n -quotInteger !_ (S# 0#) = S# (quotInt# 0# 0#) -quotInteger (S# 0#) _ = S# 0# -quotInteger (S# n#) (S# d#) = S# (quotInt# n# d#) -quotInteger (Jp# n) (S# d#) - | isTrue# (d# >=# 0#) = bigNatToInteger (quotBigNatWord n (int2Word# d#)) - | True = bigNatToNegInteger (quotBigNatWord n - (int2Word# (negateInt# d#))) -quotInteger (Jn# n) (S# d#) - | isTrue# (d# >=# 0#) = bigNatToNegInteger (quotBigNatWord n (int2Word# d#)) - | True = bigNatToInteger (quotBigNatWord n - (int2Word# (negateInt# d#))) -quotInteger (Jp# n) (Jp# d) = bigNatToInteger (quotBigNat n d) -quotInteger (Jp# n) (Jn# d) = bigNatToNegInteger (quotBigNat n d) -quotInteger (Jn# n) (Jp# d) = bigNatToNegInteger (quotBigNat n d) -quotInteger (Jn# n) (Jn# d) = bigNatToInteger (quotBigNat n d) --- handle remaining non-allocating cases -quotInteger n d = case inline quotRemInteger n d of (# q, _ #) -> q -{-# CONSTANT_FOLDED quotInteger #-} - -remInteger :: Integer -> Integer -> Integer -remInteger !_ (S# 1#) = S# 0# -remInteger _ (S# -1#) = S# 0# -remInteger _ (S# 0#) = S# (remInt# 0# 0#) -remInteger (S# 0#) _ = S# 0# -remInteger (S# n#) (S# d#) = S# (remInt# n# d#) -remInteger (Jp# n) (S# d#) - = wordToInteger (remBigNatWord n (int2Word# (absI# d#))) -remInteger (Jn# n) (S# d#) - = wordToNegInteger (remBigNatWord n (int2Word# (absI# d#))) -remInteger (Jp# n) (Jp# d) = bigNatToInteger (remBigNat n d) -remInteger (Jp# n) (Jn# d) = bigNatToInteger (remBigNat n d) -remInteger (Jn# n) (Jp# d) = bigNatToNegInteger (remBigNat n d) -remInteger (Jn# n) (Jn# d) = bigNatToNegInteger (remBigNat n d) --- handle remaining non-allocating cases -remInteger n d = case inline quotRemInteger n d of (# _, r #) -> r -{-# CONSTANT_FOLDED remInteger #-} - --- | Simultaneous 'divInteger' and 'modInteger'. --- --- Divisor must be non-zero otherwise the GHC runtime will terminate --- with a division-by-zero fault. -divModInteger :: Integer -> Integer -> (# Integer, Integer #) -divModInteger n d - | isTrue# (signumInteger# r ==# negateInt# (signumInteger# d)) - = let !q' = plusInteger q (S# -1#) -- TODO: optimize - !r' = plusInteger r d - in (# q', r' #) - | True = qr - where - !qr@(# q, r #) = quotRemInteger n d -{-# CONSTANT_FOLDED divModInteger #-} - -divInteger :: Integer -> Integer -> Integer --- same-sign ops can be handled by more efficient 'quotInteger' -divInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = quotInteger n d -divInteger n d = case inline divModInteger n d of (# q, _ #) -> q -{-# CONSTANT_FOLDED divInteger #-} - -modInteger :: Integer -> Integer -> Integer --- same-sign ops can be handled by more efficient 'remInteger' -modInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = remInteger n d -modInteger n d = case inline divModInteger n d of (# _, r #) -> r -{-# CONSTANT_FOLDED modInteger #-} - --- | Compute greatest common divisor. -gcdInteger :: Integer -> Integer -> Integer -gcdInteger (S# 0#) b = absInteger b -gcdInteger a (S# 0#) = absInteger a -gcdInteger (S# 1#) _ = S# 1# -gcdInteger (S# -1#) _ = S# 1# -gcdInteger _ (S# 1#) = S# 1# -gcdInteger _ (S# -1#) = S# 1# -gcdInteger (S# a#) (S# b#) - = wordToInteger (gcdWord# (int2Word# (absI# a#)) (int2Word# (absI# b#))) -gcdInteger a@(S# _) b = gcdInteger b a -gcdInteger (Jn# a) b = gcdInteger (Jp# a) b -gcdInteger (Jp# a) (Jp# b) = bigNatToInteger (gcdBigNat a b) -gcdInteger (Jp# a) (Jn# b) = bigNatToInteger (gcdBigNat a b) -gcdInteger (Jp# a) (S# b#) - = wordToInteger (gcdBigNatWord a (int2Word# (absI# b#))) -{-# CONSTANT_FOLDED gcdInteger #-} - --- | Compute least common multiple. -lcmInteger :: Integer -> Integer -> Integer -lcmInteger (S# 0#) !_ = S# 0# -lcmInteger (S# 1#) b = absInteger b -lcmInteger (S# -1#) b = absInteger b -lcmInteger _ (S# 0#) = S# 0# -lcmInteger a (S# 1#) = absInteger a -lcmInteger a (S# -1#) = absInteger a -lcmInteger a b = (aa `quotInteger` (aa `gcdInteger` ab)) `timesInteger` ab - where - aa = absInteger a - ab = absInteger b -{-# CONSTANT_FOLDED lcmInteger #-} - --- | Compute greatest common divisor. --- --- __Warning__: result may become negative if (at least) one argument --- is 'minBound' -gcdInt :: Int# -> Int# -> Int# -gcdInt x# y# - = word2Int# (gcdWord# (int2Word# (absI# x#)) (int2Word# (absI# y#))) - --- | Compute greatest common divisor. --- --- @since 1.0.0.0 -gcdWord :: Word# -> Word# -> Word# -gcdWord = gcdWord# - ----------------------------------------------------------------------------- --- BigNat operations - -compareBigNat :: BigNat -> BigNat -> Ordering -compareBigNat x@(BN# x#) y@(BN# y#) - | isTrue# (nx# ==# ny#) - = compareInt# (narrowCInt# (c_mpn_cmp x# y# nx#)) 0# - | isTrue# (nx# <# ny#) = LT - | True = GT - where - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - -compareBigNatWord :: BigNat -> GmpLimb# -> Ordering -compareBigNatWord bn w# - | isTrue# (sizeofBigNat# bn ==# 1#) = cmpW# (bigNatToWord bn) w# - | True = GT - -gtBigNatWord# :: BigNat -> GmpLimb# -> Int# -gtBigNatWord# bn w# - = (sizeofBigNat# bn ># 1#) `orI#` (bigNatToWord bn `gtWord#` w#) - -eqBigNat :: BigNat -> BigNat -> Bool -eqBigNat x y = isTrue# (eqBigNat# x y) - -eqBigNat# :: BigNat -> BigNat -> Int# -eqBigNat# x@(BN# x#) y@(BN# y#) - | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# ==# 0# - | True = 0# - where - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - -neqBigNat# :: BigNat -> BigNat -> Int# -neqBigNat# x@(BN# x#) y@(BN# y#) - | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# /=# 0# - | True = 1# - where - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - -eqBigNatWord :: BigNat -> GmpLimb# -> Bool -eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#) - -eqBigNatWord# :: BigNat -> GmpLimb# -> Int# -eqBigNatWord# bn w# - = (sizeofBigNat# bn ==# 1#) `andI#` (bigNatToWord bn `eqWord#` w#) - - --- | Same as @'indexBigNat#' bn 0\#@ -bigNatToWord :: BigNat -> Word# -bigNatToWord bn = indexBigNat# bn 0# - --- | Equivalent to @'word2Int#' . 'bigNatToWord'@ -bigNatToInt :: BigNat -> Int# -bigNatToInt (BN# ba#) = indexIntArray# ba# 0# - --- | CAF representing the value @0 :: BigNat@ -zeroBigNat :: BigNat -zeroBigNat = runS $ do - mbn <- newBigNat# 1# - _ <- svoid (writeBigNat# mbn 0# 0##) - unsafeFreezeBigNat# mbn -{-# NOINLINE zeroBigNat #-} - --- | Test if 'BigNat' value is equal to zero. -isZeroBigNat :: BigNat -> Bool -isZeroBigNat bn = eqBigNatWord bn 0## - --- | CAF representing the value @1 :: BigNat@ -oneBigNat :: BigNat -oneBigNat = runS $ do - mbn <- newBigNat# 1# - _ <- svoid (writeBigNat# mbn 0# 1##) - unsafeFreezeBigNat# mbn -{-# NOINLINE oneBigNat #-} - -czeroBigNat :: BigNat -czeroBigNat = runS $ do - mbn <- newBigNat# 1# - _ <- svoid (writeBigNat# mbn 0# (not# 0##)) - unsafeFreezeBigNat# mbn -{-# NOINLINE czeroBigNat #-} - --- | Special 0-sized bigNat returned in case of arithmetic underflow --- --- This is currently only returned by the following operations: --- --- - 'minusBigNat' --- - 'minusBigNatWord' --- --- Other operations such as 'quotBigNat' may return 'nullBigNat' as --- well as a dummy/place-holder value instead of 'undefined' since we --- can't throw exceptions. But that behaviour should not be relied --- upon. --- --- NB: @isValidBigNat# nullBigNat@ is false -nullBigNat :: BigNat -nullBigNat = runS (newBigNat# 0# >>= unsafeFreezeBigNat#) -{-# NOINLINE nullBigNat #-} - --- | Test for special 0-sized 'BigNat' representing underflows. -isNullBigNat# :: BigNat -> Int# -isNullBigNat# (BN# ba#) = sizeofByteArray# ba# ==# 0# - --- | Construct 1-limb 'BigNat' from 'Word#' -wordToBigNat :: Word# -> BigNat -wordToBigNat 0## = zeroBigNat -wordToBigNat 1## = oneBigNat -wordToBigNat w# - | isTrue# (not# w# `eqWord#` 0##) = czeroBigNat - | True = runS $ do - mbn <- newBigNat# 1# - _ <- svoid (writeBigNat# mbn 0# w#) - unsafeFreezeBigNat# mbn - --- | Construct BigNat from 2 limbs. --- The first argument is the most-significant limb. -wordToBigNat2 :: Word# -> Word# -> BigNat -wordToBigNat2 0## lw# = wordToBigNat lw# -wordToBigNat2 hw# lw# = runS $ do - mbn <- newBigNat# 2# - _ <- svoid (writeBigNat# mbn 0# lw#) - _ <- svoid (writeBigNat# mbn 1# hw#) - unsafeFreezeBigNat# mbn - -plusBigNat :: BigNat -> BigNat -> BigNat -plusBigNat x y - | isTrue# (eqBigNatWord# x 0##) = y - | isTrue# (eqBigNatWord# y 0##) = x - | isTrue# (nx# >=# ny#) = go x nx# y ny# - | True = go y ny# x nx# - where - go (BN# a#) na# (BN# b#) nb# = runS $ do - mbn@(MBN# mba#) <- newBigNat# na# - (W# c#) <- liftIO (c_mpn_add mba# a# na# b# nb#) - case c# of - 0## -> unsafeFreezeBigNat# mbn - _ -> unsafeSnocFreezeBigNat# mbn c# - - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - -plusBigNatWord :: BigNat -> GmpLimb# -> BigNat -plusBigNatWord x 0## = x -plusBigNatWord x@(BN# x#) y# = runS $ do - mbn@(MBN# mba#) <- newBigNat# nx# - (W# c#) <- liftIO (c_mpn_add_1 mba# x# nx# y#) - case c# of - 0## -> unsafeFreezeBigNat# mbn - _ -> unsafeSnocFreezeBigNat# mbn c# - where - nx# = sizeofBigNat# x - --- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow -minusBigNat :: BigNat -> BigNat -> BigNat -minusBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat y = x - | isTrue# (nx# >=# ny#) = runS $ do - mbn@(MBN# mba#) <- newBigNat# nx# - (W# b#) <- liftIO (c_mpn_sub mba# x# nx# y# ny#) - case b# of - 0## -> unsafeRenormFreezeBigNat# mbn - _ -> return nullBigNat - - | True = nullBigNat - where - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - --- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow -minusBigNatWord :: BigNat -> GmpLimb# -> BigNat -minusBigNatWord x 0## = x -minusBigNatWord x@(BN# x#) y# = runS $ do - mbn@(MBN# mba#) <- newBigNat# nx# - (W# b#) <- liftIO $ c_mpn_sub_1 mba# x# nx# y# - case b# of - 0## -> unsafeRenormFreezeBigNat# mbn - _ -> return nullBigNat - where - nx# = sizeofBigNat# x - - -timesBigNat :: BigNat -> BigNat -> BigNat -timesBigNat x y - | isZeroBigNat x = zeroBigNat - | isZeroBigNat y = zeroBigNat - | isTrue# (nx# >=# ny#) = go x nx# y ny# - | True = go y ny# x nx# - where - go (BN# a#) na# (BN# b#) nb# = runS $ do - let n# = nx# +# ny# - mbn@(MBN# mba#) <- newBigNat# n# - (W# msl#) <- liftIO (c_mpn_mul mba# a# na# b# nb#) - case msl# of - 0## -> unsafeShrinkFreezeBigNat# mbn (n# -# 1#) - _ -> unsafeFreezeBigNat# mbn - - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - --- | Square 'BigNat' -sqrBigNat :: BigNat -> BigNat -sqrBigNat x - | isZeroBigNat x = zeroBigNat - -- TODO: 1-limb BigNats below sqrt(maxBound::GmpLimb) -sqrBigNat x = timesBigNat x x -- TODO: mpn_sqr - -timesBigNatWord :: BigNat -> GmpLimb# -> BigNat -timesBigNatWord !_ 0## = zeroBigNat -timesBigNatWord x 1## = x -timesBigNatWord x@(BN# x#) y# - | isTrue# (nx# ==# 1#) = - let !(# !h#, !l# #) = timesWord2# (bigNatToWord x) y# - in wordToBigNat2 h# l# - | True = runS $ do - mbn@(MBN# mba#) <- newBigNat# nx# - (W# msl#) <- liftIO (c_mpn_mul_1 mba# x# nx# y#) - case msl# of - 0## -> unsafeFreezeBigNat# mbn - _ -> unsafeSnocFreezeBigNat# mbn msl# - - where - nx# = sizeofBigNat# x - --- | Specialised version of --- --- > bitBigNat = shiftLBigNat (wordToBigNat 1##) --- --- avoiding a few redundant allocations -bitBigNat :: Int# -> BigNat -bitBigNat i# - | isTrue# (i# <# 0#) = zeroBigNat -- or maybe 'nullBigNat'? - | isTrue# (i# ==# 0#) = oneBigNat - | True = runS $ do - mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) - -- FIXME: do we really need to zero-init MBAs returned by 'newByteArray#'? - -- clear all limbs (except for the most-significant limb) - _ <- svoid (clearWordArray# mba# 0# li#) - -- set single bit in most-significant limb - _ <- svoid (writeBigNat# mbn li# (uncheckedShiftL# 1## bi#)) - unsafeFreezeBigNat# mbn - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - -testBitBigNat :: BigNat -> Int# -> Bool -testBitBigNat bn i# - | isTrue# (i# <# 0#) = False - | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#) - | True = False - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - -testBitNegBigNat :: BigNat -> Int# -> Bool -testBitNegBigNat bn i# - | isTrue# (i# <# 0#) = False - | isTrue# (li# >=# nx#) = True - | allZ li# = isTrue# ((testBitWord# - (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#) - | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#) - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - - allZ 0# = True - allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#) - | True = False - - -clearBitBigNat :: BigNat -> Int# -> BigNat -clearBitBigNat bn i# - | not (inline testBitBigNat bn i#) = bn - | isTrue# (nx# ==# 1#) = wordToBigNat (bigNatToWord bn `xor#` bitWord# bi#) - | isTrue# (li# +# 1# ==# nx#) = -- special case, operating on most-sig limb - case indexBigNat# bn li# `xor#` bitWord# bi# of - 0## -> do -- most-sig limb became zero -> result has less limbs - case fmssl bn (li# -# 1#) of - 0# -> zeroBigNat - n# -> runS $ do - mbn <- newBigNat# n# - _ <- copyWordArray bn 0# mbn 0# n# - unsafeFreezeBigNat# mbn - newlimb# -> runS $ do -- no shrinking - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# li# - _ <- svoid (writeBigNat# mbn li# newlimb#) - unsafeFreezeBigNat# mbn - - | True = runS $ do - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# nx# - let newlimb# = indexBigNat# bn li# `xor#` bitWord# bi# - _ <- svoid (writeBigNat# mbn li# newlimb#) - unsafeFreezeBigNat# mbn - - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - - - -setBitBigNat :: BigNat -> Int# -> BigNat -setBitBigNat bn i# - | inline testBitBigNat bn i# = bn - | isTrue# (d# ># 0#) = runS $ do -- result BigNat will have more limbs - mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) - _ <- copyWordArray bn 0# mbn 0# nx# - _ <- svoid (clearWordArray# mba# nx# (d# -# 1#)) - _ <- svoid (writeBigNat# mbn li# (bitWord# bi#)) - unsafeFreezeBigNat# mbn - - | True = runS $ do - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# nx# - _ <- svoid (writeBigNat# mbn li# (indexBigNat# bn li# - `or#` bitWord# bi#)) - unsafeFreezeBigNat# mbn - - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - d# = li# +# 1# -# nx# - - -complementBitBigNat :: BigNat -> Int# -> BigNat -complementBitBigNat bn i# - | testBitBigNat bn i# = clearBitBigNat bn i# - | True = setBitBigNat bn i# - -popCountBigNat :: BigNat -> Int# -popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn)) - - -shiftLBigNat :: BigNat -> Int# -> BigNat -shiftLBigNat x 0# = x -shiftLBigNat x _ | isZeroBigNat x = zeroBigNat -shiftLBigNat x@(BN# xba#) n# = runS $ do - ymbn@(MBN# ymba#) <- newBigNat# yn# - W# ymsl <- liftIO (c_mpn_lshift ymba# xba# xn# (int2Word# n#)) - case ymsl of - 0## -> unsafeShrinkFreezeBigNat# ymbn (yn# -# 1#) - _ -> unsafeFreezeBigNat# ymbn - where - xn# = sizeofBigNat# x - yn# = xn# +# nlimbs# +# (nbits# /=# 0#) - !(# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# - - - -shiftRBigNat :: BigNat -> Int# -> BigNat -shiftRBigNat x 0# = x -shiftRBigNat x _ | isZeroBigNat x = zeroBigNat -shiftRBigNat x@(BN# xba#) n# - | isTrue# (nlimbs# >=# xn#) = zeroBigNat - | True = runS $ do - ymbn@(MBN# ymba#) <- newBigNat# yn# - W# ymsl <- liftIO (c_mpn_rshift ymba# xba# xn# (int2Word# n#)) - case ymsl of - 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one - _ -> unsafeFreezeBigNat# ymbn - where - xn# = sizeofBigNat# x - yn# = xn# -# nlimbs# - nlimbs# = quotInt# n# GMP_LIMB_BITS# - -shiftRNegBigNat :: BigNat -> Int# -> BigNat -shiftRNegBigNat x 0# = x -shiftRNegBigNat x _ | isZeroBigNat x = zeroBigNat -shiftRNegBigNat x@(BN# xba#) n# - | isTrue# (nlimbs# >=# xn#) = zeroBigNat - | True = runS $ do - ymbn@(MBN# ymba#) <- newBigNat# yn# - W# ymsl <- liftIO (c_mpn_rshift_2c ymba# xba# xn# (int2Word# n#)) - case ymsl of - 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one - _ -> unsafeFreezeBigNat# ymbn - where - xn# = sizeofBigNat# x - yn# = xn# -# nlimbs# - nlimbs# = quotInt# (n# -# 1#) GMP_LIMB_BITS# - - -orBigNat :: BigNat -> BigNat -> BigNat -orBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat x = y - | isZeroBigNat y = x - | isTrue# (nx# >=# ny#) = runS (ior' x# nx# y# ny#) - | True = runS (ior' y# ny# x# nx#) - where - ior' a# na# b# nb# = do -- na >= nb - mbn@(MBN# mba#) <- newBigNat# na# - _ <- liftIO (c_mpn_ior_n mba# a# b# nb#) - _ <- case isTrue# (na# ==# nb#) of - False -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - True -> return () - unsafeFreezeBigNat# mbn - - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - - -xorBigNat :: BigNat -> BigNat -> BigNat -xorBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat x = y - | isZeroBigNat y = x - | isTrue# (nx# >=# ny#) = runS (xor' x# nx# y# ny#) - | True = runS (xor' y# ny# x# nx#) - where - xor' a# na# b# nb# = do -- na >= nb - mbn@(MBN# mba#) <- newBigNat# na# - _ <- liftIO (c_mpn_xor_n mba# a# b# nb#) - case isTrue# (na# ==# nb#) of - False -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - unsafeFreezeBigNat# mbn - True -> unsafeRenormFreezeBigNat# mbn - - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - --- | aka @\x y -> x .&. (complement y)@ -andnBigNat :: BigNat -> BigNat -> BigNat -andnBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat x = zeroBigNat - | isZeroBigNat y = x - | True = runS $ do - mbn@(MBN# mba#) <- newBigNat# nx# - _ <- liftIO (c_mpn_andn_n mba# x# y# n#) - _ <- case isTrue# (nx# ==# n#) of - False -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) - True -> return () - unsafeRenormFreezeBigNat# mbn - where - n# | isTrue# (nx# <# ny#) = nx# - | True = ny# - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - - -andBigNat :: BigNat -> BigNat -> BigNat -andBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat x = zeroBigNat - | isZeroBigNat y = zeroBigNat - | True = runS $ do - mbn@(MBN# mba#) <- newBigNat# n# - _ <- liftIO (c_mpn_and_n mba# x# y# n#) - unsafeRenormFreezeBigNat# mbn - where - n# | isTrue# (nx# <# ny#) = nx# - | True = ny# - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - --- | If divisor is zero, @(\# 'nullBigNat', 'nullBigNat' \#)@ is returned -quotRemBigNat :: BigNat -> BigNat -> (# BigNat,BigNat #) -quotRemBigNat n@(BN# nba#) d@(BN# dba#) - | isZeroBigNat d = (# nullBigNat, nullBigNat #) - | eqBigNatWord d 1## = (# n, zeroBigNat #) - | n < d = (# zeroBigNat, n #) - | True = case runS go of (!q,!r) -> (# q, r #) - where - nn# = sizeofBigNat# n - dn# = sizeofBigNat# d - qn# = 1# +# nn# -# dn# - rn# = dn# - - go = do - qmbn@(MBN# qmba#) <- newBigNat# qn# - rmbn@(MBN# rmba#) <- newBigNat# rn# - - _ <- liftIO (c_mpn_tdiv_qr qmba# rmba# 0# nba# nn# dba# dn#) - - q <- unsafeRenormFreezeBigNat# qmbn - r <- unsafeRenormFreezeBigNat# rmbn - return (q, r) - -quotBigNat :: BigNat -> BigNat -> BigNat -quotBigNat n@(BN# nba#) d@(BN# dba#) - | isZeroBigNat d = nullBigNat - | eqBigNatWord d 1## = n - | n < d = zeroBigNat - | True = runS $ do - let nn# = sizeofBigNat# n - let dn# = sizeofBigNat# d - let qn# = 1# +# nn# -# dn# - qmbn@(MBN# qmba#) <- newBigNat# qn# - _ <- liftIO (c_mpn_tdiv_q qmba# nba# nn# dba# dn#) - unsafeRenormFreezeBigNat# qmbn - -remBigNat :: BigNat -> BigNat -> BigNat -remBigNat n@(BN# nba#) d@(BN# dba#) - | isZeroBigNat d = nullBigNat - | eqBigNatWord d 1## = zeroBigNat - | n < d = n - | True = runS $ do - let nn# = sizeofBigNat# n - let dn# = sizeofBigNat# d - rmbn@(MBN# rmba#) <- newBigNat# dn# - _ <- liftIO (c_mpn_tdiv_r rmba# nba# nn# dba# dn#) - unsafeRenormFreezeBigNat# rmbn - --- | Note: Result of div/0 undefined -quotRemBigNatWord :: BigNat -> GmpLimb# -> (# BigNat, GmpLimb# #) -quotRemBigNatWord !_ 0## = (# nullBigNat, 0## #) -quotRemBigNatWord n 1## = (# n, 0## #) -quotRemBigNatWord n@(BN# nba#) d# = case compareBigNatWord n d# of - LT -> (# zeroBigNat, bigNatToWord n #) - EQ -> (# oneBigNat, 0## #) - GT -> case runS go of (!q,!(W# r#)) -> (# q, r# #) -- TODO: handle word/word - where - go = do - let nn# = sizeofBigNat# n - qmbn@(MBN# qmba#) <- newBigNat# nn# - r <- liftIO (c_mpn_divrem_1 qmba# 0# nba# nn# d#) - q <- unsafeRenormFreezeBigNat# qmbn - return (q,r) - -quotBigNatWord :: BigNat -> GmpLimb# -> BigNat -quotBigNatWord n d# = case inline quotRemBigNatWord n d# of (# q, _ #) -> q - --- | div/0 not checked -remBigNatWord :: BigNat -> GmpLimb# -> Word# -remBigNatWord n@(BN# nba#) d# = c_mpn_mod_1 nba# (sizeofBigNat# n) d# - -gcdBigNatWord :: BigNat -> Word# -> Word# -gcdBigNatWord bn@(BN# ba#) = c_mpn_gcd_1# ba# (sizeofBigNat# bn) - -gcdBigNat :: BigNat -> BigNat -> BigNat -gcdBigNat x@(BN# x#) y@(BN# y#) - | isZeroBigNat x = y - | isZeroBigNat y = x - | isTrue# (nx# >=# ny#) = runS (gcd' x# nx# y# ny#) - | True = runS (gcd' y# ny# x# nx#) - where - gcd' a# na# b# nb# = do -- na >= nb - mbn@(MBN# mba#) <- newBigNat# nb# - I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#) - let rn# = narrowGmpSize# rn'# - case isTrue# (rn# ==# nb#) of - False -> unsafeShrinkFreezeBigNat# mbn rn# - True -> unsafeFreezeBigNat# mbn - - nx# = sizeofBigNat# x - ny# = sizeofBigNat# y - --- | Extended euclidean algorithm. --- --- For @/a/@ and @/b/@, compute their greatest common divisor @/g/@ --- and the coefficient @/s/@ satisfying @/a//s/ + /b//t/ = /g/@. --- --- @since 0.5.1.0 -{-# NOINLINE gcdExtInteger #-} -gcdExtInteger :: Integer -> Integer -> (# Integer, Integer #) -gcdExtInteger a b = case gcdExtSBigNat a' b' of - (# g, s #) -> let !g' = bigNatToInteger g - !s' = sBigNatToInteger s - in (# g', s' #) - where - a' = integerToSBigNat a - b' = integerToSBigNat b - --- internal helper -gcdExtSBigNat :: SBigNat -> SBigNat -> (# BigNat, SBigNat #) -gcdExtSBigNat x y = case runS go of (g,s) -> (# g, s #) - where - go = do - g@(MBN# g#) <- newBigNat# gn0# - -- According to https://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fgcdext - -- abs(s) < abs(y) / (2 g) - s@(MBN# s#) <- newBigNat# (absI# yn#) - I# ssn_# <- liftIO (integer_gmp_gcdext# s# g# x# xn# y# yn#) - let ssn# = narrowGmpSize# ssn_# - sn# = absI# ssn# - s' <- unsafeShrinkFreezeBigNat# s sn# - g' <- unsafeRenormFreezeBigNat# g - case isTrue# (ssn# >=# 0#) of - False -> return ( g', NegBN s' ) - True -> return ( g', PosBN s' ) - - !(BN# x#) = absSBigNat x - !(BN# y#) = absSBigNat y - xn# = ssizeofSBigNat# x - yn# = ssizeofSBigNat# y - - gn0# = minI# (absI# xn#) (absI# yn#) - ----------------------------------------------------------------------------- --- modular exponentiation - --- | \"@'powModInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @abs(/m/)@. --- --- Negative exponents are supported if an inverse modulo @/m/@ --- exists. --- --- __Warning__: It's advised to avoid calling this primitive with --- negative exponents unless it is guaranteed the inverse exists, as --- failure to do so will likely cause program abortion due to a --- divide-by-zero fault. See also 'recipModInteger'. --- --- Future versions of @integer_gmp@ may not support negative @/e/@ --- values anymore. --- --- @since 0.5.1.0 -{-# NOINLINE powModInteger #-} -powModInteger :: Integer -> Integer -> Integer -> Integer -powModInteger (S# b#) (S# e#) (S# m#) - | isTrue# (b# >=# 0#), isTrue# (e# >=# 0#) - = wordToInteger (powModWord (int2Word# b#) (int2Word# e#) - (int2Word# (absI# m#))) -powModInteger b e m = case m of - (S# m#) -> wordToInteger (powModSBigNatWord b' e' (int2Word# (absI# m#))) - (Jp# m') -> bigNatToInteger (powModSBigNat b' e' m') - (Jn# m') -> bigNatToInteger (powModSBigNat b' e' m') - where - b' = integerToSBigNat b - e' = integerToSBigNat e - --- | \"@'powModSecInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. It is required that @/e/ >= 0@ and --- @/m/@ is odd. --- --- This is a \"secure\" variant of 'powModInteger' using the --- @mpz_powm_sec()@ function which is designed to be resilient to side --- channel attacks and is therefore intended for cryptographic --- applications. --- --- This primitive is only available when the underlying GMP library --- supports it (GMP >= 5). Otherwise, it internally falls back to --- @'powModInteger'@, and a warning will be emitted when used. --- --- @since 1.0.2.0 -{-# NOINLINE powModSecInteger #-} -powModSecInteger :: Integer -> Integer -> Integer -> Integer -powModSecInteger b e m = bigNatToInteger (powModSecSBigNat b' e' m') - where - b' = integerToSBigNat b - e' = integerToSBigNat e - m' = absSBigNat (integerToSBigNat m) - -#if HAVE_SECURE_POWM == 0 -{-# WARNING powModSecInteger "The underlying GMP library does not support a secure version of powModInteger which is side-channel resistant - you need at least GMP version 5 to support this" #-} -#endif - --- | Version of 'powModInteger' operating on 'BigNat's --- --- @since 1.0.0.0 -powModBigNat :: BigNat -> BigNat -> BigNat -> BigNat -powModBigNat b e m = inline powModSBigNat (PosBN b) (PosBN e) m - --- | Version of 'powModInteger' for 'Word#'-sized moduli --- --- @since 1.0.0.0 -powModBigNatWord :: BigNat -> BigNat -> GmpLimb# -> GmpLimb# -powModBigNatWord b e m# = inline powModSBigNatWord (PosBN b) (PosBN e) m# - --- | Version of 'powModInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_powm_word" - powModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# - --- internal non-exported helper -powModSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat -powModSBigNat b e m@(BN# m#) = runS $ do - r@(MBN# r#) <- newBigNat# mn# - I# rn_# <- liftIO (integer_gmp_powm# r# b# bn# e# en# m# mn#) - let rn# = narrowGmpSize# rn_# - case isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> unsafeFreezeBigNat# r - where - !(BN# b#) = absSBigNat b - !(BN# e#) = absSBigNat e - bn# = ssizeofSBigNat# b - en# = ssizeofSBigNat# e - mn# = sizeofBigNat# m - -foreign import ccall unsafe "integer_gmp_powm" - integer_gmp_powm# :: MutableByteArray# RealWorld - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - --- internal non-exported helper -powModSBigNatWord :: SBigNat -> SBigNat -> GmpLimb# -> GmpLimb# -powModSBigNatWord b e m# = integer_gmp_powm1# b# bn# e# en# m# - where - !(BN# b#) = absSBigNat b - !(BN# e#) = absSBigNat e - bn# = ssizeofSBigNat# b - en# = ssizeofSBigNat# e - -foreign import ccall unsafe "integer_gmp_powm1" - integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> GmpLimb# -> GmpLimb# - --- internal non-exported helper -powModSecSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat -powModSecSBigNat b e m@(BN# m#) = runS $ do - r@(MBN# r#) <- newBigNat# mn# - I# rn_# <- liftIO (integer_gmp_powm_sec# r# b# bn# e# en# m# mn#) - let rn# = narrowGmpSize# rn_# - case isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> unsafeFreezeBigNat# r - where - !(BN# b#) = absSBigNat b - !(BN# e#) = absSBigNat e - bn# = ssizeofSBigNat# b - en# = ssizeofSBigNat# e - mn# = sizeofBigNat# m - -foreign import ccall unsafe "integer_gmp_powm_sec" - integer_gmp_powm_sec# :: MutableByteArray# RealWorld - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - - --- | \"@'recipModInteger' /x/ /m/@\" computes the inverse of @/x/@ modulo @/m/@. If --- the inverse exists, the return value @/y/@ will satisfy @0 < /y/ < --- abs(/m/)@, otherwise the result is @0@. --- --- @since 0.5.1.0 -{-# NOINLINE recipModInteger #-} -recipModInteger :: Integer -> Integer -> Integer -recipModInteger (S# x#) (S# m#) - | isTrue# (x# >=# 0#) - = wordToInteger (recipModWord (int2Word# x#) (int2Word# (absI# m#))) -recipModInteger x m = bigNatToInteger (recipModSBigNat x' m') - where - x' = integerToSBigNat x - m' = absSBigNat (integerToSBigNat m) - --- | Version of 'recipModInteger' operating on 'BigNat's --- --- @since 1.0.0.0 -recipModBigNat :: BigNat -> BigNat -> BigNat -recipModBigNat x m = inline recipModSBigNat (PosBN x) m - --- | Version of 'recipModInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_invert_word" - recipModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# - --- internal non-exported helper -recipModSBigNat :: SBigNat -> BigNat -> BigNat -recipModSBigNat x m@(BN# m#) = runS $ do - r@(MBN# r#) <- newBigNat# mn# - I# rn_# <- liftIO (integer_gmp_invert# r# x# xn# m# mn#) - let rn# = narrowGmpSize# rn_# - case isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> unsafeFreezeBigNat# r - where - !(BN# x#) = absSBigNat x - xn# = ssizeofSBigNat# x - mn# = sizeofBigNat# m - -foreign import ccall unsafe "integer_gmp_invert" - integer_gmp_invert# :: MutableByteArray# RealWorld - -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - ----------------------------------------------------------------------------- --- Conversions to/from floating point - -decodeDoubleInteger :: Double# -> (# Integer, Int# #) --- decodeDoubleInteger 0.0## = (# S# 0#, 0# #) -#if WORD_SIZE_IN_BITS == 64 -decodeDoubleInteger x = case decodeDouble_Int64# x of - (# m#, e# #) -> (# S# m#, e# #) -#elif WORD_SIZE_IN_BITS == 32 -decodeDoubleInteger x = case decodeDouble_Int64# x of - (# m#, e# #) -> (# int64ToInteger m#, e# #) -#endif -{-# CONSTANT_FOLDED decodeDoubleInteger #-} - --- provided by GHC's RTS -foreign import ccall unsafe "__int_encodeDouble" - int_encodeDouble# :: Int# -> Int# -> Double# - -encodeDoubleInteger :: Integer -> Int# -> Double# -encodeDoubleInteger (S# m#) 0# = int2Double# m# -encodeDoubleInteger (S# m#) e# = int_encodeDouble# m# e# -encodeDoubleInteger (Jp# bn@(BN# bn#)) e# - = c_mpn_get_d bn# (sizeofBigNat# bn) e# -encodeDoubleInteger (Jn# bn@(BN# bn#)) e# - = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) e# -{-# CONSTANT_FOLDED encodeDoubleInteger #-} - --- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) -foreign import ccall unsafe "integer_gmp_mpn_get_d" - c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# - -doubleFromInteger :: Integer -> Double# -doubleFromInteger (S# m#) = int2Double# m# -doubleFromInteger (Jp# bn@(BN# bn#)) - = c_mpn_get_d bn# (sizeofBigNat# bn) 0# -doubleFromInteger (Jn# bn@(BN# bn#)) - = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) 0# -{-# CONSTANT_FOLDED doubleFromInteger #-} - --- TODO: Not sure if it's worth to write 'Float' optimized versions here -floatFromInteger :: Integer -> Float# -floatFromInteger i = double2Float# (doubleFromInteger i) - -encodeFloatInteger :: Integer -> Int# -> Float# -encodeFloatInteger m e = double2Float# (encodeDoubleInteger m e) - ----------------------------------------------------------------------------- --- FFI ccall imports - -foreign import ccall unsafe "integer_gmp_gcd_word" - gcdWord# :: GmpLimb# -> GmpLimb# -> GmpLimb# - -foreign import ccall unsafe "integer_gmp_mpn_gcd_1" - c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# - -foreign import ccall unsafe "integer_gmp_mpn_gcd" - c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - -foreign import ccall unsafe "integer_gmp_gcdext" - integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s - -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - --- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_add_1" - c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_sub_1" - c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_mul_1" - c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_add" - c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpLimb - --- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_sub" - c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO GmpLimb - --- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_mul" - c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO GmpLimb - --- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) -foreign import ccall unsafe "gmp.h __gmpn_cmp" - c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> CInt# - --- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, --- const mp_limb_t *np, mp_size_t nn, --- const mp_limb_t *dp, mp_size_t dn) -foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" - c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () - -foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" - c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO () - -foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" - c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO () - --- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, --- mp_size_t s2n, mp_limb_t s3limb) -foreign import ccall unsafe "gmp.h __gmpn_divrem_1" - c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# - -> GmpLimb# -> IO GmpLimb - --- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_mod_1" - c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# - --- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_rshift" - c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# - -> IO GmpLimb - --- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" - c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# - -> IO GmpLimb - --- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_lshift" - c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# - -> IO GmpLimb - --- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_and_n" - c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_andn_n" - c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_ior_n" - c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_xor_n" - c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) -foreign import ccall unsafe "gmp.h __gmpn_popcount" - c_mpn_popcount :: ByteArray# -> GmpSize# -> GmpBitCnt# - ----------------------------------------------------------------------------- --- BigNat-wrapped ByteArray#-primops - --- | Return number of limbs contained in 'BigNat'. --- --- The result is always @>= 1@ since even zero is encoded with 1 limb. -sizeofBigNat# :: BigNat -> GmpSize# -sizeofBigNat# (BN# x#) - = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# - -data MutBigNat s = MBN# !(MutableByteArray# s) - -getSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, GmpSize# #) ---getSizeofMutBigNat# :: MutBigNat s -> S s GmpSize# -getSizeofMutBigNat# (MBN# x#) s = - case getSizeofMutableByteArray# x# s of - (# s', n# #) -> (# s', n# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# #) - -newBigNat# :: GmpSize# -> S s (MutBigNat s) -newBigNat# limbs# s = - case newByteArray# (limbs# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) s of - (# s', mba# #) -> (# s', MBN# mba# #) - -writeBigNat# :: MutBigNat s -> GmpSize# -> GmpLimb# -> State# s -> State# s -writeBigNat# (MBN# mba#) = writeWordArray# mba# - --- | Extract /n/-th (0-based) limb in 'BigNat'. --- /n/ must be less than size as reported by 'sizeofBigNat#'. -indexBigNat# :: BigNat -> GmpSize# -> GmpLimb# -indexBigNat# (BN# ba#) = indexWordArray# ba# - -unsafeFreezeBigNat# :: MutBigNat s -> S s BigNat -unsafeFreezeBigNat# (MBN# mba#) s = case unsafeFreezeByteArray# mba# s of - (# s', ba# #) -> (# s', BN# ba# #) - -resizeMutBigNat# :: MutBigNat s -> GmpSize# -> S s (MutBigNat s) -resizeMutBigNat# (MBN# mba0#) nsz# s - | isTrue# (bsz# ==# n#) = (# s', MBN# mba0# #) - | True = - case resizeMutableByteArray# mba0# bsz# s' of - (# s'', mba# #) -> (# s'', MBN# mba# #) - where - bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - !(# s', n# #) = getSizeofMutableByteArray# mba0# s - -shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s -shrinkMutBigNat# (MBN# mba0#) nsz# s - | isTrue# (bsz# ==# n#) = s' -- no-op - | True = shrinkMutableByteArray# mba0# bsz# s' - where - bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - !(# s', n# #) = getSizeofMutableByteArray# mba0# s - -unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat -unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# s = go s' - where - n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# - !(# s', nb0# #) = getSizeofMutableByteArray# mba0# s - go = do - (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) - _ <- svoid (writeWordArray# mba# n# limb#) - unsafeFreezeBigNat# (MBN# mba#) - --- | May shrink underlying 'ByteArray#' if needed to satisfy BigNat invariant -unsafeRenormFreezeBigNat# :: MutBigNat s -> S s BigNat -unsafeRenormFreezeBigNat# mbn s - | isTrue# (n0# ==# 0#) = (# s'', nullBigNat #) - | isTrue# (n# ==# 0#) = (# s'', zeroBigNat #) - | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s'' - | True = (unsafeShrinkFreezeBigNat# mbn n#) s'' - where - !(# s', n0# #) = getSizeofMutBigNat# mbn s - !(# s'', n# #) = normSizeofMutBigNat'# mbn n0# s' - --- | Shrink MBN -unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat -unsafeShrinkFreezeBigNat# x@(MBN# xmba) 1# - = \s -> case readWordArray# xmba 0# s of - (# s', w# #) -> freezeOneLimb w# s' - where - freezeOneLimb 0## = return zeroBigNat - freezeOneLimb 1## = return oneBigNat - freezeOneLimb w# | isTrue# (not# w# `eqWord#` 0##) = return czeroBigNat - freezeOneLimb _ = do - _ <- svoid (shrinkMutBigNat# x 1#) - unsafeFreezeBigNat# x -unsafeShrinkFreezeBigNat# x y# = do - _ <- svoid (shrinkMutBigNat# x y#) - unsafeFreezeBigNat# x - - -copyWordArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# - -> State# s -> State# s -copyWordArray# src src_ofs dst dst_ofs len - = copyByteArray# src (src_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) - dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) - (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) - -copyWordArray :: BigNat -> Int# -> MutBigNat s -> Int# -> Int# -> S s () -copyWordArray (BN# ba#) ofs_ba# (MBN# mba#) ofs_mba# len# - = svoid (copyWordArray# ba# ofs_ba# mba# ofs_mba# len#) - -clearWordArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -clearWordArray# mba ofs len - = setByteArray# mba (ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) - (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 0# - --- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#' -normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) -normSizeofMutBigNat# mbn@(MBN# mba) s = normSizeofMutBigNat'# mbn sz# s' - where - !(# s', n# #) = getSizeofMutableByteArray# mba s - sz# = n# `uncheckedIShiftRA#` GMP_LIMB_SHIFT# - --- | Find most-significant non-zero limb and return its index-position --- plus one. Start scanning downward from the initial limb-size --- (i.e. start-index plus one) given as second argument. --- --- NB: The 'normSizeofMutBigNat' of 'zeroBigNat' would be @0#@ -normSizeofMutBigNat'# :: MutBigNat s -> GmpSize# - -> State# s -> (# State# s, GmpSize# #) -normSizeofMutBigNat'# (MBN# mba) = go - where - go 0# s = (# s, 0# #) - go i0# s = case readWordArray# mba (i0# -# 1#) s of - (# s', 0## #) -> go (i0# -# 1#) s' - (# s', _ #) -> (# s', i0# #) - --- | Construct 'BigNat' from existing 'ByteArray#' containing /n/ --- 'GmpLimb's in least-significant-first order. --- --- If possible 'ByteArray#', will be used directly (i.e. shared --- /without/ cloning the 'ByteArray#' into a newly allocated one) --- --- Note: size parameter (times @sizeof(GmpLimb)@) must be less or --- equal to its 'sizeofByteArray#'. -byteArrayToBigNat# :: ByteArray# -> GmpSize# -> BigNat -byteArrayToBigNat# ba# n0# - | isTrue# (n# ==# 0#) = zeroBigNat - | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size - , isTrue# (baszq# ==# n#) = (BN# ba#) - | True = runS $ \s -> - let !(# s', mbn@(MBN# mba#) #) = newBigNat# n# s - !(# s'', ba_sz# #) = getSizeofMutableByteArray# mba# s' - go = do _ <- svoid (copyByteArray# ba# 0# mba# 0# ba_sz# ) - unsafeFreezeBigNat# mbn - in go s'' - where - !(# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# - - n# = fmssl (BN# ba#) (n0# -# 1#) - --- | Read 'Integer' (without sign) from memory location at @/addr/@ in --- base-256 representation. --- --- @'importIntegerFromAddr' /addr/ /size/ /msbf/@ --- --- See description of 'importIntegerFromByteArray' for more details. --- --- @since 1.0.0.0 -importIntegerFromAddr :: Addr# -> Word# -> Int# -> IO Integer -importIntegerFromAddr addr len msbf = IO $ do - bn <- liftIO (importBigNatFromAddr addr len msbf) - return (bigNatToInteger bn) - --- | Version of 'importIntegerFromAddr' constructing a 'BigNat' -importBigNatFromAddr :: Addr# -> Word# -> Int# -> IO BigNat -importBigNatFromAddr _ 0## _ = IO (\s -> (# s, zeroBigNat #)) -importBigNatFromAddr addr len0 1# = IO $ do -- MSBF - W# ofs <- liftIO (c_scan_nzbyte_addr addr 0## len0) - let len = len0 `minusWord#` ofs - addr' = addr `plusAddr#` (word2Int# ofs) - importBigNatFromAddr# addr' len 1# -importBigNatFromAddr addr len0 _ = IO $ do -- LSBF - W# len <- liftIO (c_rscan_nzbyte_addr addr 0## len0) - importBigNatFromAddr# addr len 0# - -foreign import ccall unsafe "integer_gmp_scan_nzbyte" - c_scan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word - -foreign import ccall unsafe "integer_gmp_rscan_nzbyte" - c_rscan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word - --- | Helper for 'importBigNatFromAddr' -importBigNatFromAddr# :: Addr# -> Word# -> Int# -> S RealWorld BigNat -importBigNatFromAddr# _ 0## _ = return zeroBigNat -importBigNatFromAddr# addr len msbf = do - mbn@(MBN# mba#) <- newBigNat# n# - () <- liftIO (c_mpn_import_addr mba# addr 0## len msbf) - unsafeFreezeBigNat# mbn - where - -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required - n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# - -foreign import ccall unsafe "integer_gmp_mpn_import" - c_mpn_import_addr :: MutableByteArray# RealWorld -> Addr# -> Word# -> Word# - -> Int# -> IO () - --- | Read 'Integer' (without sign) from byte-array in base-256 representation. --- --- The call --- --- @'importIntegerFromByteArray' /ba/ /offset/ /size/ /msbf/@ --- --- reads --- --- * @/size/@ bytes from the 'ByteArray#' @/ba/@ starting at @/offset/@ --- --- * with most significant byte first if @/msbf/@ is @1#@ or least --- significant byte first if @/msbf/@ is @0#@, and --- --- * returns a new 'Integer' --- --- @since 1.0.0.0 -importIntegerFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> Integer -importIntegerFromByteArray ba ofs len msbf - = bigNatToInteger (importBigNatFromByteArray ba ofs len msbf) - --- | Version of 'importIntegerFromByteArray' constructing a 'BigNat' -importBigNatFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> BigNat -importBigNatFromByteArray _ _ 0## _ = zeroBigNat -importBigNatFromByteArray ba ofs0 len0 1# = runS $ do -- MSBF - W# ofs <- liftIO (c_scan_nzbyte_bytearray ba ofs0 len0) - let len = (len0 `plusWord#` ofs0) `minusWord#` ofs - importBigNatFromByteArray# ba ofs len 1# -importBigNatFromByteArray ba ofs len0 _ = runS $ do -- LSBF - W# len <- liftIO (c_rscan_nzbyte_bytearray ba ofs len0) - importBigNatFromByteArray# ba ofs len 0# - -foreign import ccall unsafe "integer_gmp_scan_nzbyte" - c_scan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word - -foreign import ccall unsafe "integer_gmp_rscan_nzbyte" - c_rscan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word - --- | Helper for 'importBigNatFromByteArray' -importBigNatFromByteArray# :: ByteArray# -> Word# -> Word# -> Int# - -> S RealWorld BigNat -importBigNatFromByteArray# _ _ 0## _ = return zeroBigNat -importBigNatFromByteArray# ba ofs len msbf = do - mbn@(MBN# mba#) <- newBigNat# n# - () <- liftIO (c_mpn_import_bytearray mba# ba ofs len msbf) - unsafeFreezeBigNat# mbn - where - -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required - n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# - -foreign import ccall unsafe "integer_gmp_mpn_import" - c_mpn_import_bytearray :: MutableByteArray# RealWorld -> ByteArray# -> Word# - -> Word# -> Int# -> IO () - --- | Test whether all internal invariants are satisfied by 'BigNat' value --- --- Returns @1#@ if valid, @0#@ otherwise. --- --- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. -isValidBigNat# :: BigNat -> Int# -isValidBigNat# (BN# ba#) - = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm# - where - isNorm# - | isTrue# (szq# ># 1#) = (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## - | True = 1# - - sz# = sizeofByteArray# ba# - - !(# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# - --- | Version of 'nextPrimeInteger' operating on 'BigNat's --- --- @since 1.0.0.0 -nextPrimeBigNat :: BigNat -> BigNat -nextPrimeBigNat bn@(BN# ba#) = runS $ do - mbn@(MBN# mba#) <- newBigNat# n# - (W# c#) <- liftIO (nextPrime# mba# ba# n#) - case c# of - 0## -> unsafeFreezeBigNat# mbn - _ -> unsafeSnocFreezeBigNat# mbn c# - where - n# = sizeofBigNat# bn - -foreign import ccall unsafe "integer_gmp_next_prime" - nextPrime# :: MutableByteArray# RealWorld -> ByteArray# -> GmpSize# - -> IO GmpLimb - ----------------------------------------------------------------------------- --- monadic combinators for low-level state threading - -type S s a = State# s -> (# State# s, a #) - -infixl 1 >>= -infixl 1 >> -infixr 0 $ - -{-# INLINE ($) #-} -($) :: (a -> b) -> a -> b -f $ x = f x - -{-# INLINE (>>=) #-} -(>>=) :: S s a -> (a -> S s b) -> S s b -(>>=) m k = \s -> case m s of (# s', a #) -> k a s' - -{-# INLINE (>>) #-} -(>>) :: S s a -> S s b -> S s b -(>>) m k = \s -> case m s of (# s', _ #) -> k s' - -{-# INLINE svoid #-} -svoid :: (State# s -> State# s) -> S s () -svoid m0 = \s -> case m0 s of s' -> (# s', () #) - -{-# INLINE return #-} -return :: a -> S s a -return a = \s -> (# s, a #) - -{-# INLINE liftIO #-} -liftIO :: IO a -> S RealWorld a -liftIO (IO m) = m - --- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there -runS :: S RealWorld a -> a -runS m = case runRW# m of (# _, a #) -> a - --- stupid hack -fail :: [Char] -> S s a -fail s = return (raise# s) - ----------------------------------------------------------------------------- - --- | Internal helper type for "signed" 'BigNat's --- --- This is a useful abstraction for operations which support negative --- mp_size_t arguments. -data SBigNat = NegBN !BigNat | PosBN !BigNat - --- | Absolute value of 'SBigNat' -absSBigNat :: SBigNat -> BigNat -absSBigNat (NegBN bn) = bn -absSBigNat (PosBN bn) = bn - --- | /Signed/ limb count. Negative sizes denote negative integers -ssizeofSBigNat# :: SBigNat -> GmpSize# -ssizeofSBigNat# (NegBN bn) = negateInt# (sizeofBigNat# bn) -ssizeofSBigNat# (PosBN bn) = sizeofBigNat# bn - --- | Construct 'SBigNat' from 'Int#' value -intToSBigNat# :: Int# -> SBigNat -intToSBigNat# 0# = PosBN zeroBigNat -intToSBigNat# 1# = PosBN oneBigNat -intToSBigNat# (-1#) = NegBN oneBigNat -intToSBigNat# i# | isTrue# (i# ># 0#) = PosBN (wordToBigNat (int2Word# i#)) - | True = NegBN (wordToBigNat (int2Word# (negateInt# i#))) - --- | Convert 'Integer' into 'SBigNat' -integerToSBigNat :: Integer -> SBigNat -integerToSBigNat (S# i#) = intToSBigNat# i# -integerToSBigNat (Jp# bn) = PosBN bn -integerToSBigNat (Jn# bn) = NegBN bn - --- | Convert 'SBigNat' into 'Integer' -sBigNatToInteger :: SBigNat -> Integer -sBigNatToInteger (NegBN bn) = bigNatToNegInteger bn -sBigNatToInteger (PosBN bn) = bigNatToInteger bn - ----------------------------------------------------------------------------- --- misc helpers, some of these should rather be primitives exported by ghc-prim - -cmpW# :: Word# -> Word# -> Ordering -cmpW# x# y# - | isTrue# (x# `ltWord#` y#) = LT - | isTrue# (x# `eqWord#` y#) = EQ - | True = GT -{-# INLINE cmpW# #-} - -bitWord# :: Int# -> Word# -bitWord# = uncheckedShiftL# 1## -{-# INLINE bitWord# #-} - -testBitWord# :: Word# -> Int# -> Int# -testBitWord# w# i# = (bitWord# i# `and#` w#) `neWord#` 0## -{-# INLINE testBitWord# #-} - -popCntI# :: Int# -> Int# -popCntI# i# = word2Int# (popCnt# (int2Word# i#)) -{-# INLINE popCntI# #-} - --- branchless version -absI# :: Int# -> Int# -absI# i# = (i# `xorI#` nsign) -# nsign - where - -- nsign = negateInt# (i# <# 0#) - nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#) - --- branchless version -sgnI# :: Int# -> Int# -sgnI# x# = (x# ># 0#) -# (x# <# 0#) - -cmpI# :: Int# -> Int# -> Int# -cmpI# x# y# = (x# ># y#) -# (x# <# y#) - -minI# :: Int# -> Int# -> Int# -minI# x# y# | isTrue# (x# <=# y#) = x# - | True = y# - --- find most-sig set limb, starting at given index -fmssl :: BigNat -> Int# -> Int# -fmssl !bn i0# = go i0# - where - go i# | isTrue# (i# <# 0#) = 0# - | isTrue# (neWord# (indexBigNat# bn i#) 0##) = i# +# 1# - | True = go (i# -# 1#) |