quaviver: Add external bit conversion

code/bits-float-late.lisp

@@ -0,0 +1,30 @@
+(in-package #:quaviver)
+
+(defmacro %external-float (float-type value)
+  (let ((implementation-type (implementation-type float-type)))
+    (if (exact-implementation-type-p float-type)
+        `(%bits-float ,implementation-type ,value)
+        `(multiple-value-bind (significand exponent sign)
+             ,(bits-primitive-triple-form float-type value)
+           ,(primitive-triple-float-form implementation-type 'significand 'exponent 'sign)))))
+
+(defmethod bits-float ((float-type (eql :bfloat16)) value)
+  (%external-float :bfloat16 value))
+
+(defmethod bits-float ((float-type (eql :binary16)) value)
+  (%external-float :binary16 value))
+
+(defmethod bits-float ((float-type (eql :binary32)) value)
+  (%external-float :binary32 value))
+
+(defmethod bits-float ((float-type (eql :binary64)) value)
+  (%external-float :binary64 value))
+
+(defmethod bits-float ((float-type (eql :binary80)) value)
+  (%external-float :binary80 value))
+
+(defmethod bits-float ((float-type (eql :binary128)) value)
+  (%external-float :binary128 value))
+
+(defmethod bits-float ((float-type (eql :binary256)) value)
+  (%external-float :binary256 value))

code/bits-primitive-triple-form.lisp

@@ -0,0 +1,47 @@
+(in-package #:quaviver)
+
+(defmethod bits-primitive-triple-form (float-type bits-var)
+  (with-accessors ((storage-size storage-size)
+                   (significand-size significand-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)
+                   (arithmetic-size arithmetic-size))
+      float-type
+    `(let ((exponent (ldb ,exponent-byte-form ,bits-var))
+           (sign (if (ldb-test ,sign-byte-form ,bits-var) -1 1)))
+       (declare (type (unsigned-byte ,storage-size) ,bits-var)
+                (type exponent-word exponent)
+                (type fixnum sign))
+       (cond ((= exponent ,(1- (ash 1 (byte-size exponent-bytespec))))
+              (if (ldb-test ,significand-byte-form ,bits-var) ; nan
+                  (values (ldb ,nan-payload-byte-form ,bits-var)
+                          (if (ldb-test ,nan-type-byte-form ,bits-var)
+                              :quiet-nan
+                              :signaling-nan)
+                          sign)
+                  (values 0 :infinity sign)))
+             (t
+              (let ((significand (ldb ,significand-byte-form ,bits-var)))
+                (declare (type (unsigned-byte ,(+ 6 significand-size))
+                               significand))
+                (cond ((and (zerop significand)
+                            (zerop exponent))
+                       (values 0 0 sign))
+                      (t
+                       (if (zerop exponent) ; subnormal
+                           (let ((shift (- ,significand-size
+                                           (integer-length significand))))
+                             (setf significand (ash significand shift)
+                                   exponent (- ,(- 1 exponent-bias) shift)))
+                           (setf ,@(when hidden-bit-p
+                                     `(significand (logior significand
+                                                           ,(ash 1 (byte-size significand-bytespec)))))
+                                 exponent (- exponent ,exponent-bias)))
+                       (values significand exponent sign)))))))))

code/bits-primitive-triple.lisp

@@ -0,0 +1,25 @@
+(in-package #:quaviver)
+
+(defmacro %bits-primitive-triple (float-type bits-var)
+  (bits-primitive-triple-form float-type bits-var))
+
+(defmethod bits-primitive-triple ((float-type (eql :bfloat16)) value)
+  (%bits-primitive-triple :bfloat16 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary16)) value)
+  (%bits-primitive-triple :binary16 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary32)) value)
+  (%bits-primitive-triple :binary32 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary64)) value)
+  (%bits-primitive-triple :binary64 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary80)) value)
+  (%bits-primitive-triple :binary80 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary128)) value)
+  (%bits-primitive-triple :binary128 value))
+
+(defmethod bits-primitive-triple ((float-type (eql :binary256)) value)
+  (%bits-primitive-triple :binary256 value))

code/external-traits.lisp

