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

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

Fix in %MAKE-FLOAT-FROM-FIXNUMS.
Get control bits right in SET-FPU-MODE.
Given FPSCR status bits, use FP-CONDITION-NAME-FROM-FPSCR-STATUS to
derive a condition name.

File size: 20.7 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  (mov arg_z (:$ 0))                    ;for now
272  (bx lr))
273
274(defun %sf-check-exception-1 (operation op0 fp-status)
275  (declare (ignore operation op0 fp-status)))
276
277(defun %df-check-exception-1 (operation op0 fp-status)
278  (declare (ignore operation op0 fp-status)))
279
280(defvar *rounding-mode-alist*
281  '((:nearest . 0) (:positive . 1) (:negative . 2) (:zero . 3)))
282
283(defun get-fpu-mode (&optional (mode nil mode-p))
284  (let* ((flags (%get-fpscr-control)))
285    (declare (fixnum flags))
286    (let* ((rounding-mode
287            (car (nth (ldb (byte 2 22) flags) *rounding-mode-alist*)))
288           (overflow (logbitp arm::ofe flags))
289           (underflow (logbitp arm::ufe flags))
290           (division-by-zero (logbitp arm::dze flags))
291           (invalid (logbitp arm::ioe flags))
292           (inexact (logbitp arm::ixe flags)))
293    (if mode-p
294      (ecase mode
295        (:rounding-mode rounding-mode)
296        (:overflow overflow)
297        (:underflow underflow)
298        (:division-by-zero division-by-zero)
299        (:invalid invalid)
300        (:inexact inexact))
301      `(:rounding-mode ,rounding-mode
302        :overflow ,overflow
303        :underflow ,underflow
304        :division-by-zero ,division-by-zero
305        :invalid ,invalid
306        :inexact ,inexact)))))
307
308;;; did we document this?
309(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
310                          (overflow t overflow-p)
311                          (underflow t underflow-p)
312                          (division-by-zero t zero-p)
313                          (invalid t invalid-p)
314                          (inexact t inexact-p))
315  (let* ((current (%get-fpscr-control))
316         (new current))
317    (declare (fixnum current new))
318    (when rounding-p
319      (let* ((rc-bits (or
320                       (cdr (assoc rounding-mode *rounding-mode-alist*))
321                       (error "Unknown rounding mode: ~s" rounding-mode))))
322        (declare (fixnum rc-bits))
323        (setq new (dpb rc-bits (byte 2 22) new))))
324    (when invalid-p
325      (if invalid
326        (bitsetf arm::ioe new)
327        (bitclrf arm::ioe new)))
328    (when overflow-p
329      (if overflow
330        (bitsetf arm::ofe new)
331        (bitclrf arm::ofe new)))
332    (when underflow-p
333      (if underflow
334        (bitsetf arm::ufe new)
335        (bitclrf arm::ufe new)))
336    (when zero-p
337      (if division-by-zero
338        (bitsetf arm::dze new)
339        (bitclrf arm::dze new)))
340    (when inexact-p
341      (if inexact
342        (bitsetf arm::ixe new)
343        (bitclrf arm::ixe new)))
344    (unless (= current new)
345      (%set-fpscr-control new))
346    (%get-fpscr)))
347
348
349;;; Manipulating the FPSCR.  Keeping FP exception enable bits in
350;;; the FPSCR doesn't do us a whole lot of good; the NEON doesn't
351;;; support traps on FP exceptions, and some OSes (the World's
352;;; Most Advanced, in particular) reboot when a process gets an
353;;; enabled trapping FP exception on older hardware.
354;;; So: we keep the (logical) enabled exception mask in tcr.lisp-fpscr,
355;;; and just store the rounding mode in the hardware FPSCR.
356
357(defarmlapfunction %get-fpscr-control ()
358  (fmrx imm0 :fpscr)
359  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
360  (and imm0 imm0 (:$ (ash 3 22)))       ;rounding mode
361  (and imm1 imm1 (:$ #xff00))
362  (orr imm0 imm0 imm1)
363  (box-fixnum arg_z imm0)
364  (bx lr))
365
366;;; Get the cumulative exception status bits out of the FPSCR.
367(defarmlapfunction %get-fpscr-status ()
368  (fmrx imm0 :fpscr)
369  (and imm0 imm0 (:$ #xff))
370  (box-fixnum arg_z imm0)
371  (bx lr))
372
373;;; Set (clear, usually) the cumulative exception status bits in the FPSCR.
374(defarmlapfunction %set-fpscr-status ((new arg_z))
375  (fmrx imm1 :fpscr)
376  (unbox-fixnum imm0 new)
377  (and imm0 imm0 (:$ #xff))
378  (bic imm1 imm1 (:$ #xff))
379  (orr imm0 imm0 imm1)
380  (fmxr :fpscr imm0)
381  (bx lr))
382
383;;; Set the rounding mode directly in the FPSCR, and the exception enable
384;;; bits in tcr.lisp-fpscr.
385(defarmlapfunction %set-fpscr-control ((new arg_z))
386  (unbox-fixnum imm0 new)
387  (and imm1 imm0 (:$ #xff00))
388  (str imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
389  (fmrx imm1 :fpscr)
390  (bic imm1 imm1 (:$ (ash 3 22)))
391  (and imm0 imm0 (:$ (ash 3 22)))
392  (orr imm0 imm1 imm0)
393  (fmxr :fpscr imm0)
394  (bx lr))
395
396(defarmlapfunction %get-fpscr ()
397  (fmrx imm0 :fpscr)
398  (bic imm0 imm0 (:$ #xff00))
399  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
400  (and imm1 imm1 (:$ #xff00))
401  (orr imm0 imm1 imm0)
402  (mov imm0 (:lsl imm0 (:$ 4)))
403  (mov arg_z (:lsr imm0 (:$ (- 4 arm::fixnumshift))))
404  (bx lr))
405
406(defun fp-condition-name-from-fpscr-status (status)
407  (cond
408    ((logbitp arm::ioc status) 'floating-point-invalid-operation)
409    ((logbitp arm::dzc status) 'division-by-zero)
410    ((logbitp arm::ofc status) 'floating-point-overflow)
411    ((logbitp arm::ufc status) 'floating-point-underflow)
412    ((logbitp arm::ixc status) 'floating-point-inexact)))
413     
414 
415#+notyet
416(progn
417
418; See if the binary double-float operation OP set any enabled
419; exception bits in the fpscr
420(defun %df-check-exception-2 (operation op0 op1 fp-status)
421  (declare (type (unsigned-byte 24) fp-status))
422  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
423    (%set-fpscr-status 0)
424    ;; Ensure that operands are heap-consed
425    (%fp-error-from-status fp-status 
426                           (%get-fpscr-control)
427                           operation 
428                           (%copy-double-float op0 (%make-dfloat)) 
429                           (%copy-double-float op1 (%make-dfloat)))))
430
431(defun %sf-check-exception-2 (operation op0 op1 fp-status)
432  (declare (type (unsigned-byte 24) fp-status))
433  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
434    (%set-fpscr-status 0)
435    ;; Ensure that operands are heap-consed
436    (%fp-error-from-status fp-status 
437                           (%get-fpscr-control)
438                           operation
439                           
440                           (%copy-short-float op0 (%make-sfloat))
441                           
442                           (%copy-short-float op1 (%make-sfloat)))))
443
444(defun %df-check-exception-1 (operation op0 fp-status)
445  (declare (fixnum fp-status))
446  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
447    (%set-fpscr-status 0)
448    ;; Ensure that operands are heap-consed
449    (%fp-error-from-status fp-status 
450                              (%get-fpscr-control)
451                              operation 
452                              (%copy-double-float op0 (%make-dfloat)))))
453
454(defun %sf-check-exception-1 (operation op0 fp-status)
455  (declare (type (unsigned-byte 24) fp-status))
456  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
457    (%set-fpscr-status 0)
458                                        ; Ensure that operands are heap-consed
459    (%fp-error-from-status fp-status 
460                           (%get-fpscr-control)
461                           operation
462                           
463                           (%copy-short-float op0 (%make-sfloat)))))
464
465
466(defun fp-condition-from-fpscr (status-bits control-bits)
467  (declare (fixnum status-bits control-bits))
468  (cond 
469   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
470         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
471    'floating-point-invalid-operation)
472   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
473         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
474    'floating-point-overflow)
475   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
476         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
477    'floating-point-underflow)
478   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
479         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
480    'division-by-zero)
481   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
482         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
483    'floating-point-inexact)))
484
485;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
486(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
487  (declare (type (unsigned-byte 16) status-bits))
488  (case operation
489    (sqrt (setq operands (cdr operands))))
490  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
491    (if condition-class
492      (error (make-instance condition-class
493               :operation operation
494               :operands operands)))))
495
496(defun fp-minor-opcode-operation (minor-opcode)
497  (case minor-opcode
498    (25 '*)
499    (18 '/)
500    (20 '-)
501    (21 '+)
502    (22 'sqrt)
503    (t 'unknown)))
504
505);#+notyet
506
507;;; Don't we already have about 20 versions of this ?
508(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
509  (ldr imm0 (:@ ptr (:$ arm::macptr.address)))
510  (unbox-fixnum imm1 byte-offset)
511  (ldrd imm0  (:@ imm0 imm1))
512  (strd imm0 (:@ dest (:$ arm::double-float.value)))
513  (bx lr))
514
515
516#+notyet
517(progn
518(defvar *rounding-mode-alist*
519  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
520
521(defun get-fpu-mode (&optional (mode nil mode-p))
522  (let* ((flags (%get-fpscr-control)))
523    (declare (type (unsigned-byte 8) flags))
524    (if mode-p
525      (ecase mode
526        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
527        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
528        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
529        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
530        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
531        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
532      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
533        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
534        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
535        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
536        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
537        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
538
539;;; did we document this?
540(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
541                          (overflow t overflow-p)
542                          (underflow t underflow-p)
543                          (division-by-zero t zero-p)
544                          (invalid t invalid-p)
545                          (inexact t inexact-p))
546  (let* ((mask (logior (if rounding-p #x03 #x00)
547                       (if invalid-p
548                         (ash 1 (- 31 ppc::fpscr-ve-bit))
549                         #x00)
550                       (if overflow-p
551                         (ash 1 (- 31 ppc::fpscr-oe-bit))
552                         #x00)
553                       (if underflow-p
554                         (ash 1 (- 31 ppc::fpscr-ue-bit))
555                         #x00)
556                       (if zero-p
557                         (ash 1 (- 31 ppc::fpscr-ze-bit))
558                         #x00)
559                       (if inexact-p
560                         (ash 1 (- 31 ppc::fpscr-xe-bit))
561                         #x00)))
562         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
563                          (error "Unknown rounding mode: ~s" rounding-mode))
564                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
565                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
566                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
567                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
568                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
569    (declare (type (unsigned-byte 8) new mask))
570    (%set-fpscr-control (logior (logand new mask)
571                                (logandc2 (%get-fpscr-control) mask)))))
572)
573
574
575;;; Copy a single float pointed at by the macptr in single
576;;; to a double float pointed at by the macptr in double
577
578(defarmlapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
579  (check-nargs 2)
580  (macptr-ptr imm0 single)
581  (flds s0 (:@ imm0 (:$ 0)))
582  (fcvtds d1 s0)
583  (macptr-ptr imm0 double)
584  (fstd d1 (:@ imm0 (:$ 0)))
585  (bx lr))
586
587;;; Copy a double float pointed at by the macptr in double
588;;; to a single float pointed at by the macptr in single.
589(defarmlapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
590  (check-nargs 2)
591  (macptr-ptr imm0 double)
592  (fldd d0 (:@ imm0 (:$ 0)))
593  (macptr-ptr imm0 single)
594  (fcvtsd s2 d0)
595  (fsts s2 (:@  imm0 (:$ 0)))
596  (bx lr))
597
598
599(defarmlapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
600  (check-nargs 2)
601  (macptr-ptr imm0 macptr)
602  (get-double-float d1 src)
603  (fcvtsd s0 d1)
604  (fsts s0 (:@ imm0 (:$ 0)))
605  (bx lr))
606
607
608(defun host-single-float-from-unsigned-byte-32 (u32)
609  (let* ((f (%make-sfloat)))
610    (setf (uvref f arm::single-float.value-cell) u32)
611    f))
612
613
614
615
616
617(defun single-float-bits (f)
618  (uvref f arm::single-float.value-cell))
619
620
621
622(defun double-float-bits (f)
623  (values (uvref f arm::double-float.val-high-cell)
624          (uvref f arm::double-float.val-low-cell)))
625
626(defun double-float-from-bits (high low)
627  (let* ((f (%make-dfloat)))
628    (setf (uvref f arm::double-float.val-high-cell) high
629          (uvref f arm::double-float.val-low-cell) low)
630    f))
631
632(defarmlapfunction %double-float-sign ((n arg_z))
633  (ldr imm0 (:@ n (:$ arm::double-float.val-high)))
634  (cmp imm0 ($ 0))
635  (mov arg_z 'nil)
636  (addlt arg_z arg_z (:$ arm::t-offset))
637  (bx lr))
638
639(defarmlapfunction %short-float-sign ((n arg_z))
640  (ldr imm0 (:@ n (:$ arm::single-float.value)))
641  (cmp imm0 ($ 0))
642  (mov arg_z 'nil)
643  (addlt arg_z arg_z (:$ arm::t-offset))
644  (bx lr))
645
646(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
647  (get-single-float s0 src imm0)
648  (fsqrts s1 s0)
649  (put-single-float s1 dest imm0)
650  (bx lr))
651
652
653
654(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
655  (get-double-float d0 src)
656  (fsqrtd d1 d0)
657  (put-double-float d1 dest)
658  (bx lr))
659
660
Note: See TracBrowser for help on using the repository browser.