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

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

New; at least half of the functions are #+notyet, but some aren't.

File size: 18.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#+later
33(defarmlapfunction %make-float-from-fixnums ((float 4)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z))
34  (rlwinm imm0 sign 0 0 0)  ; just leave sign bit
35  (rlwimi imm0 exp (- 20 arm::fixnumshift)  1 11) ;  exp left 20 right 2 keep 11 bits
36  (ldr imm1 (:@ vsp (:$ hi)))
37  (srawi imm1 imm1 arm::fixnumshift)   ; fold into below? nah keep for later
38  (rlwimi imm0 imm1 (- 32 4) 12 31)   ; right 4 - keep  20 - stuff into hi result
39  (rlwinm imm1 imm1 28 0 3)  ; hi goes left 28 - keep 4 hi bits
40  (rlwimi imm1 lo (- 32 arm::fixnumshift) 4 31) ; stuff in 28 bits of lo
41  (ldr temp0 (:@ vsp (:$ float)))         ; the float
42  (stw imm0 arm::double-float.value temp0)
43  (stw imm1 arm::double-float.val-low temp0)
44  (la vsp 8 vsp)
45  (blr))
46
47
48#+later
49(defarmlapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z))
50  (unbox-fixnum imm0 sig)
51  (rlwimi imm0 exp (- 29 8) 1 8)
52  (inslwi imm0 sign 1 0)
53  (vpop arg_z)
54  (stw imm0 arm::single-float.value arg_z)
55  (blr))
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#+later
159(defarmlapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
160  (let ((fl.h 8)
161        (fl.l 12)
162        (sc.h 16)
163        (sc.l 20))
164    (clear-fpu-exceptions)
165    (ldr imm0 (:@ float (:$ arm::double-float.value)))
166    (ldr imm1 (:@ float (:$ arm::double-float.val-low)))
167    (stwu tsp -24 tsp)
168    (stw tsp 4 tsp)
169    (stw imm0 fl.h tsp)
170    (stw imm1 fl.l tsp)
171    (unbox-fixnum imm0 int)
172    ;(addi imm0 imm0 1022)  ; bias exponent - we assume no ovf
173    (slwi imm0 imm0 20)     ; more important - get it in right place
174    (stw imm0 sc.h tsp)
175    (stw rzero sc.l tsp)
176    (lfd fp0 fl.h tsp)
177    (lfd fp1 sc.h tsp)
178    (ldr tsp (:@ tsp (:$ 0)))
179    (fmul fp2 fp0 fp1)
180    (stfd fp2 arm::double-float.value result)
181    (bx lr)))
182
183
184
185#+later
186(defarmlapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z))
187  (let ((sc.h 12))
188    (clear-fpu-exceptions)
189    (lfs fp0 arm::single-float.value float)
190    (unbox-fixnum imm0 int)
191    (slwi imm0 imm0 IEEE-single-float-exponent-offset)
192    (stwu tsp -16 tsp)
193    (stw tsp 4 tsp)
194    (stw imm0 sc.h tsp)
195    (lfs fp1 sc.h tsp)
196    (ldr tsp (:@ tsp (:$ 0)))
197    (fmuls fp2 fp0 fp1)
198    (stfs fp2 arm::single-float.value result)
199    (bx lr)))
200                   
201
202
203
204(defarmlapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
205  (ldrd imm0 (:@ f1 (:$ arm::double-float.value)))
206  (strd imm0 (:@ f2 (:$ arm::double-float.value)))
207  (bx lr))
208                   
209
210
211(defarmlapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
212  (ldr imm0 (:@ f1 (:$ arm::single-float.value)))
213  (str imm0 (:@ f2 (:$ arm::single-float.value)))
214  (bx lr))
215
216
217(defarmlapfunction %double-float-exp ((n arg_z))
218  (ldr imm1 (:@ n (:$ arm::double-float.val-high)))
219  (mov imm1 (:lsl imm1 (:$ 1)))
220  (mov imm1 (:lsr imm1 (:$ 21)))
221  (box-fixnum arg_z imm1)
222  (bx lr))
223
224
225
226
227(defarmlapfunction set-%double-float-exp ((float arg_y) (exp arg_z))
228  (ldr imm1 (:@ float (:$ arm::double-float.val-high)))
229  (mov imm0 (:$ #xff000000))
230  (orr imm0 imm0 (:$ #x00e00000))
231  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
232  (and imm0 imm0 (:lsl exp (:$ (- 21 arm::fixnumshift))))
233  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
234  (str imm1 (:@ float (:$ arm::double-float.val-high))) ; hdr - tag = 8 - 2
235  (bx lr))
236
237
238
239
240(defarmlapfunction %short-float-exp ((n arg_z))
241  (ldr imm1 (:@ n (:$ arm::single-float.value)))
242  (mov arg_z (:$ (ash #xff arm::fixnumshift)))
243  (and arg_z arg_z (:lsr imm1 (:$ (- 23 arm::fixnumshift))))
244  (bx lr))
245
246
247
248
249(defarmlapfunction set-%short-float-exp ((float arg_y) (exp arg_z))
250  (ldr imm1 (:@ float (:$ arm::single-float.value)))
251  (mov imm0 (:$ #xff000000))
252  (bic imm1 imm1 (:lsr imm0 (:$ 1)))
253  (and imm0 imm0 (:lsl exp (:$ (- 24 arm::fixnumshift))))
254  (orr imm1 imm1 (:lsr imm0 (:$ 1)))
255  (str imm1 (:@ float (:$ arm::single-float.value)))
256  (bx lr))
257
258 
259(defarmlapfunction %short-float->double-float ((src arg_y) (result arg_z))
260  (get-single-float s0 src imm0)
261  (fcvtds d1 s0)
262  (put-double-float d1 result)
263  (bx lr))
264
265
266(defarmlapfunction %double-float->short-float ((src arg_y) (result arg_z))
267  ;(clear-fpu-exceptions)
268  (get-double-float d0 src)
269  (fcvtsd s1 d0)
270  (put-single-float s1 result imm0)
271  (bx lr))
272
273
274 
275
276
277
278(defarmlapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
279  (unbox-fixnum imm0 int)
280  (fmsr s0 imm0)
281  (fsitos s1 s0)
282  (put-single-float s1 sfloat imm0)
283  (bx lr))
284
285
286 
287
288(defarmlapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
289  (unbox-fixnum imm0 int)
290  (fmsr s0 imm0)
291  (fsitod d1 s0)
292  (put-double-float d1 dfloat)
293  (bx lr))
294
295
296
297#+notyet
298(progn
299; Manipulating the FPSCR.
300; This  returns the bottom 8 bits of the FPSCR
301(defarmlapfunction %get-fpscr-control ()
302  (mffs fp0)
303  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
304  (lbz imm0 (+ arm::tcr.lisp-fpscr-high 7) arm::rcontext)
305  (box-fixnum arg_z imm0)
306  (bx lr))
307
308; Returns the high 24 bits of the FPSCR
309(defarmlapfunction %get-fpscr-status ()
310  (mffs fp0)
311  (stfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
312  (ldr imm0 (:@ tsp (:$ arm::tcr.lisp-fpscr-low)))
313  (clrrwi imm0 imm0 8)
314  (srwi arg_z imm0 (- 8 arm::fixnumshift))
315  (bx lr))
316
317; Set the high 24 bits of the FPSCR; leave the low 8 unchanged
318(defarmlapfunction %set-fpscr-status ((new arg_z))
319  (slwi imm0 new (- 8 arm::fixnumshift))
320  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
321  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
322  (mtfsf #xfc fp0)                      ; set status fields [0-5]
323  (bx lr))
324
325; Set the low 8 bits of the FPSCR.  Zero the upper 24 bits
326(defarmlapfunction %set-fpscr-control ((new arg_z))
327  (unbox-fixnum imm0 new)
328  (clrlwi imm0 imm0 24)                 ; ensure that "status" fields are clear
329  (stw imm0 arm::tcr.lisp-fpscr-low arm::rcontext)
330  (lfd fp0 arm::tcr.lisp-fpscr-high arm::rcontext)
331  (mtfsf #xff fp0)                      ; set all fields [0-7]
332  (bx lr))
333
334
335(defarmlapfunction %ffi-exception-status ()
336  (ldr imm0  arm::tcr.ffi-exception arm::rcontext)
337  (mtcrf #xfc imm0)
338  (mcrfs :cr6 :cr6)
339  (mcrfs :cr7 :cr7)
340  (crand ppc::fpscr-fex-bit ppc::fpscr-oe-bit ppc::fpscr-ox-bit)
341  (bt ppc::fpscr-fex-bit @set)
342  (crand ppc::fpscr-fex-bit ppc::fpscr-ve-bit ppc::fpscr-vx-bit)
343  (bt ppc::fpscr-fex-bit @set)
344  (crand ppc::fpscr-fex-bit ppc::fpscr-ue-bit ppc::fpscr-ux-bit)
345  (bt ppc::fpscr-fex-bit @set)
346  (crand ppc::fpscr-fex-bit ppc::fpscr-ze-bit ppc::fpscr-zx-bit)
347  (bt ppc::fpscr-fex-bit @set)
348  (crand ppc::fpscr-fex-bit ppc::fpscr-xe-bit ppc::fpscr-xx-bit)
349  (bf ppc::fpscr-fex-bit @ret)
350  @set
351  (oris imm0 imm0 #xc000)
352  @ret
353  (srwi arg_z imm0 (- 8 arm::fixnumshift))
354  (bx lr))
355 
356
357; See if the binary double-float operation OP set any enabled
358; exception bits in the fpscr
359(defun %df-check-exception-2 (operation op0 op1 fp-status)
360  (declare (type (unsigned-byte 24) fp-status))
361  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
362    (%set-fpscr-status 0)
363    ;; Ensure that operands are heap-consed
364    (%fp-error-from-status fp-status 
365                           (%get-fpscr-control)
366                           operation 
367                           (%copy-double-float op0 (%make-dfloat)) 
368                           (%copy-double-float op1 (%make-dfloat)))))
369
370(defun %sf-check-exception-2 (operation op0 op1 fp-status)
371  (declare (type (unsigned-byte 24) fp-status))
372  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
373    (%set-fpscr-status 0)
374    ;; Ensure that operands are heap-consed
375    (%fp-error-from-status fp-status 
376                           (%get-fpscr-control)
377                           operation
378                           
379                           (%copy-short-float op0 (%make-sfloat))
380                           
381                           (%copy-short-float op1 (%make-sfloat)))))
382
383(defun %df-check-exception-1 (operation op0 fp-status)
384  (declare (fixnum fp-status))
385  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
386    (%set-fpscr-status 0)
387    ;; Ensure that operands are heap-consed
388    (%fp-error-from-status fp-status 
389                              (%get-fpscr-control)
390                              operation 
391                              (%copy-double-float op0 (%make-dfloat)))))
392
393(defun %sf-check-exception-1 (operation op0 fp-status)
394  (declare (type (unsigned-byte 24) fp-status))
395  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
396    (%set-fpscr-status 0)
397                                        ; Ensure that operands are heap-consed
398    (%fp-error-from-status fp-status 
399                           (%get-fpscr-control)
400                           operation
401                           
402                           (%copy-short-float op0 (%make-sfloat)))))
403
404
405(defun fp-condition-from-fpscr (status-bits control-bits)
406  (declare (fixnum status-bits control-bits))
407  (cond 
408   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
409         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
410    'floating-point-invalid-operation)
411   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
412         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
413    'floating-point-overflow)
414   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
415         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
416    'floating-point-underflow)
417   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
418         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
419    'division-by-zero)
420   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
421         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
422    'floating-point-inexact)))
423
424;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
425(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
426  (declare (type (unsigned-byte 16) status-bits))
427  (case operation
428    (sqrt (setq operands (cdr operands))))
429  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
430    (if condition-class
431      (error (make-instance condition-class
432               :operation operation
433               :operands operands)))))
434
435(defun fp-minor-opcode-operation (minor-opcode)
436  (case minor-opcode
437    (25 '*)
438    (18 '/)
439    (20 '-)
440    (21 '+)
441    (22 'sqrt)
442    (t 'unknown)))
443
444);#+notyet
445
446;;; Don't we already have about 20 versions of this ?
447(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
448  (ldr imm0 (:@ ptr (:$ arm::macptr.address)))
449  (unbox-fixnum imm1 byte-offset)
450  (ldrd imm0  (:@ imm0 imm1))
451  (strd imm0 (:@ dest (:$ arm::double-float.value)))
452  (bx lr))
453
454
455#+notyet
456(progn
457(defvar *rounding-mode-alist*
458  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
459
460(defun get-fpu-mode (&optional (mode nil mode-p))
461  (let* ((flags (%get-fpscr-control)))
462    (declare (type (unsigned-byte 8) flags))
463    (if mode-p
464      (ecase mode
465        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
466        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
467        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
468        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
469        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
470        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
471      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
472        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
473        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
474        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
475        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
476        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
477
478;;; did we document this?
479(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
480                          (overflow t overflow-p)
481                          (underflow t underflow-p)
482                          (division-by-zero t zero-p)
483                          (invalid t invalid-p)
484                          (inexact t inexact-p))
485  (let* ((mask (logior (if rounding-p #x03 #x00)
486                       (if invalid-p
487                         (ash 1 (- 31 ppc::fpscr-ve-bit))
488                         #x00)
489                       (if overflow-p
490                         (ash 1 (- 31 ppc::fpscr-oe-bit))
491                         #x00)
492                       (if underflow-p
493                         (ash 1 (- 31 ppc::fpscr-ue-bit))
494                         #x00)
495                       (if zero-p
496                         (ash 1 (- 31 ppc::fpscr-ze-bit))
497                         #x00)
498                       (if inexact-p
499                         (ash 1 (- 31 ppc::fpscr-xe-bit))
500                         #x00)))
501         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
502                          (error "Unknown rounding mode: ~s" rounding-mode))
503                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
504                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
505                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
506                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
507                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
508    (declare (type (unsigned-byte 8) new mask))
509    (%set-fpscr-control (logior (logand new mask)
510                                (logandc2 (%get-fpscr-control) mask)))))
511)
512
513
514;;; Copy a single float pointed at by the macptr in single
515;;; to a double float pointed at by the macptr in double
516
517(defarmlapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
518  (check-nargs 2)
519  (macptr-ptr imm0 single)
520  (flds s0 (:@ imm0 (:$ 0)))
521  (fcvtds d1 s0)
522  (macptr-ptr imm0 double)
523  (fstd d1 (:@ imm0 (:$ 0)))
524  (bx lr))
525
526;;; Copy a double float pointed at by the macptr in double
527;;; to a single float pointed at by the macptr in single.
528(defarmlapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
529  (check-nargs 2)
530  (macptr-ptr imm0 double)
531  (fldd d0 (:@ imm0 (:$ 0)))
532  (macptr-ptr imm0 single)
533  (fcvtsd s2 d0)
534  (fsts s2 (:@  imm0 (:$ 0)))
535  (bx lr))
536
537
538(defarmlapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
539  (check-nargs 2)
540  (macptr-ptr imm0 macptr)
541  (get-double-float d1 src)
542  (fcvtsd s0 d1)
543  (fsts s0 (:@ imm0 (:$ 0)))
544  (bx lr))
545
546
547(defun host-single-float-from-unsigned-byte-32 (u32)
548  (let* ((f (%make-sfloat)))
549    (setf (uvref f arm::single-float.value-cell) u32)
550    f))
551
552
553
554
555
556(defun single-float-bits (f)
557  (uvref f arm::single-float.value-cell))
558
559
560
561(defun double-float-bits (f)
562  (values (uvref f arm::double-float.val-high-cell)
563          (uvref f arm::double-float.val-low-cell)))
564
565(defun double-float-from-bits (high low)
566  (let* ((f (%make-dfloat)))
567    (setf (uvref f arm::double-float.val-high-cell) high
568          (uvref f arm::double-float.val-low-cell) low)
569    f))
570
571(defarmlapfunction %double-float-sign ((n arg_z))
572  (ldr imm0 (:@ n (:$ arm::double-float.val-high)))
573  (cmp imm0 '($ 0))
574  (mov arg_z 'nil)
575  (addlt arg_z arg_z (:$ arm::t-offset))
576  (bx lr))
577
578(defarmlapfunction %short-float-sign ((n arg_z))
579  (ldr imm0 (:@ n (:$ arm::single-float.value)))
580  (cmp imm0 '($ 0))
581  (mov arg_z 'nil)
582  (addlt arg_z arg_z (:$ arm::t-offset))
583  (bx lr))
584
585(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
586  (get-single-float s0 src imm0)
587  (fsqrts s1 s0)
588  (put-single-float s1 dest imm0)
589  (bx lr))
590
591
592
593(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
594  (get-double-float d0 src)
595  (fsqrtd d1 d0)
596  (put-double-float d1 dest)
597  (bx lr))
598
599
Note: See TracBrowser for help on using the repository browser.