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 | (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 | (bl .SPcheck-fpu-exception) |
---|
538 | (put-single-float s1 dest imm0) |
---|
539 | (return-lisp-frame)) |
---|
540 | |
---|
541 | |
---|
542 | |
---|
543 | (defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z)) |
---|
544 | (build-lisp-frame) |
---|
545 | (get-double-float d0 src) |
---|
546 | (fmrx imm0 fpscr) |
---|
547 | (bic imm0 imm0 (:$ #xff)) |
---|
548 | (fmxr fpscr imm0) |
---|
549 | (fsqrtd d1 d0) |
---|
550 | (bl .SPcheck-fpu-exception) |
---|
551 | (put-double-float d1 dest) |
---|
552 | (return-lisp-frame)) |
---|
553 | |
---|
554 | |
---|