1 ;;;; portable implementations or stubs for nonportable floating point
2 ;;;; things, useful for building Python as a cross-compiler when
3 ;;;; running under an ordinary ANSI Common Lisp implementation
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!IMPL")
16 ;;; There seems to be no portable way to mask float traps, but we
17 ;;; shouldn't encounter any float traps when cross-compiling SBCL
18 ;;; itself, anyway, so we just make this a no-op.
19 (defmacro sb!vm::with-float-traps-masked (traps &body body)
20 (declare (ignore traps))
21 ;; FIXME: should become STYLE-WARNING?
22 (format *error-output*
23 "~&(can't portably mask float traps, proceeding anyway)~%")
26 ;;; a helper function for DOUBLE-FLOAT-FOO-BITS functions
28 ;;; Return the low N bits of X as a signed N-bit value.
29 (defun mask-and-sign-extend (x n)
31 (let* ((high-bit (ash 1 (1- n)))
32 (mask (1- (ash high-bit 1)))
33 (uresult (logand mask x)))
34 (if (zerop (logand uresult high-bit))
37 (logand -1 (lognot mask))))))
39 ;;; portable implementations of SINGLE-FLOAT-BITS,
40 ;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS
42 ;;; KLUDGE: These will fail if the target's floating point isn't IEEE,
43 ;;; and so I'd be more comfortable if there were an assertion
44 ;;; "target's floating point is IEEE" in the code, but I can't see how
47 ;;; KLUDGE: It's sort of weird that these functions return signed
48 ;;; 32-bit values instead of unsigned 32-bit values. This is the way
49 ;;; that the CMU CL machine-dependent functions behaved, and I've
50 ;;; copied that behavior, but it seems to me that it'd be more
51 ;;; idiomatic to return unsigned 32-bit values. Maybe someday the
52 ;;; machine-dependent functions could be tweaked to return unsigned
54 (defun single-float-bits (x)
55 (declare (type single-float x))
56 (assert (= (float-radix x) 2))
58 0 ; known property of IEEE floating point: 0.0 is represented as 0.
59 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
60 (integer-decode-float x)
61 (assert (plusp lisp-significand))
62 ;; Calculate IEEE-style fields from Common-Lisp-style fields.
64 ;; KLUDGE: This code was written from my foggy memory of what IEEE
65 ;; format looks like, augmented by some experiments with
66 ;; the existing implementation of SINGLE-FLOAT-BITS, and what
67 ;; I found floating around on the net at
68 ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
69 ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
71 ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
72 ;; And beyond the probable sheer flakiness of the code, all the bare
73 ;; numbers floating around here are sort of ugly, too. -- WHN 19990711
74 (let* ((significand lisp-significand)
75 (exponent (+ lisp-exponent 23 127))
77 (if (plusp exponent) ; if not obviously denormalized
80 (cond (;; ordinary termination case
81 (>= significand (expt 2 23))
82 (assert (< 0 significand (expt 2 24)))
83 ;; Exponent 0 is reserved for
84 ;; denormalized numbers, and 255 is
85 ;; reserved for specials like NaN.
86 (assert (< 0 exponent 255))
87 (return (logior (ash exponent 23)
90 (;; special termination case, denormalized
93 ;; Denormalized numbers have exponent one
94 ;; greater than the exponent field.
95 (return (ash significand -1)))
97 ;; Shift as necessary to set bit 24 of
99 (setf significand (ash significand 1)
100 exponent (1- exponent)))))
103 ;; Denormalized numbers have exponent one
104 ;; greater than the exponent field.
105 (ash significand -1))
106 (unless (zerop (logand significand 1))
107 (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits"
109 (setf significand (ash significand -1)
110 exponent (1+ exponent))))))
113 (-1 (logior unsigned-result (- (expt 2 31)))))))))
114 (defun double-float-bits (x)
115 (declare (type double-float x))
116 (assert (= (float-radix x) 2))
118 0 ; known property of IEEE floating point: 0.0d0 is represented as 0.
119 ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above.
120 (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
121 (integer-decode-float x)
122 (assert (plusp lisp-significand))
123 (let* ((significand lisp-significand)
124 (exponent (+ lisp-exponent 52 1023))
126 (if (plusp exponent) ; if not obviously denormalized
129 (cond (;; ordinary termination case
130 (>= significand (expt 2 52))
131 (assert (< 0 significand (expt 2 53)))
132 ;; Exponent 0 is reserved for
133 ;; denormalized numbers, and 2047 is
134 ;; reserved for specials like NaN.
135 (assert (< 0 exponent 2047))
136 (return (logior (ash exponent 52)
139 (;; special termination case, denormalized
142 ;; Denormalized numbers have exponent one
143 ;; greater than the exponent field.
144 (return (ash significand -1)))
146 ;; Shift as necessary to set bit 53 of
148 (setf significand (ash significand 1)
149 exponent (1- exponent)))))
152 ;; Denormalized numbers have exponent one
153 ;; greater than the exponent field.
154 (ash significand -1))
155 (unless (zerop (logand significand 1))
156 (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits"
158 (setf significand (ash significand -1)
159 exponent (1+ exponent))))))
162 (-1 (logior unsigned-result (- (expt 2 63)))))))))
163 (defun double-float-low-bits (x)
164 (declare (type double-float x))
167 ;; FIXME: Unlike DOUBLE-FLOAT-HIGH-BITS or SINGLE-FLOAT-BITS,
168 ;; the CMU CL DOUBLE-FLOAT-LOW-BITS seemed to return a unsigned
169 ;; value, not a signed value, so we've done the same. But it
170 ;; would be nice to make the family of functions have a more
171 ;; consistent return convention.
172 (logand #xffffffff (double-float-bits x))))
173 (defun double-float-high-bits (x)
174 (declare (type double-float x))
177 (mask-and-sign-extend (ash (double-float-bits x) -32) 32)))
179 ;;; KLUDGE: This is a hack to work around a bug in CMU CL 18c which
180 ;;; causes the 18c compiler to die with a floating point exception
181 ;;; when trying to optimize the EXPT forms in the MAKE-FOO-FLOAT
182 ;;; functions below. See the message
183 ;;; Subject: Re: Compiler bug?
184 ;;; From: Raymond Toy <toy@rtp.ericsson.se>
185 ;;; Date: 28 Mar 2001 08:19:59 -0500
186 ;;; Message-ID: <4nvgou3u9s.fsf@rtp.ericsson.se>
187 ;;; on the cmucl-imp@cons.org mailing list. Once the CMU CL folks
188 ;;; make a bug-fix release, we can get rid of this and go back to
189 ;;; calling EXPT directly. -- WHN 2001-04-05
190 (defun kludge-opaque-expt (x y)
193 ;;; KLUDGE: These functions will blow up on any cross-compilation
194 ;;; host Lisp which has less floating point precision than the target
195 ;;; Lisp. In practice, this may not be a major problem: IEEE
196 ;;; floating point arithmetic is so common these days that most
197 ;;; cross-compilation host Lisps are likely to have exactly the same
198 ;;; floating point precision as the target Lisp. If it turns out to be
199 ;;; a problem, there are possible workarounds involving portable
200 ;;; representations for target floating point numbers, like
201 ;;; (DEFSTRUCT TARGET-SINGLE-FLOAT
202 ;;; (SIGN (MISSING-ARG) :TYPE BIT)
203 ;;; (EXPONENT (MISSING-ARG) :TYPE UNSIGNED-BYTE)
204 ;;; (MANTISSA (MISSING-ARG) :TYPE UNSIGNED-BYTE))
205 ;;; with some sort of MAKE-LOAD-FORM-ish magic to cause them to be
206 ;;; written out in the appropriate target format. (And yes, those
207 ;;; workarounds *do* look messy to me, which is why I just went
208 ;;; with this quick kludge instead.) -- WHN 19990711
209 (defun make-single-float (bits)
210 (if (zerop bits) ; IEEE float special case
212 (let ((sign (ecase (ldb (byte 1 31) bits)
215 (expt (- (ldb (byte 8 23) bits) 127))
216 (mant (* (logior (ldb (byte 23 0) bits)
219 (* sign (kludge-opaque-expt 2.0 expt) mant))))
220 (defun make-double-float (hi lo)
221 (if (and (zerop hi) (zerop lo)) ; IEEE float special case
223 (let* ((bits (logior (ash hi 32) lo))
224 (sign (ecase (ldb (byte 1 63) bits)
227 (expt (- (ldb (byte 11 52) bits) 1023))
228 (mant (* (logior (ldb (byte 52 0) bits)
231 (* sign (kludge-opaque-expt 2.0d0 expt) mant))))