dragonbox: improve endpoints in nearest shorter interval

code/dragonbox/implementation.lisp

@@ -345,16 +345,7 @@
  (loop with remainder
  do (multiple-value-setq (number remainder) (floor number divisor))
  while (zerop remainder)
- count 1))
-
- ;; The -HIGH suffix is misleading for 32 bits and bignum.
- (defun word-high (var arithmetic-size)
- #+quaviver/bignum-elision
- (ecase arithmetic-size
- (32 (values var (ash arithmetic-size 1)))
- (64 (values `(aref ,var 0) 64)))
- #-quaviver/bignum-elision
- (values var (ash arithmetic-size 1))))
+ count 1)))
 
 ;;; The beta bounds methods serve only to manually determine the limits
 ;;; of beta so that the computations can be optimized appropriately.
@@ -455,17 +446,13 @@
  (beta (+ exponent (floor-log2-expt10 (- -k) ,min-k ,max-k)))
  (expt10 (,expt10 -k))
  ;; Left endpoint
- (xi ,(multiple-value-bind (high size) (word-high 'expt10 arithmetic-size)
- `(ldb (byte ,arithmetic-size 0)
- (ash (the (unsigned-byte ,size)
- (- ,high (ash ,high ,(- (1+ significand-size)))))
- (- (- ,size ,significand-size beta))))))
+ (xi (let ((hi64 (,hi/2n expt10 64)))
+ (quaviver/math:hi/64 (- hi64 (ash hi64 ,(- (1+ significand-size))))
+ (+ ,significand-size beta))))
  ;; Right endpoint
- (zi ,(multiple-value-bind (high size) (word-high 'expt10 arithmetic-size)
- `(ldb (byte ,arithmetic-size 0)
- (ash (the (unsigned-byte ,size)
- (+ ,high (ash ,high ,(- significand-size))))
- (- (- ,size ,significand-size beta)))))))
+ (zi (let ((hi64 (,hi/2n expt10 64)))
+ (quaviver/math:hi/64 (+ hi64 (ash hi64 ,(- significand-size)))
+ (+ ,significand-size beta)))))
  (declare ((signed-byte 32) -k beta)
  ((quaviver/math:arithmetic-word ,arithmetic-size 2) expt10)
  (dynamic-extent expt10)

code/math/implementation.lisp

@@ -184,12 +184,27 @@
 (defun hi/64 (x count)
  (ash x (- count 64)))
 
+(define-compiler-macro hi/64 (&whole whole x count)
+ (case count
+ (0 0)
+ (64 `(the (arithmetic-word 64) ,x))
+ (otherwise whole)))
+
 (defun hi/hi64/128 (x count)
  #+quaviver/bignum-elision
  (hi/64 (aref x 0) count)
  #-quaviver/bignum-elision
  (ash x (- count 128)))
 
+(define-compiler-macro hi/hi64/128 (&whole whole x count)
+ #-quaviver/bignum-elision
+ (declare (ignore x))
+ (case count
+ (0 0)
+ #+quaviver/bignum-elision
+ (64 `(aref (the (arithmetic-word 64 2) ,x) 0))
+ (otherwise whole)))
+
 (defmacro %round-to-odd-1 (cp g size)
  `(let ((p (* ,cp ,g)))
  (logior (ldb (byte ,size ,(ash size 1)) p)