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

Last change on this file since 6479 was 6479, checked in by gb, 13 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
RevLine 
[2950]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
[3102]32;;; sign is -1, 1, maybe zero
[2950]33
34
35
[6479]36(defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z))
[3102]37  (mov (% sign) (% imm1))
38  (sar ($ 63) (% imm1))
39  (shl ($ 63) (% imm1))
[6479]40  (movq (@ hi (% rsp)) (% imm0))                        ;hi
[4398]41  (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0))
[3102]42  (shl ($ (- 28 x8664::fixnumshift)) (% imm0))
43  (or (% imm0) (% imm1))
44  (unbox-fixnum lo imm0)
[4398]45  (andl ($ (1- (ash 1 28))) (%l imm0))
[3102]46  (or (% imm0) (% imm1))
47  (mov (% exp) (% imm0))
48  (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0))
49  (or (% imm0) (% imm1))
[6479]50  (movq (@ float (% rsp)) (% arg_z))
[3102]51  (mov (% imm1) (@ x8664::double-float.value (% arg_z)))
[6479]52  (single-value-return 4))
[2950]53
54
[2970]55;;; Maybe we should trap - or something - on NaNs.
[2950]56(defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z))
[3064]57  (mov (@ x8664::double-float.value (% n)) (% imm0))
58  (btr ($ 63) (% imm0))
59  (mov (% imm0) (@ x8664::double-float.value (% val)))
[3102]60  (single-value-return))
[2950]61
62
63(defx86lapfunction %short-float-abs ((n arg_z))
[3176]64  (btr ($ 63) (% n))
[3102]65  (single-value-return))
[2950]66
67
[3157]68(defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z))
[4416]69  (movq (@ x8664::double-float.value (% src)) (% imm0))
70  (btcq ($ 63) (% imm0))
71  (movq (% imm0) (@ x8664::double-float.value (% res)))
[3157]72  (single-value-return))
[2950]73
74
[3157]75(defx86lapfunction %short-float-negate ((src arg_z))
[4416]76  (btcq ($ 63) (% arg_z))
[3157]77  (single-value-return))
78
79
80
[2950]81(defx86lapfunction dfloat-significand-zeros ((dfloat arg_z))
[3117]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))
[2950]88
[3117]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.
[2950]93(defx86lapfunction sfloat-significand-zeros ((sfloat arg_z))
[3117]94  (xorb (%b sfloat) (%b sfloat))
95  (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat))
[5600]96  (bsrq (% sfloat) (% imm0))
[3117]97  (xorq ($ (1- target::nbits-in-word)) (% imm0))
98  (box-fixnum imm0 arg_z)
99  (single-value-return))
[2950]100
101(defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
[3117]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))
[2950]109
110(defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z))
[3117]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))
[2950]118
119(defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
[2970]120  (get-double-float f1 fp1)
121  (put-double-float fp1 f2)
[3102]122  (single-value-return))
[2970]123
[2950]124(defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z))
[3176]125  (get-single-float src fp1)
[3102]126  (cvtss2sd (% fp1) (% fp1))
[3176]127  (put-double-float fp1 result)
[3102]128  (single-value-return))
[2950]129
130(defx86lapfunction %double-float->short-float ((src arg_z))
[3176]131  (get-double-float src fp1)
[3117]132  (cvtsd2ss (% fp1) (% fp1))
[2950]133  (put-single-float fp1 arg_z)
[3117]134  (single-value-return))
[2950]135
136(defx86lapfunction %int-to-sfloat ((int arg_z))
[3117]137  (int-to-single int imm0 fp1)
138  (put-single-float fp1 arg_z)
139  (single-value-return))
[2950]140 
141
142(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
[3117]143  (int-to-double int imm0 fp1)
144  (put-double-float fp1 arg_z)
145  (single-value-return))
[2950]146
147
148
[3117]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.
[2950]153
[3117]154;;; Return the MXCSR as a fixnum
155(defx86lapfunction %get-mxcsr ()
156  (pushq ($ '0))
[3936]157  (stmxcsr (@ 4 (% rsp)))
[3117]158  (pop (% arg_z))
159  (shr ($ (- 32 x8664::fixnumshift)) (% arg_z))
160  (single-value-return))
[2950]161
[3117]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))
[4181]167  (andl ($ '#.x86::mxcsr-write-mask) (%l temp0))
[3117]168  (shl ($ (- 32 x8664::fixnumshift)) (% temp0))
169  (push (% temp0))
[4165]170  (ldmxcsr (@ 4 (% rsp)))
[3117]171  (add ($ '1) (% rsp))
172  (single-value-return))
[2950]173
[3117]174
175;;; Get the bits that contain exception masks and rounding mode.
176
177(defun %get-mxcsr-control ()
[4181]178  (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr))))
[3117]179
180;;; Get the bits that describe current exceptions.
181(defun %get-mxcsr-status ()
[4181]182  (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr))))
[3117]183
184;;; Set the bits that describe current exceptions, presumably to clear them.
185(defun %set-mxcsr-status (arg)
[4181]186  (%set-mxcsr
187   (logior (logand x86::mxcsr-status-mask arg)
188           (logandc2 (%get-mxcsr) x86::mxcsr-status-mask)))
189  arg)
[3117]190
191;;; Set the bits that mask/unmask exceptions and control rounding.
192;;; Clear the bits which describe current exceptions.
[3677]193(defun %set-mxcsr-control (arg)
[4181]194  (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg)))
[3117]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))
[4955]199  (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0))
200  (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception))
[3117]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 ()
[4181]207  (logior (%get-mxcsr-control)
208          (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr)))))
209
210
[2950]211 
212
[3117]213;;; See if the binary double-float operation OP set any enabled
214;;; exception bits in the mxcsr
[2950]215(defun %df-check-exception-2 (operation op0 op1 fp-status)
[3117]216  (declare (type (unsigned-byte 6) fp-status))
217  (unless (zerop fp-status)
218    (%set-mxcsr-status 0)
[2950]219    ;; Ensure that operands are heap-consed
[4429]220    (%fp-error-from-status fp-status
[2950]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)
[3117]226  (declare (type (unsigned-byte 6) fp-status))
227  (unless (zerop fp-status)
228    (%set-mxcsr-status 0)
[2950]229    ;; Ensure that operands are heap-consed
230    (%fp-error-from-status fp-status 
231                           operation
[3117]232                           #+32-bit-target
[2950]233                           (%copy-short-float op0 (%make-sfloat))
[3117]234                           #+64-bit-target op0
235                           #+32-bit-target
[2950]236                           (%copy-short-float op1 (%make-sfloat))
[3117]237                           #+64-bit-target op1)))
[2950]238
239(defun %df-check-exception-1 (operation op0 fp-status)
240  (declare (fixnum fp-status))
[3614]241  (unless (zerop fp-status)
[3117]242    (%set-mxcsr-status 0)
[2950]243    ;; Ensure that operands are heap-consed
244    (%fp-error-from-status fp-status 
[3117]245                           operation 
246                           (%copy-double-float op0 (%make-dfloat)))))
[2950]247
248(defun %sf-check-exception-1 (operation op0 fp-status)
[3117]249  (declare (type (unsigned-byte 6) fp-status))
[3614]250  (unless (zerop fp-status)
[3117]251    (%set-mxcsr-status 0)
252    ;; Ensure that operands are heap-consed
[2950]253    (%fp-error-from-status fp-status 
254                           operation
[3117]255                           #+32-bit-target
[2950]256                           (%copy-short-float op0 (%make-sfloat))
[3117]257                           #+64-bit-target op0)))
[2950]258
259
[4429]260(defun fp-condition-from-mxcsr (status-bits control-bits)
261  (declare (fixnum status-bits control-bits))
[2950]262  (cond 
[4429]263   ((and (logbitp x86::mxcsr-ie-bit status-bits)
264         (not (logbitp x86::mxcsr-im-bit control-bits)))
[2950]265    'floating-point-invalid-operation)
[4429]266   ((and (logbitp x86::mxcsr-oe-bit status-bits)
267         (not (logbitp x86::mxcsr-om-bit control-bits)))
[2950]268    'floating-point-overflow)
[4429]269   ((and (logbitp x86::mxcsr-ue-bit status-bits)
270         (not (logbitp x86::mxcsr-um-bit control-bits)))
[2950]271    'floating-point-underflow)
[4429]272   ((and (logbitp x86::mxcsr-ze-bit status-bits)
273         (not (logbitp x86::mxcsr-zm-bit control-bits)))
[2950]274    'division-by-zero)
[4429]275   ((and (logbitp x86::mxcsr-pe-bit status-bits)
276         (not (logbitp x86::mxcsr-pm-bit control-bits)))
[2950]277    'floating-point-inexact)))
278
[4618]279(defun %fp-error-from-status (status-bits  operation op0 &optional op1)
[3117]280  (declare (type (unsigned-byte 6) status-bits))
[4429]281  (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control))))
[2950]282    (if condition-class
[4618]283      (let* ((operands (if op1 (list op0 op1) (list op0))))
284        (error (make-instance condition-class
285                              :operation operation
286                              :operands operands))))))
[2950]287
288
[4618]289
[2950]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))
[3176]292  (macptr-ptr ptr imm0)
293  (unbox-fixnum byte-offset imm1)
294  (movsd (@ (% imm0) (% imm1)) (% fp1))
[2950]295  (put-double-float fp1 dest)
[3176]296  (single-value-return))
[2950]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))
[3117]303  (let* ((flags (%get-mxcsr-control)))
[4181]304    (declare (fixnum flags))
[3117]305    (let* ((rounding-mode
[4181]306            (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0)
307                         (if (logbitp x86::mxcsr-rc1-bit flags) 2 0))
[3117]308                      *rounding-mode-alist*)))
[4181]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))))
[2950]314    (if mode-p
315      (ecase mode
[3117]316        (:rounding-mode rounding-mode)
317        (:overflow overflow)
318        (:underflow underflow)
319        (:division-by-zero division-by-zero)
320        (:invalid invalid)
[3614]321        (:inexact inexact))
[3117]322      `(:rounding-mode ,rounding-mode
323        :overflow ,overflow
324        :underflow ,underflow
325        :division-by-zero ,division-by-zero
326        :invalid ,invalid
327        :inexact ,inexact)))))
[2950]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))
[4181]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)))
[2950]373
374
[4181]375
[2950]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)
[3176]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))
[2950]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)
[3176]392  (macptr-ptr double imm0)
393  (movsd (@ (% imm0)) (% fp1))
394  (cvtsd2ss (% fp1) (% fp1))
395  (macptr-ptr single imm0)
[4406]396  (movss (% fp1) (@ (% imm0)))
[3176]397  (single-value-return))
[2950]398
399
400(defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
401  (check-nargs 2)
[3176]402  (macptr-ptr macptr imm0)
403  (get-double-float src fp1)
404  (cvtsd2ss (% fp1) (% fp1))
405  (movss (% fp1) (@ (% imm0)))
406  (single-value-return))
[2950]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))
[3102]411  (single-value-return))
[2950]412
413(defx86lapfunction single-float-bits ((f arg_z))
414  (shr ($ (- 32 x8664::fixnumshift)) (% f))
[3102]415  (single-value-return))
[2950]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)))
[3614]423    (setf (uvref f target::double-float.val-high-cell) high
[2950]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))
[2970]430  (testl (% imm0.l) (% imm0.l))
431  (movl ($ x8664::t-value) (% imm0.l))
[2950]432  (movl ($ x8664::nil-value) (% arg_z.l))
433  (cmovlq (% imm0) (% arg_z))
[3102]434  (single-value-return))
[2950]435
[3176]436
[2950]437(defx86lapfunction %short-float-sign ((n arg_z))
[3102]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))
[2950]443
[5627]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
[4165]456;;; end of x86-float.lisp
Note: See TracBrowser for help on using the repository browser.