From dbd8ee85cfa277b8857460f4cf7c7afdff62745b Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sun, 7 Apr 2019 19:27:05 -0400 Subject: [PATCH] Fix double-float-from-core - skip the padding slot --- float-math.lisp-expr | 3 ++ src/code/early-float.lisp | 36 ------------------------ src/compiler/float-tran.lisp | 46 +++++++++++++++++++++++++++++++ src/compiler/generic/genesis.lisp | 6 ++-- 4 files changed, 53 insertions(+), 38 deletions(-) diff --git a/float-math.lisp-expr b/float-math.lisp-expr index 58d8c7f90..a2510d2d2 100644 --- a/float-math.lisp-expr +++ b/float-math.lisp-expr @@ -130,6 +130,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x40080000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3FF6DE05 #x54442D18)) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) T) @@ -227,6 +228,7 @@ (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) T) (= (#.(MAKE-DOUBLE-FLOAT #x4310624D #xD2F1A9F8) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x0 #x0 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) @@ -466,6 +468,7 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x40080000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3FF6DE05 #x54442D18)) T) +(>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x40000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) T) diff --git a/src/code/early-float.lisp b/src/code/early-float.lisp index 04908b1b0..d2a6bf64a 100644 --- a/src/code/early-float.lisp +++ b/src/code/early-float.lisp @@ -165,39 +165,3 @@ (defconstant most-negative-fixnum-double-float (double-from-bits 1 (+ sb-vm:n-fixnum-bits sb-vm:double-float-bias) 0)) - -;;; Dummy functions to test that complex number are dumped correctly in genesis. -(defun try-folding-complex-single () - (let ((re (make-single-float #x4E000000)) - (im (make-single-float #x-21800000))) - (values (complex re im) - (locally (declare (notinline complex)) (complex re im))))) - -(defun try-folding-complex-double () - (let ((re (make-double-float #X3FE62E42 #xFEFA39EF)) - (im (make-double-float #X43CFFFFF #XFFFFFFFF))) - (values (complex re im) - (locally (declare (notinline complex)) (complex re im))))) - -#-sb-xc-host -(dolist (test '(try-folding-complex-single try-folding-complex-double)) - (multiple-value-bind (a b) (funcall test) - (assert (eql a b))) - (let ((code (fun-code-header (symbol-function test)))) - (declare (notinline code-header-words)) ; forward ref - ;; KLUDGE: code-constants-offset is also not defined yet - ;; but is accessible from make-host-1's definition. - (aver (loop for index from #.sb-vm:code-constants-offset - below (code-header-words code) - thereis (typep (code-header-ref code index) 'complex)))) - (fmakunbound test)) - -;;; An example that we can't cross-compile: CTYPE-OF-NUMBER tries to compute -;;; low/high bounds so that it can return (COMPLEX (SINGLE-FLOAT )) -;;; but we haven't taught the MIN,MAX interceptors how to operate on infinity. -#+nil -(defun more-folding () - (values (complex single-float-positive-infinity single-float-positive-infinity) - (complex single-float-negative-infinity single-float-positive-infinity) - (complex single-float-negative-infinity single-float-negative-infinity) - (complex single-float-positive-infinity single-float-negative-infinity))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 0eea52fc7..576799e49 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -1642,3 +1642,49 @@ '(,fun x)))) (def single-float %unary-ftruncate/single) (def double-float %unary-ftruncate/double)) + +;;;; TESTS + +;;; Dumping of double-float literals in genesis got some bits messed up, +;;; but only if the double-float was the value of a slot in a ctype instance. +;;; It was broken for either endianness, but miraculously didn't crash +;;; for little-endian builds even though it could have. +;;; (The dumped constants were legal normalalized float bit patterns, albeit wrong) +;;; For 32-bit big-endian machines, the bit patterns were those of subnormals. +;;; So thank goodness for that - it allowed detection of the problem. +(defun test-ctype-involving-double-float () + (specifier-type '(double-float #.sb-xc:pi))) +(assert (sb-xc:= (numeric-type-low (test-ctype-involving-double-float)) sb-xc:pi)) + +;;; Dummy functions to test that complex number are dumped correctly in genesis. +(defun try-folding-complex-single () + (let ((re (make-single-float #x4E000000)) + (im (make-single-float #x-21800000))) + (values (complex re im) + (locally (declare (notinline complex)) (complex re im))))) + +(defun try-folding-complex-double () + (let ((re (make-double-float #X3FE62E42 #xFEFA39EF)) + (im (make-double-float #X43CFFFFF #XFFFFFFFF))) + (values (complex re im) + (locally (declare (notinline complex)) (complex re im))))) + +#-sb-xc-host +(dolist (test '(try-folding-complex-single try-folding-complex-double)) + (multiple-value-bind (a b) (funcall test) + (assert (eql a b))) + (let ((code (fun-code-header (symbol-function test)))) + (aver (loop for index from sb-vm:code-constants-offset + below (code-header-words code) + thereis (typep (code-header-ref code index) 'complex)))) + (fmakunbound test)) + +;;; An example that we can't cross-compile: CTYPE-OF-NUMBER tries to compute +;;; low/high bounds so that it can return (COMPLEX (SINGLE-FLOAT )) +;;; but we haven't taught the MIN,MAX interceptors how to operate on infinity. +#+nil +(defun more-folding () + (values (complex single-float-positive-infinity single-float-positive-infinity) + (complex single-float-negative-infinity single-float-positive-infinity) + (complex single-float-negative-infinity single-float-negative-infinity) + (complex single-float-positive-infinity single-float-negative-infinity))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 380492dff..888f386bb 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -817,8 +817,10 @@ core and return a descriptor to it." (defun double-float-from-core (des) (let ((bits #+64-bit (read-bits-wordindexed des 1) - #-64-bit (let* ((word0 (read-bits-wordindexed des 1)) - (word1 (read-bits-wordindexed des 2))) + #-64-bit (let* ((word0 (read-bits-wordindexed + des sb-vm:double-float-value-slot)) + (word1 (read-bits-wordindexed + des (1+ sb-vm:double-float-value-slot)))) (ecase sb-c:*backend-byte-order* (:little-endian (logior (ash word1 32) word0)) (:big-endian (logior (ash word0 32) word1))))))