src/code/bignum-random.lisp

   1 ;;;; generation of random bignums
   2 ;;;;
   3 ;;;; The implementation assumes that the random chunk size is either
   4 ;;;; equal to the word size or equal to half the word size.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB-BIGNUM")
  16
  17 ;;; Return a nonnegative integer of DIGIT-SIZE many pseudo random bits.
  18 (declaim (inline random-bignum-digit))
  19 (defun random-bignum-digit (state)
  20   (if (= sb-kernel:n-random-chunk-bits digit-size)
  21       (sb-kernel:random-chunk state)
  22       (sb-kernel:big-random-chunk state)))
  23
  24 ;;; Return a nonnegative integer of N-BITS many pseudo random bits.
  25 ;;; N-BITS must be nonnegative and less than DIGIT-SIZE.
  26 (declaim (inline random-bignum-partial-digit))
  27 (defun random-bignum-partial-digit (n-bits state)
  28   (declare (type (integer 0 #.(1- digit-size)) n-bits)
  29            (type random-state state))
  30   (logand (1- (ash 1 n-bits))
  31           (if (<= n-bits sb-kernel:n-random-chunk-bits)
  32               (sb-kernel:random-chunk state)
  33               (sb-kernel:big-random-chunk state))))
  34
  35 ;;; Create a (nonnegative) bignum by concatenating RANDOM-CHUNK and
  36 ;;; BIT-COUNT many pseudo random bits, normalise and return it.
  37 ;;; RANDOM-CHUNK must fit into a bignum digit.
  38 (declaim (inline concatenate-random-bignum))
  39 (defun concatenate-random-bignum (random-chunk bit-count state)
  40   (declare (type bignum-element-type random-chunk)
  41            (type (integer 0 #.most-positive-fixnum) bit-count)
  42            (type random-state state))
  43   (let* ((n-total-bits (+ 1 sb-kernel:n-random-chunk-bits bit-count)) ; sign bit
  44          (length (ceiling n-total-bits digit-size))
  45          (bignum (%allocate-bignum length)))
  46     ;; DO NOT ASSUME THAT %ALLOCATE-BIGNUM PREZEROS
  47     ;; [See example in MAKE-RANDOM-BIGNUM]
  48     (setf (%bignum-ref bignum (1- length)) 0)
  49     (multiple-value-bind (n-random-digits n-random-bits)
  50         (floor bit-count digit-size)
  51       (declare (type bignum-length n-random-digits))
  52       (dotimes (index n-random-digits)
  53         (setf (%bignum-ref bignum index)
  54               (random-bignum-digit state)))
  55       (if (zerop n-random-bits)
  56           (setf (%bignum-ref bignum n-random-digits) random-chunk)
  57           (progn
  58             (setf (%bignum-ref bignum n-random-digits)
  59                   (logior (random-bignum-partial-digit n-random-bits
  60                                                        state)
  61                           (%ashl random-chunk n-random-bits)))
  62             (let ((shift (- digit-size n-random-bits)))
  63               (when (< shift sb-kernel:n-random-chunk-bits)
  64                 (setf (%bignum-ref bignum (1+ n-random-digits))
  65                       (%digit-logical-shift-right random-chunk shift)))))))
  66     (%normalize-bignum bignum length)))
  67
  68 ;;; Create and return a (nonnegative) bignum of N-BITS many pseudo
  69 ;;; random bits. The result is normalised, so may be a fixnum, too.
  70 (declaim (inline make-random-bignum))
  71 (defun make-random-bignum (n-bits state)
  72   (declare (type (and fixnum (integer 0)) n-bits)
  73            (type random-state state))
  74   (let* ((n-total-bits (1+ n-bits)) ; sign bit
  75          (length (ceiling n-total-bits digit-size))
  76          (bignum (%allocate-bignum length)))
  77     (declare (type bignum-length length))
  78     ;; DO NOT ASSUME THAT %ALLOCATE-BIGNUM PREZEROS
  79     ;; Consider: n-bits = 64 -> n-total-bits = 65 -> length = 2
  80     ;; and n-digits = 1, n-bits-partial-digit = 0
  81     ;; so DOTIMES executes exactly once, leaving the final word untouched.
  82     (setf (%bignum-ref bignum (1- length)) 0)
  83     (multiple-value-bind (n-digits n-bits-partial-digit)
  84         (floor n-bits digit-size)
  85       (declare (type bignum-length n-digits))
  86       (dotimes (index n-digits)
  87         (setf (%bignum-ref bignum index)
  88               (random-bignum-digit state)))
  89       (unless (zerop n-bits-partial-digit)
  90         (setf (%bignum-ref bignum n-digits)
  91               (random-bignum-partial-digit n-bits-partial-digit state))))
  92     (%normalize-bignum bignum length)))
  93
  94 ;;; Create and return a pseudo random bignum less than ARG. The result
  95 ;;; is normalised, so may be a fixnum, too. We try to keep the number of
  96 ;;; times RANDOM-CHUNK is called and the amount of storage consed to a
  97 ;;; minimum.
  98 ;;; Four cases are differentiated:
  99 ;;; * If ARG is a power of two and only one random chunk is needed to
 100 ;;;   supply a sufficient number of bits, a chunk is generated and
 101 ;;;   shifted to get the correct number of bits. This only conses if the
 102 ;;;   result is indeed a bignum. This case can only occur if the size of
 103 ;;;   the random chunks is equal to the word size.
 104 ;;; * If ARG is a power of two and multiple chunks are needed, we call
 105 ;;;   MAKE-RANDOM-BIGNUM. Here a bignum is always consed even if it
 106 ;;;   happens to normalize to a fixnum, which can't be avoided.
 107 ;;; * If ARG is not a power of two but one random chunk suffices an
 108 ;;;   accept-reject loop is used. Each time through the loop a chunk is
 109 ;;;   generated and shifted to get the correct number of bits. This only
 110 ;;;   conses if the final accepted result is indeed a bignum. This case
 111 ;;;   too can only occur if the size of the random chunks is equal to the
 112 ;;;   word size.
 113 ;;; * If ARG is not a power of two and multiple chunks are needed an
 114 ;;;   accept-reject loop is used that detects rejection early by
 115 ;;;   starting the generation with a random chunk aligned to the most
 116 ;;;   significant bits of ARG. If the random value is larger than the
 117 ;;;   corresponding chunk of ARG we don't need to generate the full
 118 ;;;   amount of random bits but can retry immediately. If the random
 119 ;;;   value is smaller than the ARG chunk we know already that the
 120 ;;;   result will be accepted independently of what the remaining random
 121 ;;;   bits will be, so we generate them and return. Only in the rare
 122 ;;;   case that the random value and the ARG chunk are equal we need to
 123 ;;;   generate and compare the complete random number and risk to reject
 124 ;;;   it.
 125 (defun %random-bignum (arg state)
 126   (declare (type (integer #.(1+ most-positive-fixnum)) arg)
 127            (type random-state state))
 128   (let* ((length (%bignum-length arg))
 129          (n-bits (bignum-buffer-integer-length arg length)))
 130     (declare (type (integer #.sb-vm:n-fixnum-bits) n-bits))
 131     ;; Don't use (ZEROP (LOGAND ARG (1- ARG))) to test if ARG is a power
 132     ;; of two as that would cons.
 133     (cond ((bignum-lower-bits-zero-p arg (1- n-bits) length)
 134            ;; ARG is a power of two. We need one bit less than its
 135            ;; INTEGER-LENGTH. Not using (DECF N-BITS) here allows the
 136            ;; compiler to make optimal use of the type declaration for
 137            ;; N-BITS above.
 138            (let ((n-bits (1- n-bits)))
 139              (if (<= n-bits sb-kernel:n-random-chunk-bits)
 140                  (%digit-logical-shift-right (sb-kernel:random-chunk state)
 141                                              (- sb-kernel:n-random-chunk-bits n-bits))
 142                  (make-random-bignum n-bits state))))
 143           ((<= n-bits sb-kernel:n-random-chunk-bits)
 144            (let ((shift (- sb-kernel:n-random-chunk-bits n-bits))
 145                  (arg (%bignum-ref arg 0)))
 146              (loop
 147               (let ((bits (%digit-logical-shift-right (sb-kernel:random-chunk state)
 148                                                       shift)))
 149                 (when (< bits arg)
 150                   (return bits))))))
 151           (t
 152            ;; ARG is not a power of two and we need more than one random
 153            ;; chunk.
 154            (let* ((shift (- n-bits sb-kernel:n-random-chunk-bits))
 155                   (arg-first-chunk (ldb (byte sb-kernel:n-random-chunk-bits shift)
 156                                         arg)))
 157              (loop
 158               (let ((random-chunk (sb-kernel:random-chunk state)))
 159                 ;; If the random value is larger than the corresponding
 160                 ;; chunk from the most significant bits of ARG we can
 161                 ;; retry immediately; no need to generate the remaining
 162                 ;; random bits.
 163                 (unless (> random-chunk arg-first-chunk)
 164                   ;; We need to generate the complete random number.
 165                   (let ((bits (concatenate-random-bignum random-chunk
 166                                                          shift state)))
 167                     ;; While the second comparison below subsumes the
 168                     ;; first, the first is faster and will nearly
 169                     ;; always be true, so it's worth it to try it
 170                     ;; first.
 171                     (when (or (< random-chunk arg-first-chunk)
 172                               (< bits arg))
 173                       (return bits)))))))))))