@@ -0,0 +1,135 @@
+(in-package #:quaviver)
+
+
+(defmacro %external-traits (type exponent-size significand-size)
+  (let* ((hidden-bit-p (= 1 (logcount (+ exponent-size significand-size))))
+         (storage-size (if hidden-bit-p
+                           (+ exponent-size significand-size)
+                           (+ 1 exponent-size significand-size)))
+         (stored-significand-size (if hidden-bit-p
+                                      (1- significand-size)
+                                      significand-size))
+      	 (sign-size 1)
+         (subnormalp t)
+         (non-number-p t)
+         (internal-base 2)
+         (exponent-bias (+ (ash 1 (1- exponent-size)) significand-size -2))
+         (min-exponent (- 2 exponent-bias significand-size))
+         (max-exponent (- (ash 1 (1- exponent-size)) significand-size))
+         (implementation-type (loop for (type . tail) on '(#+quaviver/short-float short-float
+                                                           single-float
+                                                           double-float
+                                                           #+quaviver/long-float long-float)
+                                    when (or (null tail)
+                                             (and (>= (exponent-size type)
+                                                      exponent-size)
+                                                  (>= (significand-size type)
+                                                      significand-size)))
+                                      return type))
+         (exactp (loop for (type . tail) on '(#+quaviver/short-float short-float
+                                              single-float
+                                              double-float
+                                              #+quaviver/long-float long-float)
+                       when (or (null tail)
+                                (and (>= (exponent-size type)
+                                         exponent-size)
+                                     (>= (significand-size type)
+                                         significand-size)))
+                         return (and (= (exponent-size type)
+                                        exponent-size)
+                                     (= (significand-size type)
+                                        significand-size)))))
+    `(progn
+       (defmethod storage-size ((type (eql ',type)))
+         ,storage-size)
+
+       (defmethod significand-bytespec ((type (eql ',type)))
+         (byte ,stored-significand-size 0))
+
+       (defmethod significand-byte-form ((type (eql ',type)))
+         '(byte ,stored-significand-size 0))
+
+       (defmethod significand-size ((type (eql ',type)))
+         ,significand-size)
+
+       (defmethod exponent-bytespec ((type (eql ',type)))
+         (byte ,exponent-size ,stored-significand-size))
+
+       (defmethod exponent-byte-form ((type (eql ',type)))
+         '(byte ,exponent-size ,stored-significand-size))
+
+       (defmethod exponent-size ((type (eql ',type)))
+         ,exponent-size)
+
+       (defmethod sign-bytespec ((type (eql ',type)))
+         (byte ,sign-size ,(+ exponent-size stored-significand-size)))
+
+       (defmethod sign-byte-form ((type (eql ',type)))
+         '(byte ,sign-size ,(+ exponent-size stored-significand-size)))
+
+       (defmethod sign-size ((type (eql ',type)))
+         ,sign-size)
+
+       (defmethod nan-payload-bytespec ((type (eql ',type)))
+         (byte ,(1- stored-significand-size) 0))
+
+       (defmethod nan-payload-byte-form ((type (eql ',type)))
+         '(byte ,(1- stored-significand-size) 0))
+
+       (defmethod nan-type-bytespec ((type (eql ',type)))
+         (byte 1 ,(1- stored-significand-size)))
+
+       (defmethod nan-type-byte-form ((type (eql ',type)))
+         '(byte 1 ,(1- stored-significand-size)))
+
+       (defmethod hidden-bit-p ((type (eql ',type)))
+         ,hidden-bit-p)
+
+       (defmethod subnormalp ((type (eql ',type)))
+         ,subnormalp)
+
+       (defmethod non-number-p ((type (eql ',type)))
+         ,non-number-p)
+
+       (defmethod internal-base ((type (eql ',type)))
+         ,internal-base)
+
+       (defmethod exponent-bias ((type (eql ',type)))
+         ,exponent-bias)
+
+       (defmethod max-exponent ((type (eql ',type)))
+         ,max-exponent)
+
+       (defmethod min-exponent ((type (eql ',type)))
+         ,min-exponent)
+
+       (defmethod arithmetic-size ((type (eql ',type)))
+         ,(ash 1 (integer-length (+ 6 significand-size))))
+
+       (defmethod implementation-type ((type (eql ',type)))
+         ',implementation-type)
+
+       (defmethod exact-implementation-type-p ((type (eql ',type)))
+         ,exactp)
+
+       (defmethod external-type ((type (eql ',type)))
+         ',type)
+
+       ,@(when exactp
+           `((defmethod external-type ((type (eql ',implementation-type)))
+               ',type))))))
+
+(%external-traits :bfloat16 8 8)
+
+(%external-traits :binary16 5 11)
+
+(%external-traits :binary32 8 24)
+
+(%external-traits :binary64 11 53)
+
+(%external-traits :binary80 15 64)
+
+(%external-traits :binary128 15 113)
+
+(%external-traits :binary256 19 237)
+

code/float-bits-late.lisp

@@ -0,0 +1,30 @@
+(in-package #:quaviver)
+
+(defmacro %float-external (float-type value)
+  (let ((implementation-type (implementation-type float-type)))
+    (if (exact-implementation-type-p float-type)
+        `(%float-bits ,implementation-type (coerce ,value ',implementation-type))
+        `(multiple-value-bind (significand exponent sign)
+             ,(float-primitive-triple-form implementation-type `(coerce ,value ',implementation-type))
+           ,(primitive-triple-bits-form float-type 'significand 'exponent 'sign)))))
+
+(defmethod float-bits ((float-type (eql :bfloat16)) value)
+  (%float-external :bfloat16 value))
+
+(defmethod float-bits ((float-type (eql :binary16)) value)
+  (%float-external :binary16 value))
+
+(defmethod float-bits ((float-type (eql :binary32)) value)
+  (%float-external :binary32 value))
+
+(defmethod float-bits ((float-type (eql :binary64)) value)
+  (%float-external :binary64 value))
+
+(defmethod float-bits ((float-type (eql :binary80)) value)
+  (%float-external :binary80 value))
+
+(defmethod float-bits ((float-type (eql :binary128)) value)
+  (%float-external :binary128 value))
+
+(defmethod float-bits ((float-type (eql :binary256)) value)
+  (%float-external :binary256 value))

code/float-bits.lisp

@@ -3,34 +3,25 @@
 (defmacro %float-bits (float-type value)
   (float-bits-form float-type value))
 
-#+clisp
-(defmethod float-bits (value)
-  (typecase value
-    #+quaviver/short-float
-    (short-float
-     (%float-bits short-float value))
-    (single-float
-     (%float-bits single-float value))
-    (double-float
-     (%float-bits double-float value))
-    #+quaviver/long-float
-    (long-float
-     (%float-bits long-float value))
-    (otherwise
-     (call-next-method))))
-
-#+(and (not clisp) quaviver/short-float)
-(defmethod float-bits ((value short-float))
-  (%float-bits short-float value))
-
-#-clisp
-(defmethod float-bits ((value single-float))
-  (%float-bits single-float value))
-
-#-clisp
-(defmethod float-bits ((value double-float))
-  (%float-bits double-float value))
-
-#+(and (not clisp) quaviver/long-float)
-(defmethod float-bits ((value long-float))
-  (%float-bits long-float value))
+#+quaviver/short-float
+(defmethod float-bits ((float-type (eql 'short-float)) value)
+  (%float-bits short-float (coerce value 'short-float)))
+
+#-quaviver/short-float
+(defmethod float-bits ((float-type (eql 'short-float)) value)
+  (%float-bits single-float (coerce value 'single-float)))
+
+(defmethod float-bits ((float-type (eql 'single-float)) value)
+  (%float-bits single-float (coerce value 'single-float)))
+
+(defmethod float-bits ((float-type (eql 'double-float)) value)
+  (%float-bits double-float (coerce value 'double-float)))
+
+#+quaviver/long-float
+(defmethod float-bits ((float-type (eql 'long-float)) value)
+  (%float-bits long-float (coerce value 'long-float)))
+
+#-quaviver/long-float
+(defmethod float-bits ((float-type (eql 'long-float)) value)
+  (%float-bits double-float (coerce value 'double-float)))
+

code/interface.lisp

@@ -4,9 +4,9 @@
 
 (defgeneric bits-float-form (float-type bits))
 
-(defgeneric float-bits (value))
+(defgeneric float-bits (float-type value))
 
-(defgeneric float-bits-form (type value))
+(defgeneric float-bits-form (float-type value))
 
 (defgeneric triple-float (client float-type base significand exponent sign))
 
@@ -16,6 +16,14 @@
 
 (defgeneric float-primitive-triple-form (float-type value))
 
+(defgeneric bits-primitive-triple-form (float-type value))
+
+(defgeneric bits-primitive-triple (float-type value))
+
+(defgeneric primitive-triple-bits-form (float-type significand exponent sign))
+
+(defgeneric primitive-triple-bits (float-type significand exponent sign))
+
 (defgeneric parse-number (client base sequence
                           &optional start end integerp ratiop floatp float-type))
 
@@ -95,6 +103,39 @@
 
 (defgeneric arithmetic-size (type))
 
+(defgeneric implementation-type (type)
+  (:method ((type (eql 'short-float)))
+    #+quaviver/short-float 'short-float
+    #-quaviver/short-float 'single-float)
+  (:method ((type (eql 'single-float)))
+    'single-float)
+  (:method ((type (eql 'double-float)))
+    'double-float)
+  (:method ((type (eql 'long-float)))
+    #+quaviver/long-float 'long-float
+    #-quaviver/long-float 'double-float))
+
+(defgeneric exact-implementation-type-p (type)
+  (:method ((type (eql 'short-float)))
+    t)
+  (:method ((type (eql 'single-float)))
+    t)
+  (:method ((type (eql 'double-float)))
+    t)
+  (:method ((type (eql 'long-float)))
+    t))
+
+(defgeneric external-type (type)
+  (:method (type)
+    (declare (ignore type))
+     nil)
+  #-quaviver/short-float
+  (:method ((type (eql 'short-float)))
+    (external-type 'single-float))
+  #-quaviver/long-float
+  (:method ((type (eql 'long-float)))
+    (external-type 'long-float)))
+
 (deftype significand-word (type &optional (extra 0))
   `(unsigned-byte ,(+ (significand-size type) extra)))