;;;; portable implementations or stubs for nonportable floating point ;;;; things, useful for building Python as a cross-compiler when ;;;; running under an ordinary ANSI Common Lisp implementation ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!IMPL") ;;; There seems to be no portable way to mask float traps, but we shouldn't ;;; encounter any float traps when cross-compiling SBCL itself, anyway, so we ;;; just make this a no-op. (defmacro sb!vm::with-float-traps-masked (traps &body body) (declare (ignore traps)) ;; FIXME: should become STYLE-WARNING? (format *error-output* "~&(can't portably mask float traps, proceeding anyway)~%") `(progn ,@body)) ;;; a helper function for DOUBLE-FLOAT-FOO-BITS functions ;;; ;;; Return the low N bits of X as a signed N-bit value. (defun mask-and-sign-extend (x n) (assert (plusp n)) (let* ((high-bit (ash 1 (1- n))) (mask (1- (ash high-bit 1))) (uresult (logand mask x))) (if (zerop (logand uresult high-bit)) uresult (logior uresult (logand -1 (lognot mask)))))) ;;; portable implementations of SINGLE-FLOAT-BITS, DOUBLE-FLOAT-LOW-BITS, and ;;; DOUBLE-FLOAT-HIGH-BITS ;;; ;;; KLUDGE: These will fail if the target's floating point isn't IEEE, and so ;;; I'd be more comfortable if there were an assertion "target's floating point ;;; is IEEE" in the code, but I can't see how to express that. ;;; ;;; KLUDGE: It's sort of weird that these functions return signed 32-bit values ;;; instead of unsigned 32-bit values. This is the way that the CMU CL ;;; machine-dependent functions behaved, and I've copied that behavior, but it ;;; seems to me that it'd be more idiomatic to return unsigned 32-bit values. ;;; Maybe someday the machine-dependent functions could be tweaked to return ;;; unsigned 32-bit values? (defun single-float-bits (x) (declare (type single-float x)) (assert (= (float-radix x) 2)) (if (zerop x) 0 ; known property of IEEE floating point: 0.0 is represented as 0. (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) (assert (plusp lisp-significand)) ;; Calculate IEEE-style fields from Common-Lisp-style fields. ;; ;; KLUDGE: This code was written from my foggy memory of what IEEE ;; format looks like, augmented by some experiments with ;; the existing implementation of SINGLE-FLOAT-BITS, and what ;; I found floating around on the net at ;; , ;; , ;; and ;; . ;; And beyond the probable sheer flakiness of the code, all the bare ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 (let* ((significand lisp-significand) (exponent (+ lisp-exponent 23 127)) (unsigned-result (if (plusp exponent) ; if not obviously denormalized (do () (nil) (cond (;; ordinary termination case (>= significand (expt 2 23)) (assert (< 0 significand (expt 2 24))) ;; Exponent 0 is reserved for denormalized numbers, ;; and 255 is reserved for specials a la NaN. (assert (< 0 exponent 255)) (return (logior (ash exponent 23) (logand significand (1- (ash 1 23)))))) (;; special termination case, denormalized float number (zerop exponent) ;; Denormalized numbers have exponent one greater than ;; the exponent field. (return (ash significand -1))) (t ;; Shift as necessary to set bit 24 of significand. (setf significand (ash significand 1) exponent (1- exponent))))) (do () ((zerop exponent) ;; Denormalized numbers have exponent one greater than the ;; exponent field. (ash significand -1)) (unless (zerop (logand significand 1)) (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x)) (setf significand (ash significand -1) exponent (1+ exponent)))))) (ecase lisp-sign (1 unsigned-result) (-1 (logior unsigned-result (- (expt 2 31))))))))) (defun double-float-bits (x) (declare (type double-float x)) (assert (= (float-radix x) 2)) (if (zerop x) 0 ; known property of IEEE floating point: 0.0d0 is represented as 0. ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above. (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) (integer-decode-float x) (assert (plusp lisp-significand)) (let* ((significand lisp-significand) (exponent (+ lisp-exponent 52 1023)) (unsigned-result (if (plusp exponent) ; if not obviously denormalized (do () (nil) (cond (;; ordinary termination case (>= significand (expt 2 52)) (assert (< 0 significand (expt 2 53))) ;; Exponent 0 is reserved for denormalized numbers, ;; and 2047 is reserved for specials a la NaN. (assert (< 0 exponent 2047)) (return (logior (ash exponent 52) (logand significand (1- (ash 1 52)))))) (;; special termination case, denormalized float number (zerop exponent) ;; Denormalized numbers have exponent one greater than ;; the exponent field. (return (ash significand -1))) (t ;; Shift as necessary to set bit 53 of significand. (setf significand (ash significand 1) exponent (1- exponent))))) (do () ((zerop exponent) ;; Denormalized numbers have exponent one greater than the ;; exponent field. (ash significand -1)) (unless (zerop (logand significand 1)) (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x)) (setf significand (ash significand -1) exponent (1+ exponent)))))) (ecase lisp-sign (1 unsigned-result) (-1 (logior unsigned-result (- (expt 2 63))))))))) (defun double-float-low-bits (x) (declare (type double-float x)) (if (zerop x) 0 ;; Unlike DOUBLE-FLOAT-HIGH-BITS or SINGLE-FLOAT-BITS, the CMU CL ;; DOUBLE-FLOAT-LOW-BITS seems to return a unsigned value, not a signed ;; value. (logand #xffffffff (double-float-bits x)))) (defun double-float-high-bits (x) (declare (type double-float x)) (if (zerop x) 0 (mask-and-sign-extend (ash (double-float-bits x) -32) 32))) ;;; KLUDGE: These functions will blow up on any cross-compilation ;;; host Lisp which has less floating point precision than the target ;;; Lisp. In practice, this may not be a major problem: IEEE ;;; floating point arithmetic is so common these days that most ;;; cross-compilation host Lisps are likely to have exactly the same ;;; floating point precision as the target Lisp. If it turns out to be ;;; a problem, there are possible workarounds involving portable ;;; representations for target floating point numbers, a la ;;; (DEFSTRUCT TARGET-SINGLE-FLOAT ;;; (SIGN (REQUIRED-ARGUMENT) :TYPE BIT) ;;; (EXPONENT (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE) ;;; (MANTISSA (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE)) ;;; with some sort of MAKE-LOAD-FORM-ish magic to cause them to be ;;; written out in the appropriate target format. (And yes, those ;;; workarounds *do* look messy to me, which is why I just went ;;; with this quick kludge instead.) -- WHN 19990711 (defun make-single-float (bits) (if (zerop bits) ; IEEE float special case 0.0 (let ((sign (ecase (ldb (byte 1 31) bits) (0 1.0) (1 -1.0))) (expt (- (ldb (byte 8 23) bits) 127)) (mant (* (logior (ldb (byte 23 0) bits) (ash 1 23)) (expt 0.5 23)))) (* sign (expt 2.0 expt) mant)))) (defun make-double-float (hi lo) (if (and (zerop hi) (zerop lo)) ; IEEE float special case 0.0d0 (let* ((bits (logior (ash hi 32) lo)) (sign (ecase (ldb (byte 1 63) bits) (0 1.0d0) (1 -1.0d0))) (expt (- (ldb (byte 11 52) bits) 1023)) (mant (* (logior (ldb (byte 52 0) bits) (ash 1 52)) (expt 0.5d0 52)))) (* sign (expt 2.0d0 expt) mant))))