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

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

arm-asm.lisp: had cs and cc condition names backwards. (not used very
often, I guess.) umull and umulls had the wrong opcode.

arm-bignum.lisp: %ADD-WITH-CARRY needs to use adcs to propagate carry out.
Define %SUBTRACT-WITH-BORROW, fix %NORMALIZE-BIGNUM-2.

arm-float: implement, fix some things.

arm-numbers: steal %FIXNUM-GCD from Wikipedia.

l0-array.lisp: *IMMHEADER-ARRAY-TYPES*, *NODEHEADER-ARRAY-TYPES* for ARM.

arm-trap-support.lisp: started.

ffi-linuxarm.lisp: more plausible callback support.

ARM stuff for MACHINE-TYPE, HEAP-UTILIZATION.

arm-exceptions.c: callback glue functions return Boolean.

arm-exceptions.h: typos in opcode test macros.

arm-spentry.s: .SPeabi_callback.

File size: 17.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  (and imm0 sign (:$ #x80000000))  ; just leave sign bit
35  (ldr imm1 (:@ vsp (:$ hi)))
36  (orr imm0 imm0 (:lsl exp (:$ (- 20 arm::fixnumshift)))) ;  exp left 20 right 2 keep 11 bits
37  (unbox-fixnum imm1 imm1)
38  (orr imm0 imm0 (:lsr imm1 (:$ 4)))
39  (and imm1 imm1 (:$ #xf0000000))
40  (orr imm1 imm1 (:lsr lo (:$ arm::fixnumshift)))
41  (ldr temp0 (:@ vsp (:$ float)))         ; the float
42  (str imm0 (:@ temp0 (:$ arm::double-float.val-high)))
43  (str imm1 (:@ temp0 (:$ arm::double-float.val-low)))
44  (add vsp vsp '2)
45  (bx lr))
46
47
48(defarmlapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z))
49  (unbox-fixnum imm0 sig)
50  (and imm1 sign (:$ #x800000000))
51  (orr imm0 imm0 (:lsl exp (:$ (- 23 arm::fixnumshift))))
52  (orr imm0 imm0 imm1)
53  (vpop1 arg_z)
54  (str imm0 (:@ arg_z (:$ arm::single-float.value)))
55  (bx lr))
56
57
58(defarmlapfunction %%double-float-abs! ((n arg_y)(val arg_z))
59  (get-double-float d0 n)
60  (fabsd d1 d0)
61  (put-double-float d1 val)
62  (bx lr))
63
64(defarmlapfunction %%short-float-abs! ((n arg_y) (val arg_z))
65  (get-single-float s1 n imm0)
66  (fabss s0 s1)
67  (put-single-float s0 val imm0)
68  (bx lr))
69
70
71
72(defarmlapfunction %double-float-negate! ((src arg_y) (res arg_z))
73  (get-double-float d0 src)
74  (fnegd d1 d0)
75  (put-double-float d1 res)
76  (bx lr))
77
78(defarmlapfunction %short-float-negate! ((src arg_y) (res arg_z))
79  (get-single-float s0 src imm0)
80  (fnegs s1 s0)
81  (put-single-float s1 res imm0)
82  (bx lr))
83
84
85
86
87;;; rets hi (25 bits) lo (28 bits) exp sign
88#+later
89(defarmlapfunction %integer-decode-double-float ((n arg_z))
90  (ldr imm0  (:@ n (:$ arm::double-float.value)))
91  (rlwinm imm1 imm0 (+ 1 arm::fixnumshift) (- 32 arm::fixnumshift 1) ; sign boxed
92                                           (- 32 arm::fixnumshift 1))
93  (add imm1 imm1 imm1)  ; imm1 = (fixnum 2) (neg) or 0 (pos)
94  (subfic temp0 imm1 '1)  ; sign boxed
95  (rlwinm. imm2 imm0 (- 32 20)  21  31)   ; right 20, keep 11 bits exp - test for 0
96  ;(subi imm2 imm2 (+ 53 1022))            ; unbias and scale
97  (slwi imm2 imm2 arm::fixnumshift)      ; box
98  (mr temp1 imm2)                        ; boxed unbiased exponent
99  (rlwinm imm0 imm0 12  0 19)            ; 20 bits of hi float left 12
100  (beq @denorm)                          ; cr set way back
101  (addi imm0 imm0 1)                     ;  add implied 1
102  @denorm
103  (rlwinm imm0 imm0 (+ (- 32 12) 4 arm::fixnumshift) 0 31)
104  (ldr imm1 (:@ n (:$ arm::double-float.val-low))) ;
105  (rlwimi imm0 imm1 (+ 4 arm::fixnumshift)
106                    (1+ (- 31 4 arm::fixnumshift))
107                    (- 31 arm::fixnumshift))  ; high 4 bits in fixnum pos
108  (rlwinm imm1 imm1 (- 4 arm::fixnumshift) 
109                    (- 4 arm::fixnumshift)
110                    (- 31 arm::fixnum-shift)) ; 28 bits  thats 2 2 29
111  (vpush imm0)   ; hi 25 bits of mantissa (includes implied 1)
112  (vpush imm1)   ; lo 28 bits of mantissa
113  (vpush temp1)  ; exp
114  (vpush temp0)  ; sign
115  (set-nargs 4)
116  (la temp0 '4 vsp)
117  (ba .SPvalues))
118
119
120;;; hi is 25 bits lo is 28 bits
121;;; big is 32 lo, 21 hi right justified
122
123#+later
124(defarmlapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z))
125  (rlwinm imm0 lo (- 32 arm::fixnumshift) 4 31)
126  (rlwimi imm0 hi (- 32 4 arm::fixnumshift) 0 3)
127  (stw imm0 (+ arm::misc-data-offset 0) big)   ; low goes in 1st wd
128  (rlwinm imm0 hi (- 32 (+ arm::fixnumshift 4)) 11 31)  ; high in second
129  (stw imm0 (+ arm::misc-data-offset 4) big)
130  (bx lr))
131
132
133#+later
134(defarmlapfunction dfloat-significand-zeros ((dfloat arg_z))
135  (ldr imm1 (:@ dfloat (:$ arm::double-float.value)))
136  (rlwinm. imm1 imm1 12 0 19)
137  (cntlzw imm1 imm1)
138  (beq @golo)
139  (box-fixnum arg_z imm1)
140  (bx lr)
141  @golo
142  (ldr imm1 (:@ dfloat (:$ arm::double-float.val-low)))
143  (cntlzw imm1 imm1)
144  (addi imm1 imm1 20)
145  (box-fixnum arg_z imm1)
146  (bx lr))
147
148#+later
149(defarmlapfunction sfloat-significand-zeros ((sfloat arg_z))
150   (ldr imm1 (:@ sfloat (:$ arm::single-float.value)))
151  (rlwinm imm1 imm1 9 0 22)
152  (cntlzw imm1 imm1)
153  (box-fixnum arg_z imm1)
154  (bx lr))
155
156
157
158(defarmlapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
159  (unbox-fixnum imm2 int)               ;imm0/imm1 needed for ldrd, etc.
160  (get-double-float d0 float)
161  (mov temp0 (:$ 0))
162  (mov imm2 (:lsl imm2 (:$ (- ieee-double-float-exponent-offset 32))))
163  (fmdrr d1 temp0 imm2)
164  (fmuld d0 d1 d0)
165  (put-double-float d0 result)
166  (bx lr))
167
168
169
170(defarmlapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z))
171  (ldr imm1 (:@ float (:$ arm::single-float.value)))
172  (mov imm0 (:lsl int (:$ (- IEEE-single-float-exponent-offset arm::fixnumshift))))
173  (fmsr s0 imm1)
174  (fmsr s2 imm0)
175  (fmuls s0 s0 s2)
176  (fmrs imm0 s0)
177  (str imm0 (:@ result (:$ arm::single-float.value)))
178  (bx lr))
179                   
180
181
182
183(defarmlapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
184  (ldrd imm0 (:@ f1 (:$ arm::double-float.value)))
185  (strd imm0 (:@ f2 (:$ arm::double-float.value)))
186  (bx lr))
187                   
188
189
190(defarmlapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
191  (ldr imm0 (:@ f1 (:$ arm::single-float.value)))
192  (str imm0 (:@ f2 (:$ arm::single-float.value)))
193  (bx lr))
194
195
196(defarmlapfunction %double-float-exp ((n arg_z))
197  (ldr imm1 (:@ n (:$ arm::double-float.val-high)))
198  (mov imm1 (:lsl imm1 (:$ 1)))
199  (mov imm1 (:lsr imm1 (:$ (1+ (- ieee-double-float-exponent-offset 32)))))
200  (box-fixnum arg_z imm1)
201  (bx lr))
202
203
204
205
206(defarmlapfunction set-%double-float-exp ((float arg_y) (exp arg_z))
207  (ldr imm1 (:@ float (:$ arm::double-float.val-high)))
208  (mov imm0 (:$ #xff000000))
209  (orr imm0 imm0 (:$ #x00e00000))
210  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
211  (and imm0 imm0 (:lsl exp (:$ (- 21 arm::fixnumshift))))
212  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
213  (str imm1 (:@ float (:$ arm::double-float.val-high))) ; hdr - tag = 8 - 2
214  (bx lr))
215
216
217
218
219(defarmlapfunction %short-float-exp ((n arg_z))
220  (ldr imm1 (:@ n (:$ arm::single-float.value)))
221  (mov imm1 (:lsl imm1 (:$ 1)))
222  (mov imm1 (:lsr imm1 (:$ (1+ ieee-single-float-exponent-offset))))
223  (box-fixnum arg_z imm1)
224  (bx lr))
225
226
227
228
229(defarmlapfunction set-%short-float-exp ((float arg_y) (exp arg_z))
230  (ldr imm1 (:@ float (:$ arm::single-float.value)))
231  (mov imm0 (:$ #xff000000))
232  (mvn imm0 (:lsr imm0 (:$ 1)))
233  (and imm1 imm1 imm0)
234  (orr imm1 imm1 (:lsl exp (:$ (- ieee-single-float-exponent-offset arm::fixnumshift))))
235  (str imm1 (:@ float (:$ arm::single-float.value)))
236  (bx lr))
237
238 
239(defarmlapfunction %short-float->double-float ((src arg_y) (result arg_z))
240  (get-single-float s0 src imm0)
241  (fcvtds d1 s0)
242  (put-double-float d1 result)
243  (bx lr))
244
245
246(defarmlapfunction %double-float->short-float ((src arg_y) (result arg_z))
247  ;(clear-fpu-exceptions)
248  (get-double-float d0 src)
249  (fcvtsd s1 d0)
250  (put-single-float s1 result imm0)
251  (bx lr))
252
253
254 
255
256
257
258(defarmlapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
259  (unbox-fixnum imm0 int)
260  (fmsr s0 imm0)
261  (fsitos s1 s0)
262  (put-single-float s1 sfloat imm0)
263  (bx lr))
264
265
266 
267
268(defarmlapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
269  (unbox-fixnum imm0 int)
270  (fmsr s0 imm0)
271  (fsitod d1 s0)
272  (put-double-float d1 dfloat)
273  (bx lr))
274
275(defarmlapfunction %ffi-exception-status ()
276  (mov arg_z (:$ 0))                    ;for now
277  (bx lr))
278
279(defun %sf-check-exception-1 (operation op0 fp-status)
280  (declare (ignore operation op0 fp-status)))
281
282
283
284#+notyet
285(progn
286; Manipulating the FPSCR.
287; This  returns the bottom 8 bits of the FPSCR
288(defarmlapfunction %get-fpscr-control ()
289  (mffs fp0)
290  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
291  (lbz imm0 (+ arm::tcr.lisp-fpscr-high 7) arm::rcontext)
292  (box-fixnum arg_z imm0)
293  (bx lr))
294
295; Returns the high 24 bits of the FPSCR
296(defarmlapfunction %get-fpscr-status ()
297  (mffs fp0)
298  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
299  (ldr imm0 (:@ tsp (:$ arm::tcr.lisp-fpscr-low)))
300  (clrrwi imm0 imm0 8)
301  (srwi arg_z imm0 (- 8 arm::fixnumshift))
302  (bx lr))
303
304; Set the high 24 bits of the FPSCR; leave the low 8 unchanged
305(defarmlapfunction %set-fpscr-status ((new arg_z))
306  (slwi imm0 new (- 8 arm::fixnumshift))
307  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
308  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
309  (mtfsf #xfc fp0)                      ; set status fields [0-5]
310  (bx lr))
311
312; Set the low 8 bits of the FPSCR.  Zero the upper 24 bits
313(defarmlapfunction %set-fpscr-control ((new arg_z))
314  (unbox-fixnum imm0 new)
315  (clrlwi imm0 imm0 24)                 ; ensure that "status" fields are clear
316  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
317  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
318  (mtfsf #xff fp0)                      ; set all fields [0-7]
319  (bx lr))
320
321
322
323 
324
325; See if the binary double-float operation OP set any enabled
326; exception bits in the fpscr
327(defun %df-check-exception-2 (operation op0 op1 fp-status)
328  (declare (type (unsigned-byte 24) fp-status))
329  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
330    (%set-fpscr-status 0)
331    ;; Ensure that operands are heap-consed
332    (%fp-error-from-status fp-status 
333                           (%get-fpscr-control)
334                           operation 
335                           (%copy-double-float op0 (%make-dfloat)) 
336                           (%copy-double-float op1 (%make-dfloat)))))
337
338(defun %sf-check-exception-2 (operation op0 op1 fp-status)
339  (declare (type (unsigned-byte 24) fp-status))
340  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
341    (%set-fpscr-status 0)
342    ;; Ensure that operands are heap-consed
343    (%fp-error-from-status fp-status 
344                           (%get-fpscr-control)
345                           operation
346                           
347                           (%copy-short-float op0 (%make-sfloat))
348                           
349                           (%copy-short-float op1 (%make-sfloat)))))
350
351(defun %df-check-exception-1 (operation op0 fp-status)
352  (declare (fixnum fp-status))
353  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
354    (%set-fpscr-status 0)
355    ;; Ensure that operands are heap-consed
356    (%fp-error-from-status fp-status 
357                              (%get-fpscr-control)
358                              operation 
359                              (%copy-double-float op0 (%make-dfloat)))))
360
361(defun %sf-check-exception-1 (operation op0 fp-status)
362  (declare (type (unsigned-byte 24) fp-status))
363  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
364    (%set-fpscr-status 0)
365                                        ; Ensure that operands are heap-consed
366    (%fp-error-from-status fp-status 
367                           (%get-fpscr-control)
368                           operation
369                           
370                           (%copy-short-float op0 (%make-sfloat)))))
371
372
373(defun fp-condition-from-fpscr (status-bits control-bits)
374  (declare (fixnum status-bits control-bits))
375  (cond 
376   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
377         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
378    'floating-point-invalid-operation)
379   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
380         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
381    'floating-point-overflow)
382   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
383         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
384    'floating-point-underflow)
385   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
386         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
387    'division-by-zero)
388   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
389         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
390    'floating-point-inexact)))
391
392;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
393(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
394  (declare (type (unsigned-byte 16) status-bits))
395  (case operation
396    (sqrt (setq operands (cdr operands))))
397  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
398    (if condition-class
399      (error (make-instance condition-class
400               :operation operation
401               :operands operands)))))
402
403(defun fp-minor-opcode-operation (minor-opcode)
404  (case minor-opcode
405    (25 '*)
406    (18 '/)
407    (20 '-)
408    (21 '+)
409    (22 'sqrt)
410    (t 'unknown)))
411
412);#+notyet
413
414;;; Don't we already have about 20 versions of this ?
415(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
416  (ldr imm0 (:@ ptr (:$ arm::macptr.address)))
417  (unbox-fixnum imm1 byte-offset)
418  (ldrd imm0  (:@ imm0 imm1))
419  (strd imm0 (:@ dest (:$ arm::double-float.value)))
420  (bx lr))
421
422
423#+notyet
424(progn
425(defvar *rounding-mode-alist*
426  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
427
428(defun get-fpu-mode (&optional (mode nil mode-p))
429  (let* ((flags (%get-fpscr-control)))
430    (declare (type (unsigned-byte 8) flags))
431    (if mode-p
432      (ecase mode
433        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
434        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
435        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
436        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
437        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
438        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
439      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
440        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
441        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
442        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
443        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
444        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
445
446;;; did we document this?
447(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
448                          (overflow t overflow-p)
449                          (underflow t underflow-p)
450                          (division-by-zero t zero-p)
451                          (invalid t invalid-p)
452                          (inexact t inexact-p))
453  (let* ((mask (logior (if rounding-p #x03 #x00)
454                       (if invalid-p
455                         (ash 1 (- 31 ppc::fpscr-ve-bit))
456                         #x00)
457                       (if overflow-p
458                         (ash 1 (- 31 ppc::fpscr-oe-bit))
459                         #x00)
460                       (if underflow-p
461                         (ash 1 (- 31 ppc::fpscr-ue-bit))
462                         #x00)
463                       (if zero-p
464                         (ash 1 (- 31 ppc::fpscr-ze-bit))
465                         #x00)
466                       (if inexact-p
467                         (ash 1 (- 31 ppc::fpscr-xe-bit))
468                         #x00)))
469         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
470                          (error "Unknown rounding mode: ~s" rounding-mode))
471                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
472                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
473                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
474                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
475                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
476    (declare (type (unsigned-byte 8) new mask))
477    (%set-fpscr-control (logior (logand new mask)
478                                (logandc2 (%get-fpscr-control) mask)))))
479)
480
481
482;;; Copy a single float pointed at by the macptr in single
483;;; to a double float pointed at by the macptr in double
484
485(defarmlapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
486  (check-nargs 2)
487  (macptr-ptr imm0 single)
488  (flds s0 (:@ imm0 (:$ 0)))
489  (fcvtds d1 s0)
490  (macptr-ptr imm0 double)
491  (fstd d1 (:@ imm0 (:$ 0)))
492  (bx lr))
493
494;;; Copy a double float pointed at by the macptr in double
495;;; to a single float pointed at by the macptr in single.
496(defarmlapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
497  (check-nargs 2)
498  (macptr-ptr imm0 double)
499  (fldd d0 (:@ imm0 (:$ 0)))
500  (macptr-ptr imm0 single)
501  (fcvtsd s2 d0)
502  (fsts s2 (:@  imm0 (:$ 0)))
503  (bx lr))
504
505
506(defarmlapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
507  (check-nargs 2)
508  (macptr-ptr imm0 macptr)
509  (get-double-float d1 src)
510  (fcvtsd s0 d1)
511  (fsts s0 (:@ imm0 (:$ 0)))
512  (bx lr))
513
514
515(defun host-single-float-from-unsigned-byte-32 (u32)
516  (let* ((f (%make-sfloat)))
517    (setf (uvref f arm::single-float.value-cell) u32)
518    f))
519
520
521
522
523
524(defun single-float-bits (f)
525  (uvref f arm::single-float.value-cell))
526
527
528
529(defun double-float-bits (f)
530  (values (uvref f arm::double-float.val-high-cell)
531          (uvref f arm::double-float.val-low-cell)))
532
533(defun double-float-from-bits (high low)
534  (let* ((f (%make-dfloat)))
535    (setf (uvref f arm::double-float.val-high-cell) high
536          (uvref f arm::double-float.val-low-cell) low)
537    f))
538
539(defarmlapfunction %double-float-sign ((n arg_z))
540  (ldr imm0 (:@ n (:$ arm::double-float.val-high)))
541  (cmp imm0 ($ 0))
542  (mov arg_z 'nil)
543  (addlt arg_z arg_z (:$ arm::t-offset))
544  (bx lr))
545
546(defarmlapfunction %short-float-sign ((n arg_z))
547  (ldr imm0 (:@ n (:$ arm::single-float.value)))
548  (cmp imm0 ($ 0))
549  (mov arg_z 'nil)
550  (addlt arg_z arg_z (:$ arm::t-offset))
551  (bx lr))
552
553(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
554  (get-single-float s0 src imm0)
555  (fsqrts s1 s0)
556  (put-single-float s1 dest imm0)
557  (bx lr))
558
559
560
561(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
562  (get-double-float d0 src)
563  (fsqrtd d1 d0)
564  (put-double-float d1 dest)
565  (bx lr))
566
567
Note: See TracBrowser for help on using the repository browser.