common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix double-float-from-core - skip the padding slot

Browse source
This commit is contained in:
Douglas Katzman 2019-04-07 19:27:05 -04:00
parent 173f34c51b
commit dbd8ee85cf
4 changed files with 53 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
float-math.lisp-expr
View file

@ -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)

36
src/code/early-float.lisp
View file

@ -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 <LOW> <HIGH>))
;;; 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)))

46
src/compiler/float-tran.lisp
View file

@ -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 <LOW> <HIGH>))
;;; 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)))

6
src/compiler/generic/genesis.lisp
View file

@ -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))))))