source: trunk/source/level-0/ARM/arm-float.lisp @ 15601

Last change on this file since 15601 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

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  (vpush1 temp1)  ; exp
113  (vpush1 temp0)  ; sign
114  (set-nargs 4)
115  (add temp0 vsp '4)
116  (spjump .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  (sploadlr .SPcheck-fpu-exception)
538  (blx lr)
539  (put-single-float s1 dest imm0)
540  (return-lisp-frame))
541
542
543
544(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
545  (build-lisp-frame)
546  (get-double-float d0 src)
547  (fmrx imm0 :fpscr)
548  (bic imm0 imm0 (:$ #xff))
549  (fmxr :fpscr imm0)
550  (fsqrtd d1 d0)
551  (sploadlr .SPcheck-fpu-exception)
552  (blx lr)
553  (put-double-float d1 dest)
554  (return-lisp-frame))
555
556
Note: See TracBrowser for help on using the repository browser.