Commit 670599db authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Fold integer-gmp.git into ghc.git (re #8545)

At the time of merge, integer-gmp.git was at
[d7bff4dddfa10389156ca11f75a5a23e78cf3ab0/integer-gmp]

Note: All but the last/current GMP tarball were removed from the
      history to keep the Git history size at a minimum.
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parents 85febc04 4775d006
GNUmakefile
autom4te.cache/
config.log
config.status
configure
dist-install/
^/ghc.mk
gmp/config.mk
integer-gmp.buildinfo
cbits/GmpDerivedConstants.h
cbits/mkGmpDerivedConstants
include/HsIntegerGmp.h
\begin{code}
{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Integer
-- Copyright : (c) The University of Glasgow 1994-2008
-- License : see libraries/integer-gmp/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
-- The 'Integer' type.
--
-- This module exposes the /portable/ 'Integer' API. See
-- "GHC.Integer.GMP.Internals" for the GMP-specific internal
-- representation of 'Integer' as well as optimized GMP-specific
-- operations.
-----------------------------------------------------------------------------
#include "MachDeps.h"
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,
eqInteger#, neqInteger#,
leInteger#, gtInteger#, ltInteger#, geInteger#,
-- * Bit-operations
andInteger, orInteger, xorInteger, complementInteger,
shiftLInteger, shiftRInteger, testBitInteger,
-- * Hashing
hashInteger,
) where
import GHC.Integer.Type
default ()
\end{code}
{-# LANGUAGE NoImplicitPrelude #-}
-- | 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://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer GHC Commentary: Libraries/Integer>.
module GHC.Integer.GMP.Internals
( -- * The 'Integer' type
Integer(..)
-- * Number theoretic functions
, gcdInt
, gcdInteger
, gcdExtInteger
, lcmInteger
, nextPrimeInteger
, testPrimeInteger
-- * Exponentiation functions
, powInteger
, powModInteger
, powModSecInteger
, recipModInteger
-- * Import/export functions
, sizeInBaseInteger
, importIntegerFromByteArray
, importIntegerFromAddr
, exportIntegerToMutableByteArray
, exportIntegerToAddr
) where
import GHC.Integer.Type
This diff is collapsed.
{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-}
module GHC.Integer.Logarithms
( integerLogBase#
, integerLog2#
, wordLog2#
) where
import GHC.Prim
import GHC.Integer
import qualified GHC.Integer.Logarithms.Internals as I
-- | Calculate the integer logarithm for an arbitrary base.
-- The base must be greater than 1, the second argument, the number
-- whose logarithm is sought, should be positive, otherwise the
-- result is meaningless.
--
-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1)
--
-- for @base > 1@ and @m > 0@.
integerLogBase# :: Integer -> Integer -> Int#
integerLogBase# b m = case step b of
(# _, e #) -> e
where
step pw =
if m `ltInteger` pw
then (# m, 0# #)
else case step (pw `timesInteger` pw) of
(# q, e #) ->
if q `ltInteger` pw
then (# q, 2# *# e #)
else (# 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# = I.integerLog2#
-- | This function calculates the integer base 2 logarithm of a 'Word#'.
wordLog2# :: Word# -> Int#
wordLog2# = I.wordLog2#
{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK hide #-}
#include "MachDeps.h"
-- 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.
module GHC.Integer.Logarithms.Internals
( integerLog2#
, integerLog2IsPowerOf2#
, wordLog2#
, roundingMode#
) where
import GHC.Prim
import GHC.Types (isTrue#)
import GHC.Integer.Type
-- When larger word sizes become common, add support for those,
-- it is not hard, just tedious.
#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64)
-- Less than ideal implementations for strange word sizes
import GHC.Integer
default ()
-- We do not know whether the word has 30 bits or 128 or even more,
-- so we cannot start from the top, although that would be much more
-- efficient.
-- Count the bits until the highest set bit is found.
wordLog2# :: Word# -> Int#
wordLog2# w = go 8# w
where
go acc u = case u `uncheckedShiftRL#` 8# of
0## -> case leadingZeros of
BA ba -> acc -# indexInt8Array# ba (word2Int# u)
v -> go (acc +# 8#) v
-- Assumption: Integer is strictly positive
integerLog2# :: Integer -> Int#
integerLog2# (S# i) = wordLog2# (int2Word# i) -- that is easy
integerLog2# m = case step m (smallInteger 2#) 1# of
(# _, l #) -> l
where
-- Invariants:
-- pw = 2 ^ lg
-- case step n pw lg of
-- (q, e) -> pw^(2*e) <= n < pw^(2*e+2)
-- && q <= n/pw^(2*e) < (q+1)
-- && q < pw^2
step n pw lg =
if n `ltInteger` pw
then (# n, 0# #)
else case step n (shiftLInteger pw lg) (2# *# lg) of
(# q, e #) ->
if q `ltInteger` pw
then (# q, 2# *# e #)
else (# q `shiftRInteger` lg, 2# *# e +# 1# #)
-- Calculate the log2 of a positive integer and check
-- whether it is a power of 2.
-- By coincidence, the presence of a power of 2 is
-- signalled by zero and not one.
integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #)
integerLog2IsPowerOf2# m =
case integerLog2# m of
lg -> if m `eqInteger` (smallInteger 1# `shiftLInteger` lg)
then (# lg, 0# #)
else (# lg, 1# #)
-- Detect the rounding mode,
-- 0# means round to zero,
-- 1# means round to even,
-- 2# means round away from zero
roundingMode# :: Integer -> Int# -> Int#
roundingMode# m h =
case smallInteger 1# `shiftLInteger` h of
c -> case m `andInteger`
((c `plusInteger` c) `minusInteger` smallInteger 1#) of
r ->
if c `ltInteger` r
then 2#
else if c `gtInteger` r
then 0#
else 1#
#else
default ()
-- We have a nice word size, we can do much better now.
#if WORD_SIZE_IN_BITS == 32
#define WSHIFT 5
#define MMASK 31
#else
#define WSHIFT 6
#define MMASK 63
#endif
-- Assumption: Integer is strictly positive
-- For small integers, use wordLog#,
-- in the general case, check words from the most
-- significant down, once a nonzero word is found,
-- calculate its log2 and add the number of following bits.
integerLog2# :: Integer -> Int#
integerLog2# (S# i) = wordLog2# (int2Word# i)
integerLog2# (J# s ba) = check (s -# 1#)
where
check i = case indexWordArray# ba i of
0## -> check (i -# 1#)
w -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#)
-- Assumption: Integer is strictly positive
-- First component 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##)) #)
-- Find the log2 as above, test whether that word is a power
-- of 2, if so, check whether only zero bits follow.
integerLog2IsPowerOf2# (J# s ba) = check (s -# 1#)
where
check :: Int# -> (# Int#, Int# #)
check i = case indexWordArray# ba 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 indexWordArray# ba 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# (J# _ ba) 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 indexWordArray# ba 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 indexWordArray# ba i of
0## -> test (i -# 1#)
_ -> 2#
-- wordLog2# 0## = -1#
{-# INLINE wordLog2# #-}
wordLog2# :: Word# -> Int#
wordLog2# w =
case leadingZeros of
BA lz ->
let zeros u = indexInt8Array# lz (word2Int# u) in
#if WORD_SIZE_IN_BITS == 64
case uncheckedShiftRL# w 56# of
a ->
if isTrue# (a `neWord#` 0##)
then 64# -# zeros a
else
case uncheckedShiftRL# w 48# of
b ->
if isTrue# (b `neWord#` 0##)
then 56# -# zeros b
else
case uncheckedShiftRL# w 40# of
c ->
if isTrue# (c `neWord#` 0##)
then 48# -# zeros c
else
case uncheckedShiftRL# w 32# of
d ->
if isTrue# (d `neWord#` 0##)
then 40# -# zeros d
else
#endif
case uncheckedShiftRL# w 24# of
e ->
if isTrue# (e `neWord#` 0##)
then 32# -# zeros e
else
case uncheckedShiftRL# w 16# of
f ->
if isTrue# (f `neWord#` 0##)
then 24# -# zeros f
else
case uncheckedShiftRL# w 8# of
g ->
if isTrue# (g `neWord#` 0##)
then 16# -# zeros g
else 8# -# zeros w
#endif
-- Lookup table
data BA = BA ByteArray#
leadingZeros :: BA
leadingZeros =
let mkArr s =
case newByteArray# 256# s of
(# s1, mba #) ->
case writeInt8Array# mba 0# 9# s1 of
s2 ->
let fillA lim val idx st =
if isTrue# (idx ==# 256#)
then st
else if isTrue# (idx <# lim)
then case writeInt8Array# mba idx val st of
nx -> fillA lim val (idx +# 1#) nx
else fillA (2# *# lim) (val -# 1#) idx st
in case fillA 2# 8# 1# s2 of
s3 -> case unsafeFreezeByteArray# mba s3 of
(# _, ba #) -> ba
in case mkArr realWorld# of
b -> BA b
This diff is collapsed.
This library (libraries/integer(-gmp)) is derived from code from several
sources:
* Code from the GHC project which is largely (c) The University of
Glasgow, and distributable under a BSD-style license (see below),
* Code from the Haskell 98 Report which is (c) Simon Peyton Jones
and freely redistributable (but see the full license for
restrictions).
The full text of these licenses is reproduced below. All of the
licenses are BSD-style or compatible.
-----------------------------------------------------------------------------
The Glasgow Haskell Compiler License
Copyright 2004, 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.
-----------------------------------------------------------------------------
Code derived from the document "Report on the Programming Language
Haskell 98", is distributed under the following license:
Copyright (c) 2002 Simon Peyton Jones
The authors intend this Report to belong to the entire Haskell
community, and so we grant permission to copy and distribute it for
any purpose, provided that it is reproduced in its entirety,
including this Notice. Modified versions of this Report may also be
copied and distributed for any purpose, provided that the modified
version is clearly presented as such, and that it does not claim to
be a definition of the Haskell 98 Language.
module Main (main) where
import Distribution.Simple
main :: IO ()
main = defaultMain
dnl--------------------------------------------------------------------
dnl * Check whether this machine has gmp/gmp3 installed
dnl--------------------------------------------------------------------
AC_DEFUN([LOOK_FOR_GMP_LIB],[
if test "$HaveFrameworkGMP" = "NO"
then
AC_CHECK_LIB([gmp], [__gmpz_powm],
[HaveLibGmp=YES; GMP_LIBS=gmp])
if test "$HaveLibGmp" = "NO"
then
AC_CHECK_LIB([gmp3], [__gmpz_powm],
[HaveLibGmp=YES; GMP_LIBS=gmp3])
fi
if test "$HaveLibGmp" = "YES"
then
AC_CHECK_LIB([$GMP_LIBS], [__gmpz_powm_sec],
[HaveSecurePowm=1])
fi
fi
])
dnl--------------------------------------------------------------------
dnl * Mac OS X only: check for GMP.framework
dnl--------------------------------------------------------------------
AC_DEFUN([LOOK_FOR_GMP_FRAMEWORK],[
if test "$HaveLibGmp" = "NO"
then
case $target_os in
darwin*)
AC_MSG_CHECKING([for GMP.framework])
save_libs="$LIBS"
LIBS="-framework GMP"
AC_TRY_LINK_FUNC(__gmpz_powm_sec,
[HaveFrameworkGMP=YES; GMP_FRAMEWORK=GMP])
LIBS="$save_libs"
AC_MSG_RESULT([$HaveFrameworkGMP])
;;
esac
fi
])
/* -----------------------------------------------------------------------------
*
* (c) The GHC Team, 1998-2012
*
* ---------------------------------------------------------------------------*/
#include <string.h>
#include "Rts.h"
#include "gmp.h"
void * stgAllocForGMP (size_t size_in_bytes);
void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
void stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED);
static void initAllocForGMP( void ) __attribute__((constructor));
/* -----------------------------------------------------------------------------
Tell GMP to use our custom heap allocation functions.
Our allocation strategy is to use GHC heap allocations rather than malloc
and co. The heap objects we use are ByteArray#s which of course have their
usual header word or two. But gmp doesn't know about ghc heap objects and
header words. So our allocator has to make a ByteArray# and return a pointer
to its interior! When the gmp function returns we receive that interior
pointer. Then we look back a couple words to get the proper ByteArray#
pointer (which then gets returned as a ByteArray# and thus get tracked
properly by the GC).
WARNING!! WARNING!! WARNING!!
It is absolutely vital that this initialisation function be called before
any of the gmp functions are called. We'd still be looking back a couple
words for the ByteArray# header, but if we were accidentally using malloc
then it'd all go wrong because of course there would be no ByteArray#
header, just malloc's own internal book keeping info. To make things worse
we would not notice immediately, it'd only be when the GC comes round to
inspect things... BANG!
> Program received signal SIGSEGV, Segmentation fault.
> [Switching to Thread 0x7f5a9ebc76f0 (LWP 17838)]
> evacuate1 (p=0x7f5a99acd2e0) at rts/sm/Evac.c:375
> 375 switch (info->type) {
-------------------------------------------------------------------------- */
static void initAllocForGMP( void )
{
mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
}
/* -----------------------------------------------------------------------------
Allocation functions for GMP.
These all use the allocate() interface - we can't have any garbage
collection going on during a gmp operation, so we use allocate()
which always succeeds. The gmp operations which might need to
allocate will ask the storage manager (via doYouWantToGC()) whether
a garbage collection is required, in case we get into a loop doing
only allocate() style allocation.
-------------------------------------------------------------------------- */
void *
stgAllocForGMP (size_t size_in_bytes)
{
StgArrWords* arr;
nat data_size_in_words, total_size_in_words;
Capability *cap;
/* round up to a whole number of words */
data_size_in_words = ROUNDUP_BYTES_TO_WDS(size_in_bytes);
total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
/* allocate and fill it in. */
cap = rts_unsafeGetMyCapability();
arr = (StgArrWords *)allocate(cap, total_size_in_words);
SET_ARR_HDR(arr, &stg_ARR_WORDS_info, ((CapabilityPublic*)cap)->r.rCCCS, size_in_bytes);
/* and return a ptr to the goods inside the array */
return arr->payload;
}
void *
stgReallocForGMP (void *ptr, size_t old_size, size_t new_size)
{
size_t min_size = old_size < new_size ? old_size : new_size;
return memcpy(stgAllocForGMP(new_size), ptr, min_size);
}
void
stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED)
{
/* easy for us: the garbage collector does the dealloc'n */
}
/* We combine the C files here.
*
* There is actually a good reason for this, really!
* The alloc file contains a __attribute__((constructor)) function. We must
* have this function in the same .o file as other stuff that actually gets
* used otherwise the static linker doesn't bother to pull in the .o file
* containing the constructor function. While we could just stick them in
* the same .c file that'd be a bit annoying. So we combine them here.
* */
#include "alloc.c"
#include "float.c"
#include "longlong.c"
/* -----------------------------------------------------------------------------
*
* (c) Lennart Augustsson
* (c) The GHC Team, 1998-2000
*
* Support for floating-point <-> gmp integer primitives
*
* ---------------------------------------------------------------------------*/
/* TODO: do we need PosixSource.h ? it lives in rts/ not public includes/ */
/* #include "PosixSource.h" */
#include "Rts.h"
#include "gmp.h"
#include "GmpDerivedConstants.h"
#include <math.h>
#define IEEE_FLOATING_POINT 1
/*
* Encoding and decoding Doubles. Code based on the HBC code
* (lib/fltcode.c).
*/
#define SIZEOF_LIMB_T SIZEOF_MP_LIMB_T
#if SIZEOF_LIMB_T == 4
#define GMP_BASE 4294967296.0
#define LIMBBITS_LOG_2 5
#elif SIZEOF_LIMB_T == 8
#define GMP_BASE 18446744073709551616.0
#define LIMBBITS_LOG_2 6
#else
#error Cannot cope with SIZEOF_LIMB_T -- please add definition of GMP_BASE
#endif
#define DNBIGIT ((SIZEOF_DOUBLE+SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T)
#define FNBIGIT ((SIZEOF_FLOAT +SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T)