source: trunk/ccl/level-0/X86/x86-float.lisp @ 6479

Last change on this file since 6479 was 6479, checked in by gb, 12 years ago

New calling sequence.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "NUMBER-MACROS")
21  (require :number-case-macro))
22
23
24;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit)
25;;;                   lo -  low 28 bits mantissa
26;;;                   exp  - take low 11 bits
27;;;                   sign - sign(sign) => result
28;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg
29;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg
30;;; no error checks, no tweaks, no nuthin
31
32;;; sign is -1, 1, maybe zero
33
34
35
36(defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z))
37  (mov (% sign) (% imm1))
38  (sar ($ 63) (% imm1))
39  (shl ($ 63) (% imm1))
40  (movq (@ hi (% rsp)) (% imm0))                        ;hi
41  (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0))
42  (shl ($ (- 28 x8664::fixnumshift)) (% imm0))
43  (or (% imm0) (% imm1))
44  (unbox-fixnum lo imm0)
45  (andl ($ (1- (ash 1 28))) (%l imm0))
46  (or (% imm0) (% imm1))
47  (mov (% exp) (% imm0))
48  (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0))
49  (or (% imm0) (% imm1))
50  (movq (@ float (% rsp)) (% arg_z))
51  (mov (% imm1) (@ x8664::double-float.value (% arg_z)))
52  (single-value-return 4))
53
54
55;;; Maybe we should trap - or something - on NaNs.
56(defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z))
57  (mov (@ x8664::double-float.value (% n)) (% imm0))
58  (btr ($ 63) (% imm0))
59  (mov (% imm0) (@ x8664::double-float.value (% val)))
60  (single-value-return))
61
62
63(defx86lapfunction %short-float-abs ((n arg_z))
64  (btr ($ 63) (% n))
65  (single-value-return))
66
67
68(defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z))
69  (movq (@ x8664::double-float.value (% src)) (% imm0))
70  (btcq ($ 63) (% imm0))
71  (movq (% imm0) (@ x8664::double-float.value (% res)))
72  (single-value-return))
73
74
75(defx86lapfunction %short-float-negate ((src arg_z))
76  (btcq ($ 63) (% arg_z))
77  (single-value-return))
78
79
80
81(defx86lapfunction dfloat-significand-zeros ((dfloat arg_z))
82  (movq (@ target::double-float.value (% dfloat)) (% imm1))
83  (shl ($ (1+ IEEE-double-float-exponent-width)) (% imm1))
84  (bsrq (% imm1) (% imm0))
85  (xorq ($ (1- target::nbits-in-word)) (% imm0))
86  (box-fixnum imm0 arg_z)
87  (single-value-return))
88
89;;; This exploits the fact that the single float is already
90;;; shifted left 32 bits.  We don't want to count the tag
91;;; bit as significant, so bash the argument into a fixnum
92;;; first.
93(defx86lapfunction sfloat-significand-zeros ((sfloat arg_z))
94  (xorb (%b sfloat) (%b sfloat))
95  (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat))
96  (bsrq (% sfloat) (% imm0))
97  (xorq ($ (1- target::nbits-in-word)) (% imm0))
98  (box-fixnum imm0 arg_z)
99  (single-value-return))
100
101(defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
102  (unbox-fixnum int imm0)
103  (get-double-float float fp1)
104  (shl ($ IEEE-double-float-exponent-offset) (% imm0))
105  (movd (% imm0) (% fp2))
106  (mulsd (% fp2) (% fp1))
107  (put-double-float fp1 result)
108  (single-value-return))
109
110(defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z))
111  (unbox-fixnum int imm0)
112  (shl ($ IEEE-double-float-exponent-offset) (% imm0))
113  (movd (% imm0) (% fp2))
114  (get-single-float float fp1)
115  (mulss (% fp2) (% fp1))
116  (put-single-float fp1 arg_z)
117  (single-value-return))
118
119(defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
120  (get-double-float f1 fp1)
121  (put-double-float fp1 f2)
122  (single-value-return))
123
124(defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z))
125  (get-single-float src fp1)
126  (cvtss2sd (% fp1) (% fp1))
127  (put-double-float fp1 result)
128  (single-value-return))
129
130(defx86lapfunction %double-float->short-float ((src arg_z))
131  (get-double-float src fp1)
132  (cvtsd2ss (% fp1) (% fp1))
133  (put-single-float fp1 arg_z)
134  (single-value-return))
135
136(defx86lapfunction %int-to-sfloat ((int arg_z))
137  (int-to-single int imm0 fp1)
138  (put-single-float fp1 arg_z)
139  (single-value-return))
140 
141
142(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
143  (int-to-double int imm0 fp1)
144  (put-double-float fp1 arg_z)
145  (single-value-return))
146
147
148
149;;; Manipulate the MXCSR.  It'll fit in a fixnum, but we have to
150;;; load and store it through memory.  On x8664, we can hide the
151;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86,
152;;; we might need to use a scratch location in the TCR or something.
153
154;;; Return the MXCSR as a fixnum
155(defx86lapfunction %get-mxcsr ()
156  (pushq ($ '0))
157  (stmxcsr (@ 4 (% rsp)))
158  (pop (% arg_z))
159  (shr ($ (- 32 x8664::fixnumshift)) (% arg_z))
160  (single-value-return))
161
162;;; Store the fixnum in arg_z in the MXCSR.  Just to be
163;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK,
164;;; so that only known control and status bits are written to.
165(defx86lapfunction %set-mxcsr ((val arg_z))
166  (mov (% val) (% temp0))
167  (andl ($ '#.x86::mxcsr-write-mask) (%l temp0))
168  (shl ($ (- 32 x8664::fixnumshift)) (% temp0))
169  (push (% temp0))
170  (ldmxcsr (@ 4 (% rsp)))
171  (add ($ '1) (% rsp))
172  (single-value-return))
173
174
175;;; Get the bits that contain exception masks and rounding mode.
176
177(defun %get-mxcsr-control ()
178  (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr))))
179
180;;; Get the bits that describe current exceptions.
181(defun %get-mxcsr-status ()
182  (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr))))
183
184;;; Set the bits that describe current exceptions, presumably to clear them.
185(defun %set-mxcsr-status (arg)
186  (%set-mxcsr
187   (logior (logand x86::mxcsr-status-mask arg)
188           (logandc2 (%get-mxcsr) x86::mxcsr-status-mask)))
189  arg)
190
191;;; Set the bits that mask/unmask exceptions and control rounding.
192;;; Clear the bits which describe current exceptions.
193(defun %set-mxcsr-control (arg)
194  (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg)))
195
196;;; Return the MXCSR value in effect after the last ff-call.
197(defx86lapfunction %get-post-ffi-mxcsr ()
198  (xor (% arg_z) (% arg_z))
199  (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0))
200  (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception))
201  (box-fixnum imm0 arg_z)
202  (single-value-return))
203
204;;; Return the status bits from the last ff-call that represent
205;;; unmasked exceptions
206(defun %ffi-exception-status ()
207  (logior (%get-mxcsr-control)
208          (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr)))))
209
210
211 
212
213;;; See if the binary double-float operation OP set any enabled
214;;; exception bits in the mxcsr
215(defun %df-check-exception-2 (operation op0 op1 fp-status)
216  (declare (type (unsigned-byte 6) fp-status))
217  (unless (zerop fp-status)
218    (%set-mxcsr-status 0)
219    ;; Ensure that operands are heap-consed
220    (%fp-error-from-status fp-status
221                           operation 
222                           (%copy-double-float op0 (%make-dfloat)) 
223                           (%copy-double-float op1 (%make-dfloat)))))
224
225(defun %sf-check-exception-2 (operation op0 op1 fp-status)
226  (declare (type (unsigned-byte 6) fp-status))
227  (unless (zerop fp-status)
228    (%set-mxcsr-status 0)
229    ;; Ensure that operands are heap-consed
230    (%fp-error-from-status fp-status 
231                           operation
232                           #+32-bit-target
233                           (%copy-short-float op0 (%make-sfloat))
234                           #+64-bit-target op0
235                           #+32-bit-target
236                           (%copy-short-float op1 (%make-sfloat))
237                           #+64-bit-target op1)))
238
239(defun %df-check-exception-1 (operation op0 fp-status)
240  (declare (fixnum fp-status))
241  (unless (zerop fp-status)
242    (%set-mxcsr-status 0)
243    ;; Ensure that operands are heap-consed
244    (%fp-error-from-status fp-status 
245                           operation 
246                           (%copy-double-float op0 (%make-dfloat)))))
247
248(defun %sf-check-exception-1 (operation op0 fp-status)
249  (declare (type (unsigned-byte 6) fp-status))
250  (unless (zerop fp-status)
251    (%set-mxcsr-status 0)
252    ;; Ensure that operands are heap-consed
253    (%fp-error-from-status fp-status 
254                           operation
255                           #+32-bit-target
256                           (%copy-short-float op0 (%make-sfloat))
257                           #+64-bit-target op0)))
258
259
260(defun fp-condition-from-mxcsr (status-bits control-bits)
261  (declare (fixnum status-bits control-bits))
262  (cond 
263   ((and (logbitp x86::mxcsr-ie-bit status-bits)
264         (not (logbitp x86::mxcsr-im-bit control-bits)))
265    'floating-point-invalid-operation)
266   ((and (logbitp x86::mxcsr-oe-bit status-bits)
267         (not (logbitp x86::mxcsr-om-bit control-bits)))
268    'floating-point-overflow)
269   ((and (logbitp x86::mxcsr-ue-bit status-bits)
270         (not (logbitp x86::mxcsr-um-bit control-bits)))
271    'floating-point-underflow)
272   ((and (logbitp x86::mxcsr-ze-bit status-bits)
273         (not (logbitp x86::mxcsr-zm-bit control-bits)))
274    'division-by-zero)
275   ((and (logbitp x86::mxcsr-pe-bit status-bits)
276         (not (logbitp x86::mxcsr-pm-bit control-bits)))
277    'floating-point-inexact)))
278
279(defun %fp-error-from-status (status-bits  operation op0 &optional op1)
280  (declare (type (unsigned-byte 6) status-bits))
281  (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control))))
282    (if condition-class
283      (let* ((operands (if op1 (list op0 op1) (list op0))))
284        (error (make-instance condition-class
285                              :operation operation
286                              :operands operands))))))
287
288
289
290;;; Don't we already have about 20 versions of this ?
291(defx86lapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
292  (macptr-ptr ptr imm0)
293  (unbox-fixnum byte-offset imm1)
294  (movsd (@ (% imm0) (% imm1)) (% fp1))
295  (put-double-float fp1 dest)
296  (single-value-return))
297
298
299(defvar *rounding-mode-alist*
300  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
301
302(defun get-fpu-mode (&optional (mode nil mode-p))
303  (let* ((flags (%get-mxcsr-control)))
304    (declare (fixnum flags))
305    (let* ((rounding-mode
306            (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0)
307                         (if (logbitp x86::mxcsr-rc1-bit flags) 2 0))
308                      *rounding-mode-alist*)))
309           (overflow (not (logbitp x86::mxcsr-om-bit flags)))
310           (underflow (not (logbitp x86::mxcsr-um-bit flags)))
311           (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags)))
312           (invalid (not (logbitp x86::mxcsr-im-bit flags)))
313           (inexact (not (logbitp x86::mxcsr-pm-bit flags))))
314    (if mode-p
315      (ecase mode
316        (:rounding-mode rounding-mode)
317        (:overflow overflow)
318        (:underflow underflow)
319        (:division-by-zero division-by-zero)
320        (:invalid invalid)
321        (:inexact inexact))
322      `(:rounding-mode ,rounding-mode
323        :overflow ,overflow
324        :underflow ,underflow
325        :division-by-zero ,division-by-zero
326        :invalid ,invalid
327        :inexact ,inexact)))))
328
329;;; did we document this?
330(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
331                          (overflow t overflow-p)
332                          (underflow t underflow-p)
333                          (division-by-zero t zero-p)
334                          (invalid t invalid-p)
335                          (inexact t inexact-p))
336  (let* ((current (%get-mxcsr-control))
337         (new current))
338    (declare (fixnum current new))
339    (when rounding-p
340      (let* ((rc-bits (or
341                       (cdr (assoc rounding-mode *rounding-mode-alist*))
342                       (error "Unknown rounding mode: ~s" rounding-mode))))
343        (declare (fixnum rc-bits))
344        (if (logbitp 0 rc-bits)
345          (bitsetf x86::mxcsr-rc0-bit new)
346          (bitclrf x86::mxcsr-rc0-bit new))
347        (if (logbitp 1 rc-bits)
348          (bitsetf x86::mxcsr-rc1-bit new)
349          (bitclrf x86::mxcsr-rc1-bit new))))
350    (when invalid-p
351      (if invalid
352        (bitclrf x86::mxcsr-im-bit new)
353        (bitsetf x86::mxcsr-im-bit new)))
354    (when overflow-p
355      (if overflow
356        (bitclrf x86::mxcsr-om-bit new)
357        (bitsetf x86::mxcsr-om-bit new)))
358    (when underflow-p
359      (if underflow
360        (bitclrf x86::mxcsr-um-bit new)
361        (bitsetf x86::mxcsr-um-bit new)))
362    (when zero-p
363      (if division-by-zero
364        (bitclrf x86::mxcsr-zm-bit new)
365        (bitsetf x86::mxcsr-zm-bit new)))
366    (when inexact-p
367      (if inexact
368        (bitclrf x86::mxcsr-pm-bit new)
369        (bitsetf x86::mxcsr-pm-bit new)))
370    (unless (= current new)
371      (%set-mxcsr-control new))
372    (%get-mxcsr)))
373
374
375
376;;; Copy a single float pointed at by the macptr in single
377;;; to a double float pointed at by the macptr in double
378
379(defx86lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
380  (check-nargs 2)
381  (macptr-ptr single imm0)
382  (movss (@ (% imm0)) (% fp1))
383  (cvtss2sd (% fp1) (% fp1))
384  (macptr-ptr double imm0)
385  (movsd (% fp1) (@ (% imm0)))
386  (single-value-return))
387
388;;; Copy a double float pointed at by the macptr in double
389;;; to a single float pointed at by the macptr in single.
390(defx86lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
391  (check-nargs 2)
392  (macptr-ptr double imm0)
393  (movsd (@ (% imm0)) (% fp1))
394  (cvtsd2ss (% fp1) (% fp1))
395  (macptr-ptr single imm0)
396  (movss (% fp1) (@ (% imm0)))
397  (single-value-return))
398
399
400(defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
401  (check-nargs 2)
402  (macptr-ptr macptr imm0)
403  (get-double-float src fp1)
404  (cvtsd2ss (% fp1) (% fp1))
405  (movss (% fp1) (@ (% imm0)))
406  (single-value-return))
407
408(defx86lapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z))
409  (shl ($ (- 32 x8664::fixnumshift)) (% arg_z))
410  (movb ($ x8664::subtag-single-float) (% arg_z.b))
411  (single-value-return))
412
413(defx86lapfunction single-float-bits ((f arg_z))
414  (shr ($ (- 32 x8664::fixnumshift)) (% f))
415  (single-value-return))
416
417(defun double-float-bits (f)
418  (values (uvref f target::double-float.val-high-cell)
419          (uvref f target::double-float.val-low-cell)))
420
421(defun double-float-from-bits (high low)
422  (let* ((f (%make-dfloat)))
423    (setf (uvref f target::double-float.val-high-cell) high
424          (uvref f target::double-float.val-low-cell) low)
425    f))
426
427;;; Return T if n is negative, else NIL.
428(defx86lapfunction %double-float-sign ((n arg_z))
429  (movl (@ x8664::double-float.val-high (% n)) (% imm0.l))
430  (testl (% imm0.l) (% imm0.l))
431  (movl ($ x8664::t-value) (% imm0.l))
432  (movl ($ x8664::nil-value) (% arg_z.l))
433  (cmovlq (% imm0) (% arg_z))
434  (single-value-return))
435
436
437(defx86lapfunction %short-float-sign ((n arg_z))
438  (testq (% n) (% n))
439  (movl ($ x8664::t-value) (% imm0.l))
440  (movl ($ x8664::nil-value) (% arg_z.l))
441  (cmovlq (% imm0) (% arg_z))
442  (single-value-return))
443
444(defx86lapfunction %double-float-sqrt! ((n arg_y) (result arg_z))
445  (get-double-float n fp0)
446  (sqrtsd (% fp0) (% fp0))
447  (put-double-float fp0 result)
448  (single-value-return))
449
450(defx86lapfunction %single-float-sqrt ((n arg_z))
451  (get-single-float n fp0)
452  (sqrtss (% fp0) (% fp0))
453  (put-single-float fp0 arg_z)
454  (single-value-return))
455
456;;; end of x86-float.lisp
Note: See TracBrowser for help on using the repository browser.