source: trunk/source/level-0/X86/X8632/x8632-float.lisp @ 13067

Last change on this file since 13067 was 13067, checked in by rme, 11 years ago

Update copyright notices.

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