source: branches/arm/level-0/ARM/arm-float.lisp @ 14037

Last change on this file since 14037 was 14037, checked in by gb, 10 years ago

FFI FP exception stuff.

File size: 16.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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
33(defarmlapfunction %make-float-from-fixnums ((float 4)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z))
34  (ldr imm0 (:@ vsp (:$ hi)))
35  (unbox-fixnum imm0 imm0)
36  (unbox-fixnum imm1 lo)
37  (cmp sign (:$ 0))
38  (orr imm1 imm1 (:lsl imm0 (:$ 28)))
39  (mov imm0 (:lsr imm0 (:$ 4)))
40  (bic imm0 imm0 (:$ #xff000000))
41  (bic imm0 imm0 (:$ #x00f00000))
42  (orr imm0 imm0 (:lsl exp (:$ (- 20 arm::fixnumshift)))) ;  exp left 20 right 2 keep 11 bits
43  (ldr arg_z (:@ vsp (:$ float)))
44  (orrmi imm0 imm0 (:$ #x80000000))
45  (str imm0 (:@ arg_z (:$ arm::double-float.val-high)))
46  (str imm1 (:@ arg_z (:$ arm::double-float.val-low)))
47  (add vsp vsp '2)
48  (bx lr))
49
50
51(defarmlapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z))
52  (mov imm0 (:lsl sig (:$ (- 32 (+ ieee-single-float-hidden-bit arm::fixnumshift)))))
53  (mov imm0 (:lsr imm0 (:$ (- 32 ieee-single-float-hidden-bit))))
54  (and imm1 sign (:$ #x800000000))
55  (orr imm0 imm0 (:lsl exp (:$ (- 23 arm::fixnumshift))))
56  (orr imm0 imm0 imm1)
57  (vpop1 arg_z)
58  (str imm0 (:@ arg_z (:$ arm::single-float.value)))
59  (bx lr))
60
61
62(defarmlapfunction %%double-float-abs! ((n arg_y)(val arg_z))
63  (get-double-float d0 n)
64  (fabsd d1 d0)
65  (put-double-float d1 val)
66  (bx lr))
67
68(defarmlapfunction %%short-float-abs! ((n arg_y) (val arg_z))
69  (get-single-float s1 n imm0)
70  (fabss s0 s1)
71  (put-single-float s0 val imm0)
72  (bx lr))
73
74
75
76(defarmlapfunction %double-float-negate! ((src arg_y) (res arg_z))
77  (get-double-float d0 src)
78  (fnegd d1 d0)
79  (put-double-float d1 res)
80  (bx lr))
81
82(defarmlapfunction %short-float-negate! ((src arg_y) (res arg_z))
83  (get-single-float s0 src imm0)
84  (fnegs s1 s0)
85  (put-single-float s1 res imm0)
86  (bx lr))
87
88
89
90
91;;; rets hi (25 bits) lo (28 bits) exp sign
92(defarmlapfunction %integer-decode-double-float ((n arg_z))
93  (ldr imm0  (:@ n (:$ arm::double-float.val-high)))
94  (mov temp0 '1)
95  (tst imm0 (:$ #x80000000))
96  (movne temp0 '-1)
97  (bic imm1 imm0 (:$ #x80000000))
98  (mov temp1 '-1)
99  (ands temp1 temp1 (:lsr imm1 (:$ (- (- IEEE-double-float-exponent-offset 32)
100                                      arm::fixnumshift))))
101  (mov imm0 (:lsl imm0 (:$ 12)))
102  (mov imm0 (:lsr imm0 (:$ 12)))
103  (ldr imm1 (:@ n (:$ arm::double-float.val-low)))
104  (orrne imm0 imm0 (:$ (ash 1 (- IEEE-double-float-hidden-bit 32))))
105  (mov imm0 (:lsl imm0 (:$ 4)))
106  (orr imm0 imm0 (:lsr imm1 (:$ (- 32 4))))
107  (box-fixnum imm0 imm0)
108  (mov imm1 (:lsl imm1 (:$ 4)))
109  (mov imm1 (:lsr imm1 (:$ (- 4 arm::fixnumshift))))
110  (vpush1 imm0)   ; hi 25 bits of mantissa (includes implied 1)
111  (vpush1 imm1)   ; lo 28 bits of mantissa
112  (vpush1 temp1)  ; exp
113  (vpush1 temp0)  ; sign
114  (set-nargs 4)
115  (add temp0 vsp '4)
116  (ba .SPvalues))
117
118
119;;; hi is 25 bits lo is 28 bits
120;;; big is 32 lo, 21 hi right justified
121(defarmlapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z))
122  (unbox-fixnum imm0 hi)
123  (unbox-fixnum imm1 lo)
124  (orr imm1 imm1 (:lsl imm0 (:$ 28)))
125  (mov imm0 (:lsr imm0 (:$ 4)))
126  (str imm0 (:@ big (:$ (+ arm::misc-data-offset 4))))
127  (str imm1 (:@ big (:$ arm::misc-data-offset)))
128  (bx lr))
129
130
131(defarmlapfunction dfloat-significand-zeros ((dfloat arg_z))
132  (ldr imm1 (:@ dfloat (:$ arm::double-float.value)))
133  (movs imm1 (:lsl imm1 (:$ 12)))
134  (clz imm1 imm1)
135  (movne arg_z (:lsl imm1 (:$ arm::fixnumshift)))
136  (bxne lr)
137  @golo
138  (ldr imm1 (:@ dfloat (:$ arm::double-float.val-low)))
139  (clz imm1 imm1)
140  (add imm1 imm1 (:$ 20))
141  (box-fixnum arg_z imm1)
142  (bx lr))
143
144(defarmlapfunction sfloat-significand-zeros ((sfloat arg_z))
145  (ldr imm1 (:@ sfloat (:$ arm::single-float.value)))
146  (mov imm1 (:lsl imm1 (:$ 9)))
147  (clz imm1 imm1)
148  (box-fixnum arg_z imm1)
149  (bx lr))
150
151
152
153(defarmlapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
154  (unbox-fixnum imm2 int)               ;imm0/imm1 needed for ldrd, etc.
155  (get-double-float d0 float)
156  (mov temp0 (:$ 0))
157  (mov imm2 (:lsl imm2 (:$ (- ieee-double-float-exponent-offset 32))))
158  (fmdrr d1 temp0 imm2)
159  (fmuld d0 d1 d0)
160  (put-double-float d0 result)
161  (bx lr))
162
163
164
165(defarmlapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z))
166  (ldr imm1 (:@ float (:$ arm::single-float.value)))
167  (mov imm0 (:lsl int (:$ (- IEEE-single-float-exponent-offset arm::fixnumshift))))
168  (fmsr s0 imm1)
169  (fmsr s2 imm0)
170  (fmuls s0 s0 s2)
171  (fmrs imm0 s0)
172  (str imm0 (:@ result (:$ arm::single-float.value)))
173  (bx lr))
174                   
175
176
177
178(defarmlapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
179  (ldrd imm0 (:@ f1 (:$ arm::double-float.value)))
180  (strd imm0 (:@ f2 (:$ arm::double-float.value)))
181  (bx lr))
182                   
183
184
185(defarmlapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
186  (ldr imm0 (:@ f1 (:$ arm::single-float.value)))
187  (str imm0 (:@ f2 (:$ arm::single-float.value)))
188  (bx lr))
189
190
191(defarmlapfunction %double-float-exp ((n arg_z))
192  (ldr imm1 (:@ n (:$ arm::double-float.val-high)))
193  (mov imm1 (:lsl imm1 (:$ 1)))
194  (mov imm1 (:lsr imm1 (:$ (1+ (- ieee-double-float-exponent-offset 32)))))
195  (box-fixnum arg_z imm1)
196  (bx lr))
197
198
199
200
201(defarmlapfunction set-%double-float-exp ((float arg_y) (exp arg_z))
202  (ldr imm1 (:@ float (:$ arm::double-float.val-high)))
203  (mov imm0 (:$ #xff000000))
204  (orr imm0 imm0 (:$ #x00e00000))
205  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
206  (and imm0 imm0 (:lsl exp (:$ (- 21 arm::fixnumshift))))
207  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
208  (str imm1 (:@ float (:$ arm::double-float.val-high))) ; hdr - tag = 8 - 2
209  (bx lr))
210
211
212
213
214(defarmlapfunction %short-float-exp ((n arg_z))
215  (ldr imm1 (:@ n (:$ arm::single-float.value)))
216  (mov imm1 (:lsl imm1 (:$ 1)))
217  (mov imm1 (:lsr imm1 (:$ (1+ ieee-single-float-exponent-offset))))
218  (box-fixnum arg_z imm1)
219  (bx lr))
220
221
222
223
224(defarmlapfunction set-%short-float-exp ((float arg_y) (exp arg_z))
225  (ldr imm1 (:@ float (:$ arm::single-float.value)))
226  (mov imm0 (:$ #xff000000))
227  (mvn imm0 (:lsr imm0 (:$ 1)))
228  (and imm1 imm1 imm0)
229  (orr imm1 imm1 (:lsl exp (:$ (- ieee-single-float-exponent-offset arm::fixnumshift))))
230  (str imm1 (:@ float (:$ arm::single-float.value)))
231  (bx lr))
232
233 
234(defarmlapfunction %short-float->double-float ((src arg_y) (result arg_z))
235  (get-single-float s0 src imm0)
236  (fcvtds d1 s0)
237  (put-double-float d1 result)
238  (bx lr))
239
240
241(defarmlapfunction %double-float->short-float ((src arg_y) (result arg_z))
242  ;(clear-fpu-exceptions)
243  (get-double-float d0 src)
244  (fcvtsd s1 d0)
245  (put-single-float s1 result imm0)
246  (bx lr))
247
248
249 
250
251
252
253(defarmlapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
254  (unbox-fixnum imm0 int)
255  (fmsr s0 imm0)
256  (fsitos s1 s0)
257  (put-single-float s1 sfloat imm0)
258  (bx lr))
259
260
261 
262
263(defarmlapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
264  (unbox-fixnum imm0 int)
265  (fmsr s0 imm0)
266  (fsitod d1 s0)
267  (put-double-float d1 dfloat)
268  (bx lr))
269
270(defarmlapfunction %ffi-exception-status ()
271  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
272  (fmrx imm2 fpscr)
273  (and imm0 imm2 (:$ #xff))
274  (ands imm0 imm0 (:lsr imm1 (:$ 8)))
275  (moveq arg_z 'nil)
276  (bxeq lr)
277  (mov arg_z (:lsl imm0 (:$ arm::fixnumshift)))
278  (bic imm0 imm2 (:$ #xff))
279  (fmxr fpscr imm0)
280  (bx lr))
281
282(defun %sf-check-exception-1 (operation op0 fp-status)
283  (when fp-status
284    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
285      (error (make-instance (or condition-name 'arithmetic-error)
286                            :operation operation
287                            :operands (list (%copy-short-float op0 (%make-sfloat))))))))
288
289(defun %sf-check-exception-2 (operation op0 op1 fp-status)
290  (when fp-status
291    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
292      (error (make-instance (or condition-name 'arithmetic-error)
293                            :operation operation
294                            :operands (list (%copy-short-float op0 (%make-sfloat))
295                                            (%copy-short-float op1 (%make-sfloat))))))))
296
297
298(defun %df-check-exception-1 (operation op0 fp-status)
299  (when fp-status
300    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
301      (error (make-instance (or condition-name 'arithmetic-error)
302                            :operation operation
303                            :operands (list (%copy-double-float op0 (%make-dfloat))))))))
304
305; See if the binary double-float operation OP set any enabled
306; exception bits in the fpscr
307(defun %df-check-exception-2 (operation op0 op1 fp-status)
308  (when fp-status
309    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
310      (error (make-instance (or condition-name 'arithmetic-error)
311                            :operation operation
312                            :operands (list (%copy-double-float op0 (%make-dfloat))
313                                            (%copy-double-float op1 (%make-dfloat))))))))
314
315(defvar *rounding-mode-alist*
316  '((:nearest . 0) (:positive . 1) (:negative . 2) (:zero . 3)))
317
318(defun get-fpu-mode (&optional (mode nil mode-p))
319  (let* ((flags (%get-fpscr-control)))
320    (declare (fixnum flags))
321    (let* ((rounding-mode
322            (car (nth (ldb (byte 2 22) flags) *rounding-mode-alist*)))
323           (overflow (logbitp arm::ofe flags))
324           (underflow (logbitp arm::ufe flags))
325           (division-by-zero (logbitp arm::dze flags))
326           (invalid (logbitp arm::ioe flags))
327           (inexact (logbitp arm::ixe flags)))
328    (if mode-p
329      (ecase mode
330        (:rounding-mode rounding-mode)
331        (:overflow overflow)
332        (:underflow underflow)
333        (:division-by-zero division-by-zero)
334        (:invalid invalid)
335        (:inexact inexact))
336      `(:rounding-mode ,rounding-mode
337        :overflow ,overflow
338        :underflow ,underflow
339        :division-by-zero ,division-by-zero
340        :invalid ,invalid
341        :inexact ,inexact)))))
342
343;;; did we document this?
344(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
345                          (overflow t overflow-p)
346                          (underflow t underflow-p)
347                          (division-by-zero t zero-p)
348                          (invalid t invalid-p)
349                          (inexact t inexact-p))
350  (let* ((current (%get-fpscr-control))
351         (new current))
352    (declare (fixnum current new))
353    (when rounding-p
354      (let* ((rc-bits (or
355                       (cdr (assoc rounding-mode *rounding-mode-alist*))
356                       (error "Unknown rounding mode: ~s" rounding-mode))))
357        (declare (fixnum rc-bits))
358        (setq new (dpb rc-bits (byte 2 22) new))))
359    (when invalid-p
360      (if invalid
361        (bitsetf arm::ioe new)
362        (bitclrf arm::ioe new)))
363    (when overflow-p
364      (if overflow
365        (bitsetf arm::ofe new)
366        (bitclrf arm::ofe new)))
367    (when underflow-p
368      (if underflow
369        (bitsetf arm::ufe new)
370        (bitclrf arm::ufe new)))
371    (when zero-p
372      (if division-by-zero
373        (bitsetf arm::dze new)
374        (bitclrf arm::dze new)))
375    (when inexact-p
376      (if inexact
377        (bitsetf arm::ixe new)
378        (bitclrf arm::ixe new)))
379    (unless (= current new)
380      (%set-fpscr-control new))
381    (%get-fpscr)))
382
383
384;;; Manipulating the FPSCR.  Keeping FP exception enable bits in
385;;; the FPSCR doesn't do us a whole lot of good; the NEON doesn't
386;;; support traps on FP exceptions, and some OSes (the World's
387;;; Most Advanced, in particular) reboot when a process gets an
388;;; enabled trapping FP exception on older hardware.
389;;; So: we keep the (logical) enabled exception mask in tcr.lisp-fpscr,
390;;; and just store the rounding mode in the hardware FPSCR.
391
392(defarmlapfunction %get-fpscr-control ()
393  (fmrx imm0 :fpscr)
394  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
395  (and imm0 imm0 (:$ (ash 3 22)))       ;rounding mode
396  (and imm1 imm1 (:$ #xff00))
397  (orr imm0 imm0 imm1)
398  (box-fixnum arg_z imm0)
399  (bx lr))
400
401;;; Get the cumulative exception status bits out of the FPSCR.
402(defarmlapfunction %get-fpscr-status ()
403  (fmrx imm0 :fpscr)
404  (and imm0 imm0 (:$ #xff))
405  (box-fixnum arg_z imm0)
406  (bx lr))
407
408;;; Set (clear, usually) the cumulative exception status bits in the FPSCR.
409(defarmlapfunction %set-fpscr-status ((new arg_z))
410  (fmrx imm1 :fpscr)
411  (unbox-fixnum imm0 new)
412  (and imm0 imm0 (:$ #xff))
413  (bic imm1 imm1 (:$ #xff))
414  (orr imm0 imm0 imm1)
415  (fmxr :fpscr imm0)
416  (bx lr))
417
418;;; Set the rounding mode directly in the FPSCR, and the exception enable
419;;; bits in tcr.lisp-fpscr.
420(defarmlapfunction %set-fpscr-control ((new arg_z))
421  (unbox-fixnum imm0 new)
422  (and imm1 imm0 (:$ #xff00))
423  (str imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
424  (fmrx imm1 :fpscr)
425  (bic imm1 imm1 (:$ (ash 3 22)))
426  (and imm0 imm0 (:$ (ash 3 22)))
427  (orr imm0 imm1 imm0)
428  (fmxr :fpscr imm0)
429  (bx lr))
430
431(defarmlapfunction %get-fpscr ()
432  (fmrx imm0 :fpscr)
433  (bic imm0 imm0 (:$ #xff00))
434  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
435  (and imm1 imm1 (:$ #xff00))
436  (orr imm0 imm1 imm0)
437  (mov imm0 (:lsl imm0 (:$ 4)))
438  (mov arg_z (:lsr imm0 (:$ (- 4 arm::fixnumshift))))
439  (bx lr))
440
441(defun fp-condition-name-from-fpscr-status (status)
442  (cond
443    ((logbitp arm::ioc status) 'floating-point-invalid-operation)
444    ((logbitp arm::dzc status) 'division-by-zero)
445    ((logbitp arm::ofc status) 'floating-point-overflow)
446    ((logbitp arm::ufc status) 'floating-point-underflow)
447    ((logbitp arm::ixc status) 'floating-point-inexact)))
448     
449 
450;;; Don't we already have about 20 versions of this ?
451(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
452  (ldr imm0 (:@ ptr (:$ arm::macptr.address)))
453  (unbox-fixnum imm1 byte-offset)
454  (ldrd imm0  (:@ imm0 imm1))
455  (strd imm0 (:@ dest (:$ arm::double-float.value)))
456  (bx lr))
457
458
459;;; Copy a single float pointed at by the macptr in single
460;;; to a double float pointed at by the macptr in double
461
462(defarmlapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
463  (check-nargs 2)
464  (macptr-ptr imm0 single)
465  (flds s0 (:@ imm0 (:$ 0)))
466  (fcvtds d1 s0)
467  (macptr-ptr imm0 double)
468  (fstd d1 (:@ imm0 (:$ 0)))
469  (bx lr))
470
471;;; Copy a double float pointed at by the macptr in double
472;;; to a single float pointed at by the macptr in single.
473(defarmlapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
474  (check-nargs 2)
475  (macptr-ptr imm0 double)
476  (fldd d0 (:@ imm0 (:$ 0)))
477  (macptr-ptr imm0 single)
478  (fcvtsd s2 d0)
479  (fsts s2 (:@  imm0 (:$ 0)))
480  (bx lr))
481
482
483(defarmlapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
484  (check-nargs 2)
485  (macptr-ptr imm0 macptr)
486  (get-double-float d1 src)
487  (fcvtsd s0 d1)
488  (fsts s0 (:@ imm0 (:$ 0)))
489  (bx lr))
490
491
492(defun host-single-float-from-unsigned-byte-32 (u32)
493  (let* ((f (%make-sfloat)))
494    (setf (uvref f arm::single-float.value-cell) u32)
495    f))
496
497
498
499
500
501(defun single-float-bits (f)
502  (uvref f arm::single-float.value-cell))
503
504
505
506(defun double-float-bits (f)
507  (values (uvref f arm::double-float.val-high-cell)
508          (uvref f arm::double-float.val-low-cell)))
509
510(defun double-float-from-bits (high low)
511  (let* ((f (%make-dfloat)))
512    (setf (uvref f arm::double-float.val-high-cell) high
513          (uvref f arm::double-float.val-low-cell) low)
514    f))
515
516(defarmlapfunction %double-float-sign ((n arg_z))
517  (ldr imm0 (:@ n (:$ arm::double-float.val-high)))
518  (cmp imm0 ($ 0))
519  (mov arg_z 'nil)
520  (addlt arg_z arg_z (:$ arm::t-offset))
521  (bx lr))
522
523(defarmlapfunction %short-float-sign ((n arg_z))
524  (ldr imm0 (:@ n (:$ arm::single-float.value)))
525  (cmp imm0 ($ 0))
526  (mov arg_z 'nil)
527  (addlt arg_z arg_z (:$ arm::t-offset))
528  (bx lr))
529
530(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
531  (build-lisp-frame)
532  (get-single-float s0 src imm0)
533  (fmrx imm0 fpscr)
534  (bic imm0 imm0 (:$ #xff))
535  (fmxr fpscr imm0)
536  (fsqrts s1 s0)
537  (bl .SPcheck-fpu-exception)
538  (put-single-float s1 dest imm0)
539  (return-lisp-frame))
540
541
542
543(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
544  (build-lisp-frame)
545  (get-double-float d0 src)
546  (fmrx imm0 fpscr)
547  (bic imm0 imm0 (:$ #xff))
548  (fmxr fpscr imm0)
549  (fsqrtd d1 d0)
550  (bl .SPcheck-fpu-exception)
551  (put-double-float d1 dest)
552  (return-lisp-frame))
553
554
Note: See TracBrowser for help on using the repository browser.