2 (:use "COMMON-LISP" "SB-ALIEN" "SB-BIGNUM")
3 ;; we need a few very internal symbols
4 (:import-from "SB-BIGNUM"
5 "%BIGNUM-0-OR-PLUSP" "%NORMALIZE-BIGNUM"
6 "NEGATE-BIGNUM-IN-PLACE")
8 ;; bignum integer operations
21 #:mpz-probably-prime-p
24 ;; Following three are GMP >= 5.1 only
30 ;; random number generation
41 ;; (un)installer functions
42 ; these insert/remove the runtime patch in SBCL's runtime
45 ; these also load/unload the shared library and setup/clear
46 ; hooks to handle core saves
56 (defvar *gmp-disabled* nil)
58 (defconstant +bignum-raw-area-offset+
59 (- (* sb-vm:bignum-digits-offset sb-vm:n-word-bytes)
60 sb-vm:other-pointer-lowtag))
62 (declaim (inline bignum-data-sap))
63 (defun bignum-data-sap (x)
64 (declare (type bignum x))
65 (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address x))
66 +bignum-raw-area-offset+))
70 (load-shared-object #-(or win32 darwin) "libgmp.so"
71 #+darwin "libgmp.dylib"
72 #+win32 "libgmp-10.dll"
75 (warn "GMP not loaded (~a)" e)
76 (return-from %load-gmp nil)))
79 (defvar *gmp-features* nil)
80 (defvar *gmp-version* nil)
82 ;; We load only the library right now to avoid undefined alien
87 ;;; types and initialization
88 (define-alien-type nil
92 (mp_d (* unsigned-long))))
94 ;; Section 3.6 "Memory Management" of the GMP manual states: "mpz_t
95 ;; and mpq_t variables never reduce their allocated space. Normally
96 ;; this is the best policy, since it avoids frequent
97 ;; reallocation. Applications that need to return memory to the heap
98 ;; at some particular point can use mpz_realloc2, or clear variables
101 ;; We can therefore allocate a bignum of sufficiant size and use the
102 ;; space for GMP computations without the need for memory transfer
103 ;; from C to Lisp space.
104 (declaim (inline z-to-bignum z-to-bignum-neg))
106 (defun z-to-bignum (b count)
107 "Convert GMP integer in the buffer of a pre-allocated bignum."
108 (declare (optimize (speed 3) (space 3) (safety 0))
110 (type bignum-index count))
113 (the unsigned-byte (%normalize-bignum b count))))
115 (defun z-to-bignum-neg (b count)
116 "Convert to twos complement int the buffer of a pre-allocated
118 (declare (optimize (speed 3) (space 3) (safety 0))
120 (type bignum-index count))
121 (negate-bignum-in-place b)
122 (the (integer * 0) (%normalize-bignum b count)))
124 ;;; conversion functions that also copy from GMP to SBCL bignum space
125 (declaim (inline gmp-z-to-bignum gmp-z-to-bignum-neg))
127 (defun gmp-z-to-bignum (z b count)
128 "Convert and copy a positive GMP integer into the buffer of a
129 pre-allocated bignum. The allocated bignum-length must be (1+ COUNT)."
130 (declare (optimize (speed 3) (space 3) (safety 0))
131 (type (alien (* unsigned-long)) z)
133 (type bignum-index count))
134 (dotimes (i count (%normalize-bignum b count))
135 (%bignum-set b i (deref z i))))
137 (defun gmp-z-to-bignum-neg (z b count)
138 "Convert to twos complement and copy a negative GMP integer into the
139 buffer of a pre-allocated bignum. The allocated bignum-length must
141 (declare (optimize (speed 3) (space 3) (safety 0))
142 (type (alien (* unsigned-long)) z)
144 (type bignum-index count))
147 (declare (type (mod 2) carry add))
149 (multiple-value-bind (value carry-tmp)
151 (%lognot (deref z i)) add carry)
152 (%bignum-set b i value)
153 (setf carry carry-tmp
156 (declaim (inline blength bassert)
157 (ftype (function (integer) (values bignum-index &optional)) blength)
158 (ftype (function (integer) (values bignum &optional)) bassert))
161 (declare (optimize (speed 3) (space 3) (safety 0)))
164 (t (%bignum-length a))))
167 (declare (optimize (speed 3) (space 3) (safety 0)))
169 (fixnum (make-small-bignum a))
173 (define-alien-type nil
175 (mp_num (struct gmpint))
176 (mp_den (struct gmpint))))
178 ;;; memory initialization functions to support non-alloced results
179 ;;; since an upper bound cannot always correctly predetermined
180 ;;; (e.g. the memory required for the fib function exceed the number
181 ;;; of limbs that are be determined through the infamous Phi-relation
182 ;;; resulting in a memory access error.
184 ;; use these for non-prealloced bignum values, but only when
185 ;; ultimately necessary since copying back into bignum space a the end
186 ;; of the operation is about three times slower than the shared buffer
188 (declaim (inline __gmpz_init __gmpz_clear))
189 (define-alien-routine __gmpz_init void
190 (x (* (struct gmpint))))
192 (define-alien-routine __gmpz_clear void
193 (x (* (struct gmpint))))
196 ;;; integer interface functions
197 (defmacro define-twoarg-mpz-funs (funs)
198 (loop for i in funs collect `(define-alien-routine ,i void
199 (r (* (struct gmpint)))
200 (a (* (struct gmpint))))
202 finally (return `(progn
203 (declaim (inline ,@funs))
206 (defmacro define-threearg-mpz-funs (funs)
207 (loop for i in funs collect `(define-alien-routine ,i void
208 (r (* (struct gmpint)))
209 (a (* (struct gmpint)))
210 (b (* (struct gmpint))))
212 finally (return `(progn
213 (declaim (inline ,@funs))
216 (defmacro define-fourarg-mpz-funs (funs)
217 (loop for i in funs collect `(define-alien-routine ,i void
218 (r (* (struct gmpint)))
219 (a (* (struct gmpint)))
220 (b (* (struct gmpint)))
221 (c (* (struct gmpint))))
223 finally (return `(progn
224 (declaim (inline ,@funs))
228 (define-twoarg-mpz-funs (__gmpz_sqrt
231 (define-threearg-mpz-funs (__gmpz_add
238 (define-fourarg-mpz-funs (__gmpz_cdiv_qr
243 (declaim (inline __gmpz_pow_ui
244 __gmpz_probab_prime_p
252 (define-alien-routine __gmpz_pow_ui void
253 (r (* (struct gmpint)))
254 (b (* (struct gmpint)))
257 (define-alien-routine __gmpz_probab_prime_p int
258 (n (* (struct gmpint)))
261 (define-alien-routine __gmpz_fac_ui void
262 (r (* (struct gmpint)))
265 (define-alien-routine __gmpz_2fac_ui void
266 (r (* (struct gmpint)))
269 (define-alien-routine __gmpz_mfac_uiui void
270 (r (* (struct gmpint)))
274 (define-alien-routine __gmpz_primorial_ui void
275 (r (* (struct gmpint)))
278 (define-alien-routine __gmpz_bin_ui void
279 (r (* (struct gmpint)))
280 (n (* (struct gmpint)))
283 (define-alien-routine __gmpz_fib2_ui void
284 (r (* (struct gmpint)))
285 (a (* (struct gmpint)))
290 (defmacro define-threearg-mpq-funs (funs)
291 (loop for i in funs collect `(define-alien-routine ,i void
292 (r (* (struct gmprat)))
293 (a (* (struct gmprat)))
294 (b (* (struct gmprat))))
296 finally (return `(progn
297 (declaim (inline ,@funs))
300 (define-threearg-mpq-funs (__gmpq_add
308 ;;; utility macros for GMP mpz variable and result declaration and
309 ;;; incarnation of associated SBCL bignums
310 (defmacro with-mpz-results (pairs &body body)
311 (loop for (gres size) in pairs
312 for res = (gensym "RESULT")
313 collect `(,gres (struct gmpint)) into declares
314 collect `(,res (%allocate-bignum ,size))
316 collect `(setf (slot ,gres 'mp_alloc) (%bignum-length ,res)
317 (slot ,gres 'mp_size) 0
318 (slot ,gres 'mp_d) (bignum-data-sap ,res))
320 collect `(if (minusp (slot ,gres 'mp_size)) ; check for negative result
321 (z-to-bignum-neg ,res ,size)
322 (z-to-bignum ,res ,size))
324 collect res into results
327 (sb-sys:with-pinned-objects ,results
328 (with-alien ,declares
331 (values ,@normlimbs)))))))
333 (defmacro with-mpz-vars (pairs &body body)
334 (loop for (a ga) in pairs
335 for length = (gensym "LENGTH")
336 for plusp = (gensym "PLUSP")
337 for barg = (gensym "BARG")
338 for arg = (gensym "ARG")
339 collect `(,ga (struct gmpint)) into declares
340 collect `(,barg (bassert ,a)) into gmpinits
341 collect `(,plusp (%bignum-0-or-plusp ,barg (%bignum-length ,barg))) into gmpinits
342 collect `(,arg (if ,plusp ,barg (negate-bignum ,barg nil))) into gmpinits
343 collect `(,length (%bignum-length ,arg)) into gmpinits
344 collect arg into vars
345 collect `(setf (slot ,ga 'mp_alloc) ,length
347 (progn ;; handle twos complements/ulong limbs mismatch
348 (when (zerop (%bignum-ref ,arg (1- ,length)))
350 (if ,plusp ,length (- ,length)))
351 (slot ,ga 'mp_d) (bignum-data-sap ,arg))
354 `(with-alien ,declares
356 (sb-sys:with-pinned-objects ,vars
360 (defmacro with-gmp-mpz-results (resultvars &body body)
361 (loop for gres in resultvars
362 for res = (gensym "RESULT")
363 for size = (gensym "SIZE")
364 collect size into sizes
365 collect `(,gres (struct gmpint)) into declares
366 collect `(__gmpz_init (addr ,gres)) into inits
367 collect `(,size (1+ (abs (slot ,gres 'mp_size))))
369 collect `(,res (%allocate-bignum ,size))
371 collect `(setf ,res (if (minusp (slot ,gres 'mp_size)) ; check for negative result
372 (gmp-z-to-bignum-neg (slot ,gres 'mp_d) ,res ,size)
373 (gmp-z-to-bignum (slot ,gres 'mp_d) ,res ,size)))
375 collect `(__gmpz_clear (addr ,gres)) into clears
376 collect res into results
378 `(with-alien ,declares
382 (declare (type bignum-index ,@sizes))
383 ;; copy GMP limbs into result bignum
384 (sb-sys:with-pinned-objects ,results
387 (values ,@results))))))
389 ;;; function definition and foreign function relationships
390 (defmacro defgmpfun (name args &body body)
392 (declaim (sb-ext:maybe-inline ,name))
394 (declare (optimize (speed 3) (space 3) (safety 0))
395 (type integer ,@args))
399 ;; SBCL/GMP functions
400 (defgmpfun mpz-add (a b)
401 (with-mpz-results ((result (1+ (max (blength a)
403 (with-mpz-vars ((a ga) (b gb))
404 (__gmpz_add (addr result) (addr ga) (addr gb)))))
406 (defgmpfun mpz-sub (a b)
407 (with-mpz-results ((result (1+ (max (blength a)
409 (with-mpz-vars ((a ga) (b gb))
410 (__gmpz_sub (addr result) (addr ga) (addr gb)))))
412 (defgmpfun mpz-mul (a b)
413 (with-mpz-results ((result (+ (blength a)
415 (with-mpz-vars ((a ga) (b gb))
416 (__gmpz_mul (addr result) (addr ga) (addr gb)))))
418 (defgmpfun mpz-mod (a b)
419 (with-mpz-results ((result (1+ (max (blength a)
421 (with-mpz-vars ((a ga) (b gb))
422 (__gmpz_mod (addr result) (addr ga) (addr gb))
423 (when (and (minusp (slot gb 'mp_size))
424 (/= 0 (slot result 'mp_size)))
425 (__gmpz_add (addr result) (addr result) (addr gb))))))
427 (defgmpfun mpz-cdiv (n d)
428 (let ((size (1+ (max (blength n)
430 (with-mpz-results ((quot size)
432 (with-mpz-vars ((n gn) (d gd))
433 (__gmpz_cdiv_qr (addr quot) (addr rem) (addr gn) (addr gd))))))
435 (defgmpfun mpz-fdiv (n d)
436 (let ((size (1+ (max (blength n)
438 (with-mpz-results ((quot size)
440 (with-mpz-vars ((n gn) (d gd))
441 (__gmpz_fdiv_qr (addr quot) (addr rem) (addr gn) (addr gd))))))
443 (defgmpfun mpz-tdiv (n d)
444 (let ((size (max (blength n)
446 (with-mpz-results ((quot size)
448 (with-mpz-vars ((n gn) (d gd))
449 (__gmpz_tdiv_qr (addr quot) (addr rem) (addr gn) (addr gd))))))
451 (defun mpz-pow (base exp)
452 (declare (optimize (speed 3) (space 3) (safety 0))
453 (type bignum-type base))
454 (check-type exp (unsigned-byte #.sb-vm:n-word-bits))
455 (with-gmp-mpz-results (rop)
456 (with-mpz-vars ((base gbase))
457 (__gmpz_pow_ui (addr rop) (addr gbase) exp))))
459 (defgmpfun mpz-powm (base exp mod)
460 (with-mpz-results ((rop (1+ (blength mod))))
461 (with-mpz-vars ((base gbase) (exp gexp) (mod gmod))
462 (__gmpz_powm (addr rop) (addr gbase) (addr gexp) (addr gmod)))))
464 (defgmpfun mpz-gcd (a b)
465 (with-mpz-results ((result (min (blength a)
467 (with-mpz-vars ((a ga) (b gb))
468 (__gmpz_gcd (addr result) (addr ga) (addr gb)))))
470 (defgmpfun mpz-lcm (a b)
471 (with-mpz-results ((result (+ (blength a)
473 (with-mpz-vars ((a ga) (b gb))
474 (__gmpz_lcm (addr result) (addr ga) (addr gb)))))
476 (defgmpfun mpz-sqrt (a)
477 (with-mpz-results ((result (1+ (ceiling (blength a) 2))))
478 (with-mpz-vars ((a ga))
479 (__gmpz_sqrt (addr result) (addr ga)))))
482 ;;; Functions that use GMP-side allocated integers and copy the result
483 ;;; into a SBCL bignum at the end of the computation when the required
484 ;;; bignum length is known.
485 (defun mpz-probably-prime-p (n &optional (reps 25))
486 (declare (optimize (speed 3) (space 3) (safety 0)))
487 (check-type reps fixnum)
488 (with-mpz-vars ((n gn))
489 (__gmpz_probab_prime_p (addr gn) reps)))
491 (defun mpz-nextprime (a)
492 (declare (optimize (speed 3) (space 3) (safety 0)))
493 (with-gmp-mpz-results (prime)
494 (with-mpz-vars ((a ga))
495 (__gmpz_nextprime (addr prime) (addr ga)))))
498 (declare (optimize (speed 3) (space 3) (safety 0)))
499 (check-type n (unsigned-byte #.sb-vm:n-word-bits))
500 (with-gmp-mpz-results (fac)
501 (__gmpz_fac_ui (addr fac) n)))
504 (declare (optimize (speed 3) (space 3) (safety 0)))
505 (check-type n (unsigned-byte #.sb-vm:n-word-bits))
506 (with-gmp-mpz-results (fac)
507 (__gmpz_2fac_ui (addr fac) n)))
509 (defun %mpz-mfac (n m)
510 (declare (optimize (speed 3) (space 3) (safety 0)))
511 (check-type n (unsigned-byte #.sb-vm:n-word-bits))
512 (check-type m (unsigned-byte #.sb-vm:n-word-bits))
513 (with-gmp-mpz-results (fac)
514 (__gmpz_mfac_uiui (addr fac) n m)))
516 (defun %mpz-primorial (n)
517 (declare (optimize (speed 3) (space 3) (safety 0)))
518 (check-type n (unsigned-byte #.sb-vm:n-word-bits))
519 (with-gmp-mpz-results (r)
520 (__gmpz_primorial_ui (addr r) n)))
522 (defun setup-5.1-stubs ()
523 (macrolet ((stubify (name implementation &rest arguments)
524 `(setf (fdefinition ',name)
525 (if (member :sb-gmp-5.1 *gmp-features*)
526 (fdefinition ',implementation)
528 (declare (ignore ,@arguments))
529 (error "~S is only available in GMP >= 5.1"
531 (stubify mpz-2fac %mpz-2fac n)
532 (stubify mpz-mfac %mpz-mfac n m)
533 (stubify mpz-primorial %mpz-primorial n)))
536 (declare (optimize (speed 3) (space 3) (safety 0)))
537 (check-type k (unsigned-byte #.sb-vm:n-word-bits))
538 (with-gmp-mpz-results (r)
539 (with-mpz-vars ((n gn))
540 (__gmpz_bin_ui (addr r) (addr gn) k))))
543 (declare (optimize (speed 3) (space 3) (safety 0)))
544 ;; (let ((size (1+ (ceiling (* n (log 1.618034 2)) 64)))))
545 ;; fibonacci number magnitude in bits is assymptotic to n(log_2 phi)
546 ;; This is correct for the result but appears not to be enough for GMP
547 ;; during computation (memory access error), so use GMP-side allocation.
548 (check-type n (unsigned-byte #.sb-vm:n-word-bits))
549 (with-gmp-mpz-results (fibn fibn-1)
550 (__gmpz_fib2_ui (addr fibn) (addr fibn-1) n)))
553 ;;;; Random bignum (mpz) generation
555 ;; we do not actually use the gestalt of the struct but need its size
556 ;; for allocation purposes
557 (define-alien-type nil
559 (mp_seed (struct gmpint))
563 (declaim (inline __gmp_randinit_mt
564 __gmp_randinit_lc_2exp
570 (define-alien-routine __gmp_randinit_mt void
571 (s (* (struct gmprandstate))))
573 (define-alien-routine __gmp_randinit_lc_2exp void
574 (s (* (struct gmprandstate)))
575 (a (* (struct gmpint)))
579 (define-alien-routine __gmp_randseed void
580 (s (* (struct gmprandstate)))
581 (sd (* (struct gmpint))))
583 (define-alien-routine __gmp_randseed_ui void
584 (s (* (struct gmprandstate)))
587 (define-alien-routine __gmpz_urandomb void
588 (r (* (struct gmpint)))
589 (s (* (struct gmprandstate)))
590 (bcnt unsigned-long))
592 (define-alien-routine __gmpz_urandomm void
593 (r (* (struct gmpint)))
594 (s (* (struct gmprandstate)))
595 (n (* (struct gmpint))))
597 (defstruct (gmp-rstate (:constructor %make-gmp-rstate))
598 (ref (make-alien (struct gmprandstate))
599 :type (alien (* (struct gmprandstate))) :read-only t))
601 (defun make-gmp-rstate ()
602 "Instantiate a state for the GMP Mersenne-Twister random number generator."
603 (declare (optimize (speed 3) (space 3)))
604 (let* ((state (%make-gmp-rstate))
605 (ref (gmp-rstate-ref state)))
606 (__gmp_randinit_mt ref)
607 (sb-ext:finalize state (lambda () (free-alien ref)))
610 (defun make-gmp-rstate-lc (a c m2exp)
611 "Instantiate a state for the GMP linear congruential random number generator."
612 (declare (optimize (speed 3) (space 3) (safety 0)))
613 (check-type c (unsigned-byte #.sb-vm:n-word-bits))
614 (check-type m2exp (unsigned-byte #.sb-vm:n-word-bits))
615 (let* ((state (%make-gmp-rstate))
616 (ref (gmp-rstate-ref state)))
617 (with-mpz-vars ((a ga))
618 (__gmp_randinit_lc_2exp ref (addr ga) c m2exp))
619 (sb-ext:finalize state (lambda () (free-alien ref)))
622 (defun rand-seed (state seed)
623 "Initialize a random STATE with SEED."
624 (declare (optimize (speed 3) (space 3) (safety 0)))
625 (check-type state gmp-rstate)
626 (let ((ref (gmp-rstate-ref state)))
628 ((typep seed '(unsigned-byte #.sb-vm:n-word-bits))
629 (__gmp_randseed_ui ref seed))
630 ((typep seed '(integer 0 *))
631 (with-mpz-vars ((seed gseed))
632 (__gmp_randseed ref (addr gseed))))
634 (error "SEED must be a positive integer")))))
636 (defun random-bitcount (state bitcount)
637 "Return a random integer in the range 0..(2^bitcount - 1)."
638 (declare (optimize (speed 3) (space 3) (safety 0)))
639 (check-type state gmp-rstate)
640 (check-type bitcount (unsigned-byte #.sb-vm:n-word-bits))
641 (let ((ref (gmp-rstate-ref state)))
642 (with-mpz-results ((result (+ (ceiling bitcount sb-vm:n-word-bits) 2)))
643 (__gmpz_urandomb (addr result) ref bitcount))))
645 (defun random-int (state boundary)
646 "Return a random integer in the range 0..(boundary - 1)."
647 (declare (optimize (speed 3) (space 3) (safety 0)))
648 (check-type state gmp-rstate)
649 (let ((b (bassert boundary))
650 (ref (gmp-rstate-ref state)))
651 (with-mpz-results ((result (1+ (%bignum-length b))))
652 (with-mpz-vars ((b gb))
653 (__gmpz_urandomm (addr result) ref (addr gb))))))
656 ;;; Rational functions
657 (declaim (inline %lsize))
658 (defun %lsize (minusp n)
659 (declare (optimize (speed 3) (space 3) (safety 0)))
660 "n must be a (potentially denormalized) bignum"
661 (let ((length (%bignum-length n)))
662 (when (zerop (%bignum-ref n (1- length)))
664 (if minusp (- length) length)))
666 (defmacro defmpqfun (name gmpfun)
668 (declaim (sb-ext:maybe-inline ,name))
670 (declare (optimize (speed 3) (space 3) (safety 0)))
671 (let ((size (+ (max (blength (numerator a))
672 (blength (denominator a)))
673 (max (blength (numerator b))
674 (blength (denominator b)))
676 (with-alien ((r (struct gmprat)))
677 (let ((num (%allocate-bignum size))
678 (den (%allocate-bignum size)))
679 (sb-sys:with-pinned-objects (num den)
680 (setf (slot (slot r 'mp_num) 'mp_size) 0
681 (slot (slot r 'mp_num) 'mp_alloc) size
682 (slot (slot r 'mp_num) 'mp_d) (bignum-data-sap num))
683 (setf (slot (slot r 'mp_den) 'mp_size) 0
684 (slot (slot r 'mp_den) 'mp_alloc) size
685 (slot (slot r 'mp_den) 'mp_d) (bignum-data-sap den))
686 (let* ((an (bassert (numerator a)))
687 (ad (bassert (denominator a)))
688 (asign (not (%bignum-0-or-plusp an (%bignum-length an))))
689 (bn (bassert (numerator b)))
690 (bd (bassert (denominator b)))
691 (bsign (not (%bignum-0-or-plusp bn (%bignum-length bn)))))
693 (setf an (negate-bignum an nil)))
695 (setf bn (negate-bignum bn nil)))
696 (let* ((anlen (%lsize asign an))
697 (adlen (%lsize NIL ad))
698 (bnlen (%lsize bsign bn))
699 (bdlen (%lsize NIL bd)))
700 (with-alien ((arga (struct gmprat))
701 (argb (struct gmprat)))
702 (sb-sys:with-pinned-objects (an ad bn bd)
703 (setf (slot (slot arga 'mp_num) 'mp_size) anlen
704 (slot (slot arga 'mp_num) 'mp_alloc) (abs anlen)
705 (slot (slot arga 'mp_num) 'mp_d)
706 (bignum-data-sap an))
707 (setf (slot (slot arga 'mp_den) 'mp_size) adlen
708 (slot (slot arga 'mp_den) 'mp_alloc) (abs adlen)
709 (slot (slot arga 'mp_den) 'mp_d)
710 (bignum-data-sap ad))
711 (setf (slot (slot argb 'mp_num) 'mp_size) bnlen
712 (slot (slot argb 'mp_num) 'mp_alloc) (abs bnlen)
713 (slot (slot argb 'mp_num) 'mp_d)
714 (bignum-data-sap bn))
715 (setf (slot (slot argb 'mp_den) 'mp_size) bdlen
716 (slot (slot argb 'mp_den) 'mp_alloc) (abs bdlen)
717 (slot (slot argb 'mp_den) 'mp_d)
718 (bignum-data-sap bd))
719 (,gmpfun (addr r) (addr arga) (addr argb)))))
720 (locally (declare (optimize (speed 1)))
721 (sb-kernel::build-ratio (if (minusp (slot (slot r 'mp_num) 'mp_size))
722 (z-to-bignum-neg num size)
723 (z-to-bignum num size))
724 (z-to-bignum den size)))))))))))
726 (defmpqfun mpq-add __gmpq_add)
727 (defmpqfun mpq-sub __gmpq_sub)
728 (defmpqfun mpq-mul __gmpq_mul)
729 (defmpqfun mpq-div __gmpq_div)
732 ;;;; SBCL interface and integration installation
733 (macrolet ((def (name original)
734 (let ((special (intern (format nil "*~A-FUNCTION*" name))))
736 (declaim (type function ,special)
738 (defvar ,special (symbol-function ',original))
739 (defun ,name (&rest args)
740 (apply (load-time-value ,special t) args))))))
741 (def orig-mul multiply-bignums)
742 (def orig-truncate bignum-truncate)
743 (def orig-gcd bignum-gcd)
744 (def orig-lcm sb-kernel:two-arg-lcm)
745 (def orig-isqrt isqrt)
746 (def orig-two-arg-+ sb-kernel:two-arg-+)
747 (def orig-two-arg-- sb-kernel:two-arg--)
748 (def orig-two-arg-* sb-kernel:two-arg-*)
749 (def orig-two-arg-/ sb-kernel:two-arg-/))
753 (declare (optimize (speed 3) (space 3))
754 (type bignum-type a b)
756 (if (or (< (min (%bignum-length a)
763 (defun gmp-truncate (a b)
764 (declare (optimize (speed 3) (space 3))
765 (type bignum-type a b)
767 (if (or (< (min (%bignum-length a)
775 (declare (optimize (speed 3) (space 3))
778 (if (or (and (typep a 'fixnum)
785 (declare (optimize (speed 3) (space 3))
786 (type unsigned-byte n)
788 (if (or (typep n 'fixnum)
794 (defun gmp-two-arg-+ (x y)
795 (declare (optimize (speed 3) (space 3))
797 (if (and (or (typep x 'ratio)
801 (not *gmp-disabled*))
803 (orig-two-arg-+ x y)))
805 (defun gmp-two-arg-- (x y)
806 (declare (optimize (speed 3) (space 3))
808 (if (and (or (typep x 'ratio)
812 (not *gmp-disabled*))
814 (orig-two-arg-- x y)))
816 (defun gmp-two-arg-* (x y)
817 (declare (optimize (speed 3) (space 3))
819 (if (and (or (typep x 'ratio)
823 (not *gmp-disabled*))
825 (orig-two-arg-* x y)))
827 (defun gmp-two-arg-/ (x y)
828 (declare (optimize (speed 3) (space 3))
830 (if (and (rationalp x)
833 (not *gmp-disabled*))
835 (orig-two-arg-/ x y)))
838 (defmacro with-package-locks-ignored (&body body)
839 `(handler-bind ((sb-ext:package-lock-violation
841 (declare (ignore condition))
842 (invoke-restart :ignore-all))))
845 (defun install-gmp-funs ()
846 (with-package-locks-ignored
847 (macrolet ((def (destination source)
848 `(setf (fdefinition ',destination)
849 (fdefinition ',source))))
850 (def multiply-bignums gmp-mul)
851 (def bignum-truncate gmp-truncate)
852 (def bignum-gcd mpz-gcd)
853 (def sb-kernel:two-arg-lcm gmp-lcm)
854 (def sb-kernel:two-arg-+ gmp-two-arg-+)
855 (def sb-kernel:two-arg-- gmp-two-arg--)
856 (def sb-kernel:two-arg-* gmp-two-arg-*)
857 (def sb-kernel:two-arg-/ gmp-two-arg-/)
858 (def isqrt gmp-isqrt)))
861 (defun uninstall-gmp-funs ()
862 (with-package-locks-ignored
863 (macrolet ((def (destination source)
864 `(setf (fdefinition ',destination)
865 ,(intern (format nil "*~A-FUNCTION*" source)))))
866 (def multiply-bignums orig-mul)
867 (def bignum-truncate orig-truncate)
868 (def bignum-gcd orig-gcd)
869 (def sb-kernel:two-arg-lcm orig-lcm)
870 (def sb-kernel:two-arg-+ orig-two-arg-+)
871 (def sb-kernel:two-arg-- orig-two-arg--)
872 (def sb-kernel:two-arg-* orig-two-arg-*)
873 (def sb-kernel:two-arg-/ orig-two-arg-/)
874 (def isqrt orig-isqrt)))
877 (defun load-gmp (&key (persistently t))
878 (setf *gmp-features* nil
880 *features* (set-difference *features* '(:sb-gmp :sb-gmp-5.0 :sb-gmp-5.1)))
882 (pushnew 'load-gmp sb-ext:*init-hooks*)
883 (pushnew 'uninstall-gmp-funs sb-ext:*save-hooks*))
884 (let ((success (%load-gmp)))
886 (setf *gmp-version* (extern-alien "__gmp_version" c-string)))
887 (cond ((null *gmp-version*))
888 ((string<= *gmp-version* "5.")
889 (warn "SB-GMP requires at least GMP version 5.0")
892 (pushnew :sb-gmp *gmp-features*)
893 (pushnew :sb-gmp-5.0 *gmp-features*)
894 (when (string>= *gmp-version* "5.1")
895 (pushnew :sb-gmp-5.1 *gmp-features*))
896 (setf *features* (union *features* *gmp-features*))))
899 (uninstall-gmp-funs))
904 (setf sb-ext:*init-hooks* (remove 'load-gmp sb-ext:*init-hooks*))
906 (setf sb-ext:*save-hooks* (remove 'uninstall-gmp-funs sb-ext:*save-hooks*))