source: branches/ia32/level-0/X86/X8632/x8632-float.lisp @ 7985

Last change on this file since 7985 was 7985, checked in by rme, 12 years ago

Forgot (single-value-return) in a couple of places; correct other
minor errors.

File size: 17.6 KB
Line 
1(in-package "CCL")
2
3(eval-when (:compile-toplevel :execute)
4  (require "NUMBER-MACROS")
5  (require "NUMBER-CASE-MACRO"))
6
7;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit)
8;;;                   lo -  low 28 bits mantissa
9;;;                   exp  - take low 11 bits
10;;;                   sign - sign(sign) => result
11;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg
12;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg
13;;; no error checks, no tweaks, no nuthin
14
15;;; sign is -1, 1, maybe zero
16
17(defx8632lapfunction %make-float-from-fixnums ((dfloat 12) (hi 8) (lo 4) #|(ra 0)|# (exp arg_y) (sign arg_z))
18  (mov (% sign) (% imm0))
19  (movl (@ dfloat (% esp)) (% arg_z))
20  (sar ($ 31) (% imm0))
21  (shl ($ 31) (% imm0))                 ;insert sign
22  (shl ($ (- 20 x8632::fixnumshift)) (% exp))
23  (orl (% exp) (% imm0))                ;insert biased exponent
24  (movl (% imm0) (@ x8632::double-float.val-high (% arg_z)))
25  (movl (@ hi (% esp)) (% arg_y))
26  (andl ($ (ash (1- (ash 1 24)) x8632::fixnumshift)) (% arg_y))
27  (movl (% arg_y) (% imm0))
28  (shrl ($ (+ 4 x8632::fixnumshift)) (% imm0))              ;top 20 bits of hi
29  (orl (% imm0) (@ x8632::double-float.val-high (% arg_z))) ; into high word
30  ;; do low half
31  (movl (@ lo (% esp)) (% imm0))
32  (sar ($ x8632::fixnumshift) (% imm0))
33  (andl ($ (1- (ash 1 28))) (% imm0))
34  (shl ($ (- 28 x8632::fixnumshift)) (% arg_y)) ;position low 4 bits of hi
35  (orl (% arg_y) (% imm0))
36  (movl (% imm0) (@ x8632::double-float.value (% arg_z)))
37  (single-value-return 5))
38
39(defx8632lapfunction %make-short-float-from-fixnums ((sfloat 8) (significand 4) #|(ra 0)|# (biased-exp arg_y) (sign arg_z))
40  (movl (% sign) (% imm0))
41  (movl (@ sfloat (% esp)) (% arg_z))
42  (sarl ($ 31) (% imm0))
43  (shll ($ 31) (% imm0))                ;insert sign
44  (shll ($ (- ieee-single-float-exponent-offset x8632::fixnumshift)) (% biased-exp))
45  (or (% biased-exp) (% imm0))          ;insert biased exponent
46  (movl (% imm0) (@ x8632::single-float.value (% arg_z)))
47  (movl (@ significand (% esp)) (% imm0))
48  (sar ($ x8632::fixnumshift) (% imm0))
49  (andl ($ (1- (ash 1 ieee-single-float-hidden-bit))) (% imm0))
50  (or (% imm0) (@ x8632::single-float.value (% arg_z)))
51  (single-value-return 4))
52
53;;; Maybe we should trap - or something - on NaNs.
54(defx8632lapfunction %%double-float-abs! ((n arg_y) (val arg_z))
55  (get-double-float n fp1)
56  (put-double-float fp1 val)
57  (btrl ($ 31) (@ x8632::double-float.val-high (% val)))
58  (single-value-return))
59
60(defx8632lapfunction %%short-float-abs! ((n arg_y) (val arg_z))
61  (movl (@ x8632::single-float.value (% n)) (% imm0))
62  (btr ($ 31) (% imm0))
63  (movl (% imm0) (@ x8632::single-float.value (% val)))
64  (single-value-return))
65
66(defx8632lapfunction %double-float-negate! ((src arg_y) (res arg_z))
67  (get-double-float src fp1)
68  (put-double-float fp1 res)
69  (btcl ($ 31) (@ x8632::double-float.val-high (% res)))
70  (single-value-return))
71
72(defx8632lapfunction %short-float-negate! ((src arg_y) (res arg_z))
73  (movl (@ x8632::single-float.value (% src)) (% imm0))
74  (btcl ($ 31) (% imm0))
75  (movl (% imm0) (@ x8632::single-float.value (% res)))
76  (single-value-return))
77
78;;; return hi (25 bits) lo (28 bits) exp sign
79(defx8632lapfunction %integer-decode-double-float ((n arg_z))
80  (mark-as-imm temp0)
81  (let ((imm1 temp0)
82        (sign 0)
83        (exp 4)
84        (lo 8)
85        (hi 12))
86    (pushl ($ 0))                       ;hi
87    (pushl ($ 0))                       ;lo
88    (pushl ($ 0))                       ;exp
89    (pushl ($ 0))                       ;sign
90
91    (movl (@ x8632::double-float.val-high (% n)) (% imm1))
92    (movl (% imm1) (% imm0))
93    (sarl ($ 31) (% imm0))              ;propagate sign
94    (shll ($ 31) (% imm0))
95    (box-fixnum imm0 arg_y)
96    (movl (% arg_y) (@ sign (% esp)))
97
98    (movl (% imm1) (% imm0))
99    (andl ($ #x7ff00000) (% imm0))      ;exponent
100    (shll ($ (- 20 x8632::fixnumshift)) (% imm0))
101    (movl (% imm0) (@ exp (% esp)))
102
103    (movl (@ x8632::double-float.value (% n)) (% imm0))
104    (andl ($ #x000fffff) (% imm1))      ;high 20 bits of fraction
105    (shldl ($ 4) (% imm0) (% imm1))     ;shift in 4 bits from low word
106    (testl ($ 0) (@ exp (% esp)))
107    (jz @denorm)
108    (or ($ (ash 1 (- ieee-double-float-hidden-bit 32))) (% imm1))
109    @denorm
110    (box-fixnum imm1 arg_y)
111    (movl (% arg_y) (@ hi (% esp)))
112
113    (shll ($ 4) (% imm0))               ;shift out bits included in hi
114    (shrl ($ (- 4 x8632::fixnumshift)) (% imm0)) ;and box 28 low bits
115    (movl (% imm0) (@ lo (% esp))))
116  (mark-as-node temp0)
117  (set-nargs 4)
118  (leal (@ '4 (% esp)) (% temp0))
119  (jmp-subprim .SPvalues))
120
121;;; hi is 25 bits lo is 28 bits
122;;; big is 32 lo, 21 hi right justified
123(defx8632lapfunction make-big-53 ((hi 4) #|(ra 0)|# (lo arg_y) (big arg_z))
124  (mark-as-imm temp0)
125  (let ((imm1 temp0))
126    (movl (@ hi (% esp)) (% temp1))
127    (movl (% temp1) (% imm0))
128    (shll ($ (- 28 x8632::fixnumshift)) (% imm0))
129    (unbox-fixnum lo imm1)
130    (orl (% imm0) (% imm1))
131    (movl (% imm1) (@ x8632::misc-data-offset (% big))) ;low 32 bits
132    (movl (% temp1) (% imm0))
133    (sarl ($ (+ 4 x8632::fixnumshift)) (% imm0))
134    (movl (% imm0) (@ (+ 4 x8632::misc-data-offset) (% big)))) ;high 21 bits
135  (mark-as-node temp0)
136  (single-value-return 3))
137
138;;; dfloat must be non-zero
139(defx8632lapfunction dfloat-significand-zeros ((dfloat arg_z))
140  (mark-as-imm temp0)
141  (let ((imm1 temp0))
142    (movl (@ x8632::double-float.value (% dfloat)) (% imm0))
143    (movl (@ x8632::double-float.val-high (% dfloat)) (% imm1))
144    ;; shift imm1 left by count, shifting bits from imm0 in from the right
145    (shldl ($ (1+ ieee-double-float-exponent-width)) (% imm0) (% imm1))
146    (testl (% imm1) (% imm1))
147    (jz @low)
148    (bsrl (% imm1) (% imm0))
149    (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
150    (jmp @done)
151    @low
152    (bsrl (% imm0) (% imm0))
153    (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
154    ;; if we're here, the upper part of the fraction was all zeros,
155    ;; so add the count for those in.
156    (add ($ (- ieee-double-float-mantissa-width 32)) (% imm0))
157    @done
158    (box-fixnum imm0 arg_z))
159  (mark-as-node temp0)
160  (single-value-return))
161
162;;; sfloat must be non-zero
163(defx8632lapfunction sfloat-significand-zeros ((sfloat arg_z))
164  (movl (@ x8632::single-float.value (% sfloat)) (% imm0))
165  (shl ($ (1+ IEEE-single-float-exponent-width)) (% imm0))
166  (bsrl (% imm0) (% imm0))
167  (xorl ($ (1- x8632::nbits-in-word)) (% imm0))
168  (box-fixnum imm0 arg_z)
169  (single-value-return))
170
171(defx8632lapfunction %%scale-dfloat! ((dfloat 4) #|(ra 0)|# (int arg_y) (result arg_z))
172  (unbox-fixnum int imm0)
173  (movl (@ dfloat (% esp)) (% temp0))
174  (get-double-float temp0 fp1)
175  (shl ($ (- ieee-double-float-exponent-offset 32)) (% imm0))
176  (movl ($ 0) (@ x8632::double-float.value (% result)))
177  (movl (% imm0) (@ x8632::double-float.val-high (% result)))
178  (get-double-float result fp2)
179  (mulsd (% fp2) (% fp1))
180  (put-double-float fp1 result)
181  (single-value-return 3))
182
183(defx8632lapfunction %%scale-sfloat! ((sfloat 4) #|(ra 0)|# (int arg_y) (result arg_z))
184  (unbox-fixnum int imm0)
185  (movl (@ sfloat (% esp)) (% temp0))
186  (get-single-float temp0 fp1)
187  (shl ($ ieee-single-float-exponent-offset) (% imm0))
188  (movd (% imm0) (% fp2))
189  (mulss (% fp2) (% fp1))
190  (put-single-float fp1 arg_z)
191  (single-value-return 3))
192
193(defx8632lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
194  (get-double-float f1 fp1)
195  (put-double-float fp1 f2)
196  (single-value-return))
197
198(defx8632lapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
199  (get-single-float f1 fp1)
200  (put-single-float fp1 f2)
201  (single-value-return))
202
203(defx8632lapfunction %double-float-exp ((n arg_z))
204  (movl (@ x8632::double-float.val-high (% n)) (% imm0))
205  (shll ($ 1) (% imm0))
206  (shrl ($ (1+ (- ieee-double-float-exponent-offset 32))) (% imm0))
207  (box-fixnum imm0 arg_z)
208  (single-value-return))
209
210(defx8632lapfunction set-%double-float-exp ((dfloat arg_y) (exp arg_z))
211  (movl (% exp) (% temp0))
212  (shll ($ (1+ (- 20 x8632::fixnumshift))) (% temp0))
213  (shrl ($ 1) (% temp0))
214  (movl (@ x8632::double-float.val-high (% dfloat)) (% imm0))
215  (andl ($ #x800fffff) (% imm0))
216  (orl (% temp0) (% imm0))
217  (movl (% imm0) (@ x8632::double-float.val-high (% dfloat)))
218  (single-value-return))
219
220(defx8632lapfunction %short-float-exp ((n arg_z))
221  (movl (@ x8632::single-float.value (% n)) (% imm0))
222  (shll ($ 1) (% imm0))
223  (shrl ($ (1+ ieee-single-float-exponent-offset)) (% imm0))
224  (box-fixnum imm0 arg_z)
225  (single-value-return))
226
227(defx8632lapfunction set-%short-float-exp ((sfloat arg_y) (exp arg_z))
228  (movl (% exp) (% temp0))
229  (shll ($ (1+ (- ieee-single-float-exponent-offset x8632::fixnumshift))) (% temp0))
230  (shrl ($ 1) (% temp0))
231  (movl (@ x8632::single-float.value (% sfloat)) (% imm0))
232  (andl ($ #x807fffff) (% imm0))
233  (orl (% temp0) (% imm0))
234  (movl (% imm0) (@ x8632::single-float.value (% sfloat)))
235  (single-value-return))
236
237(defx8632lapfunction %short-float->double-float ((src arg_y) (result arg_z))
238  (get-single-float src fp1)
239  (cvtss2sd (% fp1) (% fp1))
240  (put-double-float fp1 result)
241  (single-value-return))
242
243(defx8632lapfunction %double-float->short-float ((src arg_z))
244  (get-double-float src fp1)
245  (cvtsd2ss (% fp1) (% fp1))
246  (put-single-float fp1 arg_z)
247  (single-value-return))
248
249(defx8632lapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
250  (int-to-single int imm0 fp1)
251  (put-single-float fp1 arg_z)
252  (single-value-return))
253
254(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
255  (int-to-double int imm0 fp1)
256  (put-double-float fp1 arg_z)
257  (single-value-return))
258
259
260
261;;; Manipulate the MXCSR.  It's 32 bits wide, and we have to load and
262;;; store it through memory.  Use the scratch-mxcsr field in the TCR.
263;;; The upper half of the MXCSR is reserved (must be zero).
264
265;;; Return the MXCSR as a fixnum
266(defx8632lapfunction %get-mxcsr ()
267  (stmxcsr (@ (% :rcontext) x8632::tcr.scratch-mxcsr))
268  (movl (@ (% :rcontext) x8632::tcr.scratch-mxcsr) (% imm0))
269  (box-fixnum imm0 arg_z)
270  (single-value-return))
271
272;;; Store the fixnum in arg_z in the MXCSR.  Just to be
273;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK,
274;;; so that only known control and status bits are written to.
275(defx86lapfunction %set-mxcsr ((val arg_z))
276  (unbox-fixnum arg_z imm0)
277  (andl ($ x86::mxcsr-write-mask) (% imm0))
278  (movl (% imm0) (@ (% :rcontext) x8632::tcr.scratch-mxcsr))
279  (ldmxcsr (@ (% :rcontext) x8632::tcr.scratch-mxcsr))
280  (single-value-return))
281
282;;; Return the MXCSR value in effect after the last ff-call.
283(defx8632lapfunction %get-post-ffi-mxcsr ()
284  (xor (% arg_z) (% arg_z))
285  (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0))
286  (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception))
287  (box-fixnum imm0 arg_z)
288  (single-value-return))
289
290;;; Get the bits that contain exception masks and rounding mode.
291
292(defun %get-mxcsr-control ()
293  (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr))))
294
295;;; Get the bits that describe current exceptions.
296(defun %get-mxcsr-status ()
297  (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr))))
298
299;;; Set the bits that describe current exceptions, presumably to clear them.
300(defun %set-mxcsr-status (arg)
301  (%set-mxcsr
302   (logior (logand x86::mxcsr-status-mask arg)
303           (logandc2 (%get-mxcsr) x86::mxcsr-status-mask)))
304  arg)
305
306;;; Set the bits that mask/unmask exceptions and control rounding.
307;;; Clear the bits which describe current exceptions.
308(defun %set-mxcsr-control (arg)
309  (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg)))
310
311;;; Return the MXCSR value in effect after the last ff-call.
312(defx86lapfunction %get-post-ffi-mxcsr ()
313  (xor (% arg_z) (% arg_z))
314  (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0))
315  (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception))
316  (box-fixnum imm0 arg_z)
317  (single-value-return))
318
319;;; The next several defuns are copied verbatim from x8664-float.lisp.
320;;; It will probably be desirable to factor this code out into a new
321;;; x86-float.lisp, perhaps conditionalized via #+sse2 or something.
322;;; (Some day we may want to support x87 fp and we'll need
323;;; x87-specific versions of these functions.)
324
325;;; start duplicated code
326
327;;; Return the status bits from the last ff-call that represent
328;;; unmasked exceptions
329(defun %ffi-exception-status ()
330  (logior (%get-mxcsr-control)
331          (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr)))))
332
333;;; See if the binary double-float operation OP set any enabled
334;;; exception bits in the mxcsr
335(defun %df-check-exception-2 (operation op0 op1 fp-status)
336  (declare (type (unsigned-byte 6) fp-status))
337  (unless (zerop fp-status)
338    (%set-mxcsr-status 0)
339    ;; Ensure that operands are heap-consed
340    (%fp-error-from-status fp-status
341                           operation 
342                           (%copy-double-float op0 (%make-dfloat)) 
343                           (%copy-double-float op1 (%make-dfloat)))))
344
345(defun %sf-check-exception-2 (operation op0 op1 fp-status)
346  (declare (type (unsigned-byte 6) fp-status))
347  (unless (zerop fp-status)
348    (%set-mxcsr-status 0)
349    ;; Ensure that operands are heap-consed
350    (%fp-error-from-status fp-status 
351                           operation
352                           #+32-bit-target
353                           (%copy-short-float op0 (%make-sfloat))
354                           #+64-bit-target op0
355                           #+32-bit-target
356                           (%copy-short-float op1 (%make-sfloat))
357                           #+64-bit-target op1)))
358
359(defun %df-check-exception-1 (operation op0 fp-status)
360  (declare (fixnum fp-status))
361  (unless (zerop fp-status)
362    (%set-mxcsr-status 0)
363    ;; Ensure that operands are heap-consed
364    (%fp-error-from-status fp-status 
365                           operation 
366                           (%copy-double-float op0 (%make-dfloat)))))
367
368(defun %sf-check-exception-1 (operation op0 fp-status)
369  (declare (type (unsigned-byte 6) fp-status))
370  (unless (zerop fp-status)
371    (%set-mxcsr-status 0)
372    ;; Ensure that operands are heap-consed
373    (%fp-error-from-status fp-status 
374                           operation
375                           #+32-bit-target
376                           (%copy-short-float op0 (%make-sfloat))
377                           #+64-bit-target op0)))
378
379
380(defun fp-condition-from-mxcsr (status-bits control-bits)
381  (declare (fixnum status-bits control-bits))
382  (cond 
383   ((and (logbitp x86::mxcsr-ie-bit status-bits)
384         (not (logbitp x86::mxcsr-im-bit control-bits)))
385    'floating-point-invalid-operation)
386   ((and (logbitp x86::mxcsr-oe-bit status-bits)
387         (not (logbitp x86::mxcsr-om-bit control-bits)))
388    'floating-point-overflow)
389   ((and (logbitp x86::mxcsr-ue-bit status-bits)
390         (not (logbitp x86::mxcsr-um-bit control-bits)))
391    'floating-point-underflow)
392   ((and (logbitp x86::mxcsr-ze-bit status-bits)
393         (not (logbitp x86::mxcsr-zm-bit control-bits)))
394    'division-by-zero)
395   ((and (logbitp x86::mxcsr-pe-bit status-bits)
396         (not (logbitp x86::mxcsr-pm-bit control-bits)))
397    'floating-point-inexact)))
398
399(defun %fp-error-from-status (status-bits  operation op0 &optional op1)
400  (declare (type (unsigned-byte 6) status-bits))
401  (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control))))
402    (if condition-class
403      (let* ((operands (if op1 (list op0 op1) (list op0))))
404        (error (make-instance condition-class
405                              :operation operation
406                              :operands operands))))))
407
408;;; end duplicated code
409
410;;; Don't we already have about 20 versions of this ?
411(defx8632lapfunction %double-float-from-macptr! ((ptr 4) #|(ra 0)|# (byte-offset arg_y) (dest arg_z))
412  (mark-as-imm temp0)
413  (let ((imm1 temp0))
414    (movl (@ ptr (% esp)) (% temp1))
415    (macptr-ptr temp1 imm0)
416    (unbox-fixnum byte-offset imm1)
417    (movsd (@ (% imm0) (% imm1)) (% fp1))
418    (put-double-float fp1 dest))
419  (mark-as-node temp0)
420  (single-value-return 3))
421
422;;; Copy a single float pointed at by the macptr in single
423;;; to a double float pointed at by the macptr in double
424(defx8632lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
425  (check-nargs 2)
426  (macptr-ptr single imm0)
427  (movss (@ (% imm0)) (% fp1))
428  (cvtss2sd (% fp1) (% fp1))
429  (macptr-ptr double imm0)
430  (movsd (% fp1) (@ (% imm0)))
431  (single-value-return))
432
433;;; Copy a double float pointed at by the macptr in double
434;;; to a single float pointed at by the macptr in single.
435(defx8632lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
436  (check-nargs 2)
437  (macptr-ptr double imm0)
438  (movsd (@ (% imm0)) (% fp1))
439  (cvtsd2ss (% fp1) (% fp1))
440  (macptr-ptr single imm0)
441  (movss (% fp1) (@ (% imm0)))
442  (single-value-return))
443
444(defx8632lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
445  (check-nargs 2)
446  (macptr-ptr macptr imm0)
447  (get-double-float src fp1)
448  (cvtsd2ss (% fp1) (% fp1))
449  (movss (% fp1) (@ (% imm0)))
450  (single-value-return))
451
452(defun host-single-float-from-unsigned-byte-32 (u32)
453  (let* ((f (%make-sfloat)))
454    (setf (uvref f x8632::single-float.value-cell) u32)
455    f))
456
457(defun single-float-bits (f)
458  (uvref f x8632::single-float.value-cell))
459
460(defun double-float-bits (f)
461  (values (uvref f target::double-float.val-high-cell)
462          (uvref f target::double-float.value-cell)))
463
464(defun double-float-from-bits (high low)
465  (let* ((f (%make-dfloat)))
466    (setf (uvref f target::double-float.val-high-cell) high
467          (uvref f target::double-float.value-cell) low)
468    f))
469
470;;; Return T if n is negative, else NIL.
471(defx8632lapfunction %double-float-sign ((n arg_z))
472  (movl (@ x8632::double-float.val-high (% n)) (% imm0))
473  (testl (% imm0) (% imm0))
474  (movl ($ x8632::t-value) (% imm0))
475  (movl ($ x8632::nil-value) (% arg_z))
476  (cmovll (% imm0) (% arg_z))
477  (single-value-return))
478
479(defx8632lapfunction %short-float-sign ((n arg_z))
480  (movl (@ x8632::single-float.value (% n)) (% imm0))
481  (testl (% imm0) (% imm0))
482  (movl ($ x8632::t-value) (% imm0))
483  (movl ($ x8632::nil-value) (% arg_z))
484  (cmovll (% imm0) (% arg_z))
485  (single-value-return))
486
487(defx8632lapfunction %double-float-sqrt! ((n arg_y) (result arg_z))
488  (get-double-float n fp0)
489  (sqrtsd (% fp0) (% fp0))
490  (put-double-float fp0 result)
491  (single-value-return))
492
493(defx8632lapfunction %single-float-sqrt! ((n arg_y) (result arg_z))
494  (get-single-float n fp0)
495  (sqrtss (% fp0) (% fp0))
496  (put-single-float fp0 arg_z)
497  (single-value-return))
498
499
500
Note: See TracBrowser for help on using the repository browser.