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

Last change on this file since 14104 was 14104, checked in by gb, 11 years ago

Don't use "ba" pseudo-instruction.

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