Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Questionable Optimizations #10

Draft
wants to merge 4 commits into
base: main
Choose a base branch
from
Draft

Questionable Optimizations #10

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
b8ec48c
liebler: check exponents earlier to improve type inference
scymtym Jul 11, 2024
1950671
quaviver: allow clients to compute and inline BITS-FLOAT forms
scymtym Jul 11, 2024
f35e0b5
quaviver: allow clients to compute and inline base 2 INTEGER-FLOAT forms
scymtym Jul 11, 2024
39bcddd
compare: cosmetic change
scymtym Jul 11, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
144 changes: 82 additions & 62 deletions code/bits-float.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion code/compare/float-integer.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down
3 changes: 1 addition & 2 deletions code/compare/integer-float.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)))

Expand Down
163 changes: 84 additions & 79 deletions code/integer-float-2.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading