diff --git a/code/bits-float.lisp b/code/bits-float.lisp index 6289be20..8711d389 100644 --- a/code/bits-float.lisp +++ b/code/bits-float.lisp @@ -15,75 +15,95 @@ (- ub32 #.(ash 1 32)) ub32)) +#+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod bits-float-form (client (result-type (eql 'single-float)) value-form) + (declare (ignore client)) + #+abcl + `(system:make-single-float ,value-form) + #+allegro + `(let ((value ,value-form)) + (excl:shorts-to-single-float (ldb (byte 16 16) value) + (ldb (byte 16 0) value))) + #+ccl + `(ccl::host-single-float-from-unsigned-byte-32 ,value-form) + #+clasp + `(ext:bits-to-single-float ,value-form) + #+cmucl + `(kernel:make-single-float (ub32-sb32 ,value-form)) + #+ecl + `(system:bits-single-float ,value-form) + #+lispworks + `(let ((v (sys:make-typed-aref-vector 4))) + (declare (optimize (speed 3) (float 0) (safety 0)) + (dynamic-extent v)) + (setf (sys:typed-aref '(unsigned-byte 32) v 0) ,value-form) + (sys:typed-aref 'single-float v 0)) + #+mezzano + `(mezzano.extensions:ieee-binary32-to-single-float ,value-form) + #+sbcl + `(sb-kernel:make-single-float (ub32-sb32 ,value-form)))) + #+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) (defmethod bits-float (client (result-type (eql 'single-float)) value) (declare (ignore client)) - #+abcl - (system:make-single-float value) - #+allegro - (excl:shorts-to-single-float (ldb (byte 16 16) value) - (ldb (byte 16 0) value)) - #+ccl - (ccl::host-single-float-from-unsigned-byte-32 value) - #+clasp - (ext:bits-to-single-float value) - #+cmucl - (kernel:make-single-float (ub32-sb32 value)) - #+ecl - (system:bits-single-float value) - #+lispworks - (let ((v (sys:make-typed-aref-vector 4))) - (declare (optimize (speed 3) (float 0) (safety 0)) - (dynamic-extent v)) - (setf (sys:typed-aref '(unsigned-byte 32) v 0) value) - (sys:typed-aref 'single-float v 0)) - #+mezzano - (mezzano.extensions:ieee-binary32-to-single-float value) - #+sbcl - (sb-kernel:make-single-float (ub32-sb32 value))) + (macrolet ((body () (bits-float-form nil 'single-float 'value))) + (body))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + #+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) + (defmethod bits-float-form (client (result-type (eql 'double-float)) value-form) + (declare (ignore client)) + #+abcl + `(system:make-double-float ,value-form) + #+allegro + `(let* ((value ,value-form) + (us3 (ldb (byte 16 48) value)) + (us2 (ldb (byte 16 32) value)) + (us1 (ldb (byte 16 16) value)) + (us0 (ldb (byte 16 0) value))) + (excl:shorts-to-double-float us3 us2 us1 us0)) + #+ccl + `(let* ((value ,value-form) + (upper (ldb (byte 32 32) value)) + (lower (ldb (byte 32 0) value))) + (ccl::double-float-from-bits upper lower)) + #+clasp + (ext:bits-to-double-float value) + #+cmucl + `(let* ((value ,value-form) + (upper (ub32-sb32 (ldb (byte 32 32) value))) + (lower (ldb (byte 32 0) value))) + (kernel:make-double-float upper lower)) + #+ecl + `(system:bits-double-float ,value-form) + #+lispworks + `(let* ((value ,value-form) + (upper (ldb (byte 32 32) value)) + (lower (ldb (byte 32 0) value)) + (v (sys:make-typed-aref-vector 8))) + (declare (optimize (speed 3) (float 0) (safety 0)) + (dynamic-extent v)) + #+little-endian + (setf (sys:typed-aref '(unsigned-byte 32) v 0) lower + (sys:typed-aref '(unsigned-byte 32) v 4) upper) + #-little-endian + (setf (sys:typed-aref '(unsigned-byte 32) v 0) upper + (sys:typed-aref '(unsigned-byte 32) v 4) lower) + (sys:typed-aref 'double-float v 0)) + #+mezzano + `(mezzano.extensions:ieee-binary64-to-double-float ,value-form) + #+sbcl + `(let* ((value ,value-form) + (upper (ub32-sb32 (ldb (byte 32 32) value))) + (lower (ldb (byte 32 0) value))) + (sb-kernel:make-double-float upper lower)))) #+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) (defmethod bits-float (client (result-type (eql 'double-float)) value) (declare (ignore client)) - #+abcl - (system:make-double-float value) - #+allegro - (let ((us3 (ldb (byte 16 48) value)) - (us2 (ldb (byte 16 32) value)) - (us1 (ldb (byte 16 16) value)) - (us0 (ldb (byte 16 0) value))) - (excl:shorts-to-double-float us3 us2 us1 us0)) - #+ccl - (let ((upper (ldb (byte 32 32) value)) - (lower (ldb (byte 32 0) value))) - (ccl::double-float-from-bits upper lower)) - #+clasp - (ext:bits-to-double-float value) - #+cmucl - (let ((upper (ub32-sb32 (ldb (byte 32 32) value))) - (lower (ldb (byte 32 0) value))) - (kernel:make-double-float upper lower)) - #+ecl - (system:bits-double-float value) - #+lispworks - (let ((upper (ldb (byte 32 32) value)) - (lower (ldb (byte 32 0) value)) - (v (sys:make-typed-aref-vector 8))) - (declare (optimize (speed 3) (float 0) (safety 0)) - (dynamic-extent v)) - #+little-endian - (setf (sys:typed-aref '(unsigned-byte 32) v 0) lower - (sys:typed-aref '(unsigned-byte 32) v 4) upper) - #-little-endian - (setf (sys:typed-aref '(unsigned-byte 32) v 0) upper - (sys:typed-aref '(unsigned-byte 32) v 4) lower) - (sys:typed-aref 'double-float v 0)) - #+mezzano - (mezzano.extensions:ieee-binary64-to-double-float value) - #+sbcl - (let ((upper (ub32-sb32 (ldb (byte 32 32) value))) - (lower (ldb (byte 32 0) value))) - (sb-kernel:make-double-float upper lower))) + (macrolet ((body () (bits-float-form nil 'double-float 'value))) + (body))) #+(and ecl quaviver/long-float-fallback) (ffi:def-union long-float/uint128 diff --git a/code/compare/float-integer.lisp b/code/compare/float-integer.lisp index 0007d88b..d32ee307 100644 --- a/code/compare/float-integer.lisp +++ b/code/compare/float-integer.lisp @@ -55,7 +55,7 @@ (list* (float-hex-digits (float-type (iterator-interval iterator))) result))) (not result)) - (error (condition) + (error () (format stream "~:@<#x~x :error~:@>~%" (iterator-bits iterator)) nil))) diff --git a/code/compare/integer-float.lisp b/code/compare/integer-float.lisp index e9a06f39..521e53ed 100644 --- a/code/compare/integer-float.lisp +++ b/code/compare/integer-float.lisp @@ -38,8 +38,7 @@ (list* (float-hex-digits (float-type (iterator-interval iterator))) result))) (not result)) - (error (condition) - (declare (ignore condition)) + (error () (format stream "~:@<#x~x :error~:@>~%" (iterator-bits iterator)) nil))) diff --git a/code/integer-float-2.lisp b/code/integer-float-2.lisp index ee7105c9..3388cb8c 100644 --- a/code/integer-float-2.lisp +++ b/code/integer-float-2.lisp @@ -10,87 +10,92 @@ :operation 'quaviver:integer-float :operands (list client result-type base significand exponent sign))) -(defmacro %integer-encode-float (client type significand exponent sign) - (with-accessors ((storage-size storage-size) - (significand-bytespec significand-bytespec) - (significand-byte-form significand-byte-form) - (exponent-bytespec exponent-bytespec) - (exponent-byte-form exponent-byte-form) - (sign-byte-form sign-byte-form) - (nan-payload-byte-form nan-payload-byte-form) - (nan-type-byte-form nan-type-byte-form) - (hidden-bit-p hidden-bit-p) - (exponent-bias exponent-bias) - (min-exponent min-exponent) - (max-exponent max-exponent) - (significand-size significand-size)) - type - (let ((exponent-var (gensym)) - (significand-var (gensym)) - (bits-var (gensym))) - `(let ((,bits-var 0) - (,exponent-var ,exponent) - (,significand-var ,significand)) - (declare (type (unsigned-byte ,storage-size) - ,bits-var ,significand-var) - (type (or fixnum keyword) - ,exponent-var) - (type fixnum ,sign) - (optimize speed)) - (when (minusp ,sign) - (setf (ldb ,sign-byte-form ,bits-var) 1)) - (cond ((keywordp ,exponent-var) - (setf (ldb ,exponent-byte-form ,bits-var) - ,(1- (ash 1 (byte-size exponent-bytespec)))) - (ecase ,exponent-var - (:infinity) - (:quiet-nan - (setf (ldb ,nan-type-byte-form ,bits-var) 1 - (ldb ,nan-payload-byte-form ,bits-var) ,significand-var)) - (:signaling-nan - (setf (ldb ,nan-payload-byte-form ,bits-var) - (if (zerop ,significand-var) 1 ,significand-var))))) - ((zerop ,significand-var)) - (t - (let ((shift (- ,significand-size - (integer-length ,significand-var)))) - (setf ,significand-var (ash ,significand-var shift)) - (decf ,exponent-var shift)) - (cond ((< ,exponent-var ,min-exponent) - (integer-float-underflow - ,client ',type 2 ,significand ,exponent ,sign)) - ((> ,exponent-var ,max-exponent) - (integer-float-overflow - ,client ',type 2 ,significand ,exponent ,sign)) - (t - (incf ,exponent-var ,exponent-bias) - (cond ((plusp ,exponent-var) - (setf (ldb ,significand-byte-form ,bits-var) - ,significand-var - (ldb ,exponent-byte-form ,bits-var) - ,exponent-var)) - (t ; Unadjusted subnormal - (setf (ldb (byte (+ ,(byte-size significand-bytespec) - ,exponent-var) - ,(byte-position significand-bytespec)) - ,bits-var) - (ldb (byte (+ ,(byte-size significand-bytespec) - ,exponent-var) - (- ,(1+ (byte-position significand-bytespec)) - ,exponent-var)) - ,significand-var)))))))) - (quaviver:bits-float nil ',type ,bits-var))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod integer-float-form + (client result-type (base (eql 2)) significand-form exponent-form sign-form) + (with-accessors ((storage-size storage-size) + (significand-bytespec significand-bytespec) + (significand-byte-form significand-byte-form) + (exponent-bytespec exponent-bytespec) + (exponent-byte-form exponent-byte-form) + (sign-byte-form sign-byte-form) + (nan-payload-byte-form nan-payload-byte-form) + (nan-type-byte-form nan-type-byte-form) + (hidden-bit-p hidden-bit-p) + (exponent-bias exponent-bias) + (min-exponent min-exponent) + (max-exponent max-exponent) + (significand-size significand-size)) + result-type + (let ((bits-var (gensym)) + (significand-var (gensym)) + (exponent-var (gensym)) + (sign-var (gensym))) + `(let ((,bits-var 0) + (,significand-var ,significand-form) + (,exponent-var ,exponent-form) + (,sign-var ,sign-form)) + (declare (type (unsigned-byte ,storage-size) + ,bits-var ,significand-var) + (type (or fixnum keyword) + ,exponent-var) + (type fixnum ,sign-var) + (optimize speed)) + (when (minusp ,sign-var) + (setf (ldb ,sign-byte-form ,bits-var) 1)) + (cond ((keywordp ,exponent-var) + (setf (ldb ,exponent-byte-form ,bits-var) + ,(1- (ash 1 (byte-size exponent-bytespec)))) + (ecase ,exponent-var + (:infinity) + (:quiet-nan + (setf (ldb ,nan-type-byte-form ,bits-var) 1 + (ldb ,nan-payload-byte-form ,bits-var) ,significand-var)) + (:signaling-nan + (setf (ldb ,nan-payload-byte-form ,bits-var) + (if (zerop ,significand-var) 1 ,significand-var))))) + ((zerop ,significand-var)) + (t + (let ((shift (- ,significand-size + (integer-length ,significand-var)))) + (setf ,significand-var (ash ,significand-var shift)) + (decf ,exponent-var shift)) + (cond ((< ,exponent-var ,min-exponent) + (integer-float-underflow + ,client ',result-type 2 ,significand-var ,exponent-var ,sign-var)) + ((> ,exponent-var ,max-exponent) + (integer-float-overflow + ,client ',result-type 2 ,significand-var ,exponent-var ,sign-var)) + (t + (incf ,exponent-var ,exponent-bias) + (cond ((plusp ,exponent-var) + (setf (ldb ,significand-byte-form ,bits-var) + ,significand-var + (ldb ,exponent-byte-form ,bits-var) + ,exponent-var)) + (t ; Unadjusted subnormal + (setf (ldb (byte (+ ,(byte-size significand-bytespec) + ,exponent-var) + ,(byte-position significand-bytespec)) + ,bits-var) + (ldb (byte (+ ,(byte-size significand-bytespec) + ,exponent-var) + (- ,(1+ (byte-position significand-bytespec)) + ,exponent-var)) + ,significand-var)))))))) + ,(quaviver:bits-float-form nil result-type bits-var)))))) -(defmethod integer-float - (client (result-type (eql 'single-float)) (base (eql 2)) significand exponent sign) - (%integer-encode-float client single-float - significand exponent sign)) +(macrolet ((body (type significand exponent sign) + (integer-float-form nil type 2 significand exponent sign))) -#+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) -(defmethod integer-float - (client (result-type (eql 'double-float)) (base (eql 2)) significand exponent sign) - (%integer-encode-float client double-float - significand exponent sign)) + (defmethod integer-float + (client (result-type (eql 'single-float)) (base (eql 2)) significand exponent sign) + (body single-float significand exponent sign)) + + #+(or abcl allegro ccl clasp cmucl ecl lispworks mezzano sbcl) + (defmethod integer-float + (client (result-type (eql 'double-float)) (base (eql 2)) significand exponent sign) + (body double-float significand exponent sign))) #+quaviver/long-float (defmethod integer-float diff --git a/code/liebler/implementation.lisp b/code/liebler/implementation.lisp index 2d2224a7..3846119d 100644 --- a/code/liebler/implementation.lisp +++ b/code/liebler/implementation.lisp @@ -3,6 +3,14 @@ (defclass client () ()) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun %compute-min-exponent (min-exponent significand-size) + (declare (ignore significand-size)) + (ceiling (/ (* (- min-exponent 4) 4194304) 13933176))) + + (defun %compute-max-exponent (max-exponent significand-size) + (floor (/ (* (+ max-exponent 4 significand-size) 4194304) 13933176)))) + (defmacro %liebler (client result-type significand exponent sign) (with-accessors ((arithmetic-size quaviver:arithmetic-size) (significand-size quaviver:significand-size) @@ -16,37 +24,43 @@ (type (or fixnum keyword) ,exponent) (type fixnum ,sign) (optimize speed)) - (if (or (not (numberp ,exponent)) - (zerop ,significand)) - (quaviver:integer-float ,client ',result-type 2 - ,significand ,exponent ,sign) - (let* ((k (quaviver.math:floor-log-expt 2 10 ,exponent)) - (q (+ k (integer-length ,significand) ,(- significand-size))) - (shift (- ,word-size (integer-length ,significand)))) - (declare (type fixnum k shift)) - ;; The following overflow and underflow checks are not - ;; strict checks. Stricter checks will happen in - ;; integer-float/2. These are here to protect the expt10 - ;; table lookup from an out of bounds error. - (when (> q ,(+ max-exponent - (quaviver.math:ceiling-log-expt 2 10 1))) - (quaviver::integer-float-overflow - ,client ',result-type 10 ,significand ,exponent ,sign)) - (when (< q ,(- min-exponent - (quaviver.math:ceiling-log-expt 2 10 1))) - (quaviver::integer-float-underflow - ,client ',result-type 10 ,significand ,exponent ,sign)) - (setf ,significand (quaviver.math:round-to-odd - ,arithmetic-size - (ash ,significand shift) - (quaviver.math:expt ,arithmetic-size 10 - (- ,exponent))) - k (- k -1 shift) - shift (- ,significand-size (integer-length ,significand))) - (quaviver:integer-float ,client ',result-type 2 - (round ,significand (ash 1 (- shift))) - (- k shift) - ,sign))))))) + (cond ((or (not (numberp ,exponent)) + (zerop ,significand)) + (quaviver:integer-float ,client ',result-type 2 + ,significand ,exponent ,sign)) + ((> ,exponent ,(%compute-max-exponent max-exponent significand-size)) + (quaviver::integer-float-overflow + ,client ',result-type 10 ,significand ,exponent ,sign)) + ((< ,exponent ,(%compute-min-exponent min-exponent significand-size)) + (quaviver::integer-float-underflow + ,client ',result-type 10 ,significand ,exponent ,sign)) + (t + (let* ((k (quaviver.math:floor-log-expt 2 10 ,exponent)) + (q (+ k (integer-length ,significand) ,(- significand-size))) + (shift (- ,word-size (integer-length ,significand)))) + (declare (type fixnum k shift)) + ;; The following overflow and underflow checks are not + ;; strict checks. Stricter checks will happen in + ;; integer-float/2. These are here to protect the expt10 + ;; table lookup from an out of bounds error. + (when (> q ,(+ max-exponent + (quaviver.math:ceiling-log-expt 2 10 1))) + (quaviver::integer-float-overflow + ,client ',result-type 10 ,significand ,exponent ,sign)) + (when (< q ,(- min-exponent + (quaviver.math:ceiling-log-expt 2 10 1))) + (quaviver::integer-float-underflow + ,client ',result-type 10 ,significand ,exponent ,sign)) + (setf ,significand (quaviver.math:round-to-odd + ,arithmetic-size + (ash ,significand shift) + (quaviver.math:expt ,arithmetic-size 10 + (- ,exponent))) + k (- k -1 shift) + shift (- ,significand-size (integer-length ,significand))) + ,(quaviver:integer-float-form + nil result-type 2 + `(round ,significand (ash 1 (- shift))) `(- k shift) 'sign)))))))) #-clisp (defmethod quaviver:integer-float diff --git a/code/packages.lisp b/code/packages.lisp index 3d5d45c8..4e55879b 100644 --- a/code/packages.lisp +++ b/code/packages.lisp @@ -1,8 +1,10 @@ (defpackage #:quaviver (:use #:common-lisp) (:export #:bits-float + #:bits-float-form #:float-bits #:integer-float + #:integer-float-form #:float-integer #:digits-integer #:integer-digits