source: trunk/source/level-0/PPC/ppc-float.lisp @ 12338

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

Word-size issues in PPC %FFI-EXCEPTION-STATUS.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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#+ppc32-target
33(defppclapfunction %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 ppc32::fixnumshift)  1 11) ;  exp left 20 right 2 keep 11 bits
36  (lwz imm1 hi vsp)
37  (srawi imm1 imm1 ppc32::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 ppc32::fixnumshift) 4 31) ; stuff in 28 bits of lo
41  (lwz temp0 float vsp)         ; the float
42  (stw imm0 ppc32::double-float.value temp0)
43  (stw imm1 ppc32::double-float.val-low temp0)
44  (la vsp 8 vsp)
45  (blr))
46
47#+ppc64-target
48(defppclapfunction %make-float-from-fixnums ((float 8)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z))
49  (rlwinm imm0 sign 0 0 0)  ; just leave sign bit
50  (rlwimi imm0 exp (- 20 ppc64::fixnumshift)  1 11) ;  exp left 20 right 2 keep 11 bits
51  (ld imm1 hi vsp)
52  (srawi imm1 imm1 ppc64::fixnumshift)   ; fold into below? nah keep for later
53  (rlwimi imm0 imm1 (- 32 4) 12 31)   ; right 4 - keep  20 - stuff into hi result
54  (rlwinm imm1 imm1 28 0 3)  ; hi goes left 28 - keep 4 hi bits
55  (rlwimi imm1 lo (- 32 ppc64::fixnumshift) 4 31) ; stuff in 28 bits of lo
56  (ld temp0 float vsp)         ; the float
57  (stw imm0 ppc64::double-float.value temp0)
58  (stw imm1 ppc64::double-float.val-low temp0)
59  (la vsp '2 vsp)
60  (blr))
61
62#+ppc32-target
63(defppclapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z))
64  (unbox-fixnum imm0 sig)
65  (rlwimi imm0 exp (- 29 8) 1 8)
66  (inslwi imm0 sign 1 0)
67  (vpop arg_z)
68  (stw imm0 ppc32::single-float.value arg_z)
69  (blr))
70
71
72(defppclapfunction %%double-float-abs! ((n arg_y)(val arg_z))
73  (get-double-float fp1 n)
74  (fabs fp1 fp1)
75  (put-double-float fp1 val)
76  (blr))
77
78#+ppc32-target
79(defppclapfunction %%short-float-abs! ((n arg_y) (val arg_z))
80  (get-single-float fp1 n)
81  (fabs fp0 fp1)
82  (put-single-float fp0 val)
83  (blr))
84
85#+ppc64-target
86(defppclapfunction %short-float-abs ((n arg_z))
87  (get-single-float fp1 n)
88  (fabs fp0 fp1)
89  (put-single-float fp0 arg_z)
90  (blr))
91
92(defppclapfunction %double-float-negate! ((src arg_y) (res arg_z))
93  (get-double-float fp0 src)
94  (fneg fp1 fp0)
95  (put-double-float fp1 res)
96  (blr))
97
98#+ppc32-target
99(defppclapfunction %short-float-negate! ((src arg_y) (res arg_z))
100  (get-single-float fp0 src)
101  (fneg fp1 fp0)
102  (put-single-float fp1 res)
103  (blr))
104
105#+ppc64-target
106;;; Non-destructive.
107(defppclapfunction %short-float-negate ((src arg_z))
108  (get-single-float fp0 src)
109  (fneg fp1 fp0)
110  (put-single-float fp1 arg_z)
111  (blr))
112
113
114;;; rets hi (25 bits) lo (28 bits) exp sign
115#+ppc32-target
116(defppclapfunction %integer-decode-double-float ((n arg_z))
117  (lwz imm0  ppc32::double-float.value n)
118  (rlwinm imm1 imm0 (+ 1 ppc32::fixnumshift) (- 32 ppc32::fixnumshift 1) ; sign boxed
119                                           (- 32 ppc32::fixnumshift 1))
120  (add imm1 imm1 imm1)  ; imm1 = (fixnum 2) (neg) or 0 (pos)
121  (subfic temp0 imm1 '1)  ; sign boxed
122  (rlwinm. imm2 imm0 (- 32 20)  21  31)   ; right 20, keep 11 bits exp - test for 0
123  ;(subi imm2 imm2 (+ 53 1022))            ; unbias and scale
124  (slwi imm2 imm2 ppc32::fixnumshift)      ; box
125  (mr temp1 imm2)                        ; boxed unbiased exponent
126  (rlwinm imm0 imm0 12  0 19)            ; 20 bits of hi float left 12
127  (beq @denorm)                          ; cr set way back
128  (addi imm0 imm0 1)                     ;  add implied 1
129  @denorm
130  (rlwinm imm0 imm0 (+ (- 32 12) 4 ppc32::fixnumshift) 0 31)
131  (lwz imm1 ppc32::double-float.val-low n) ;
132  (rlwimi imm0 imm1 (+ 4 ppc32::fixnumshift)
133                    (1+ (- 31 4 ppc32::fixnumshift))
134                    (- 31 ppc32::fixnumshift))  ; high 4 bits in fixnum pos
135  (rlwinm imm1 imm1 (- 4 ppc32::fixnumshift) 
136                    (- 4 ppc32::fixnumshift)
137                    (- 31 ppc32::fixnum-shift)) ; 28 bits  thats 2 2 29
138  (vpush imm0)   ; hi 25 bits of mantissa (includes implied 1)
139  (vpush imm1)   ; lo 28 bits of mantissa
140  (vpush temp1)  ; exp
141  (vpush temp0)  ; sign
142  (set-nargs 4)
143  (la temp0 '4 vsp)
144  (ba .SPvalues))
145
146
147;;; hi is 25 bits lo is 28 bits
148;;; big is 32 lo, 21 hi right justified
149#+ppc32-target
150(defppclapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z))
151  (rlwinm imm0 lo (- 32 ppc32::fixnumshift) 4 31)
152  (rlwimi imm0 hi (- 32 4 ppc32::fixnumshift) 0 3)
153  (stw imm0 (+ ppc32::misc-data-offset 0) big)   ; low goes in 1st wd
154  (rlwinm imm0 hi (- 32 (+ ppc32::fixnumshift 4)) 11 31)  ; high in second
155  (stw imm0 (+ ppc32::misc-data-offset 4) big)
156  (blr))
157
158
159
160(defppclapfunction dfloat-significand-zeros ((dfloat arg_z))
161  (lwz imm1 target::double-float.value dfloat)
162  (rlwinm. imm1 imm1 12 0 19)
163  (cntlzw imm1 imm1)
164  (beq @golo)
165  (box-fixnum arg_z imm1)
166  (blr)
167  @golo
168  (lwz imm1 target::double-float.val-low dfloat)
169  (cntlzw imm1 imm1)
170  (addi imm1 imm1 20)
171  (box-fixnum arg_z imm1)
172  (blr))
173
174(defppclapfunction sfloat-significand-zeros ((sfloat arg_z))
175  #+ppc32-target (lwz imm1 ppc32::single-float.value sfloat)
176  #+ppc64-target (srdi imm1 sfloat 32)
177  (rlwinm imm1 imm1 9 0 22)
178  (cntlzw imm1 imm1)
179  (box-fixnum arg_z imm1)
180  (blr))
181
182
183
184#+ppc32-target
185(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
186  (let ((fl.h 8)
187        (fl.l 12)
188        (sc.h 16)
189        (sc.l 20))
190    (clear-fpu-exceptions)
191    (lwz imm0 ppc32::double-float.value float)
192    (lwz imm1 ppc32::double-float.val-low float)
193    (stwu tsp -24 tsp)
194    (stw tsp 4 tsp)
195    (stw imm0 fl.h tsp)
196    (stw imm1 fl.l tsp)
197    (unbox-fixnum imm0 int)
198    ;(addi imm0 imm0 1022)  ; bias exponent - we assume no ovf
199    (slwi imm0 imm0 20)     ; more important - get it in right place
200    (stw imm0 sc.h tsp)
201    (stw rzero sc.l tsp)
202    (lfd fp0 fl.h tsp)
203    (lfd fp1 sc.h tsp)
204    (lwz tsp 0 tsp)
205    (fmul fp2 fp0 fp1)
206    (stfd fp2 ppc32::double-float.value result)
207    (blr)))
208
209#+ppc64-target
210(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
211  (let ((fl.h 16)
212        (fl.l 20)
213        (sc.h 24)
214        (sc.l 28))
215    (clear-fpu-exceptions)
216    (lwz imm0 ppc64::double-float.value float)
217    (lwz imm1 ppc64::double-float.val-low float)
218    (stdu tsp -32 tsp)
219    (std tsp 8 tsp)
220    (stw imm0 fl.h tsp)
221    (stw imm1 fl.l tsp)
222    (unbox-fixnum imm0 int)
223    ;(addi imm0 imm0 1022)  ; bias exponent - we assume no ovf
224    (slwi imm0 imm0 20)     ; more important - get it in right place
225    (stw imm0 sc.h tsp)
226    (stw rzero sc.l tsp)
227    (lfd fp0 fl.h tsp)
228    (lfd fp1 sc.h tsp)
229    (la tsp 32 tsp)
230    (fmul fp2 fp0 fp1)
231    (stfd fp2 ppc64::double-float.value result)
232    (blr)))
233
234#+ppc32-target
235(defppclapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z))
236  (let ((sc.h 12))
237    (clear-fpu-exceptions)
238    (lfs fp0 ppc32::single-float.value float)
239    (unbox-fixnum imm0 int)
240    (slwi imm0 imm0 IEEE-single-float-exponent-offset)
241    (stwu tsp -16 tsp)
242    (stw tsp 4 tsp)
243    (stw imm0 sc.h tsp)
244    (lfs fp1 sc.h tsp)
245    (lwz tsp 0 tsp)
246    (fmuls fp2 fp0 fp1)
247    (stfs fp2 ppc32::single-float.value result)
248    (blr)))
249                   
250
251#+ppc64-target
252(defppclapfunction %%scale-sfloat! ((float arg_y)(int arg_z))
253  (let ((sc.h 16))
254    (clear-fpu-exceptions)
255    (get-single-float fp0 float)
256    (unbox-fixnum imm0 int)
257    (slwi imm0 imm0 IEEE-single-float-exponent-offset)
258    (stwu tsp -32 tsp)
259    (stw tsp 8 tsp)
260    (stw imm0 sc.h tsp)
261    (lfs fp1 sc.h tsp)
262    (la tsp 32 tsp)
263    (fmuls fp2 fp0 fp1)
264    (put-single-float fp2 arg_z)
265    (blr)))
266
267(defppclapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
268  (lfd fp0 target::double-float.value f1)
269  (stfd fp0 target::double-float.value f2)
270  (blr))
271                   
272
273#+ppc32-target
274(defppclapfunction %copy-short-float ((f1 arg_y) (f2 arg_z))
275  (lfs fp0 ppc32::single-float.value f1)
276  (stfs fp0 ppc32::single-float.value f2)
277  (blr))
278
279#+ppc32-target
280(defppclapfunction %double-float-exp ((n arg_z))
281  (lwz imm1 target::double-float.value n)
282  (rlwinm arg_z imm1 (- 32 (- 20 target::fixnumshift)) 19  29) ; right 20 left 2 = right 18 = left 14
283  (blr))
284
285
286
287#+ppc32-target
288(defppclapfunction set-%double-float-exp ((float arg_y) (exp arg_z))
289  (lwz imm1 target::double-float.value float)
290  (rlwimi imm1 exp (- 20 target::fixnumshift) 1 11)
291  (stw imm1 target::double-float.value float) ; hdr - tag = 8 - 2
292  (blr))
293
294
295
296#+ppc32-target
297(defppclapfunction %short-float-exp ((n arg_z))
298  (lwz imm1 ppc32::single-float.value n)
299  (rlwinm arg_z imm1 (- 32 (- 23 ppc32::fixnumshift)) 22 29)
300  (blr))
301
302
303
304#+ppc32-target
305(defppclapfunction set-%short-float-exp ((float arg_y) (exp arg_z))
306  (lwz imm1 ppc32::single-float.value float)
307  (rlwimi imm1 exp (- 23 ppc32::fixnumshift) 1 8)
308  (stw imm1 ppc32::single-float.value float)
309  (blr))
310
311 
312(defppclapfunction %short-float->double-float ((src arg_y) (result arg_z))
313  (get-single-float fp0 src)
314  (put-double-float fp0 result)
315  (blr))
316
317#+ppc32-target
318(defppclapfunction %double-float->short-float ((src arg_y) (result arg_z))
319  ;(clear-fpu-exceptions)
320  (get-double-float fp0 src)
321  (frsp fp1 fp0)
322  (put-single-float fp1 result)
323  (blr))
324
325#+ppc64-target
326(defppclapfunction %double-float->short-float ((src arg_z))
327  ;(clear-fpu-exceptions)
328  (get-double-float fp0 src)
329  (frsp fp1 fp0)
330  (put-single-float fp1 arg_z)
331  (blr))
332 
333
334
335#+ppc32-target
336(defppclapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z))
337  (int-to-freg int fp0 imm0)
338  (frsp fp1 fp0)
339  (stfs fp1 ppc32::single-float.value sfloat)
340  (blr))
341
342#+ppc64-target
343(defppclapfunction %int-to-sfloat ((int arg_z))
344  (int-to-freg int fp0 imm0)
345  (frsp fp1 fp0)
346  (stfs fp1 ppc64::tcr.single-float-convert ppc64::rcontext)
347  (ld arg_z ppc64::tcr.single-float-convert ppc64::rcontext)
348  (blr))
349 
350
351(defppclapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
352  (int-to-freg int fp0 imm0)
353  (stfd fp0 target::double-float.value dfloat)
354  (blr))
355
356
357
358; Manipulating the FPSCR.
359; This  returns the bottom 8 bits of the FPSCR
360(defppclapfunction %get-fpscr-control ()
361  (mffs fp0)
362  (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext)
363  (lbz imm0 (+ target::tcr.lisp-fpscr-high 7) target::rcontext)
364  (box-fixnum arg_z imm0)
365  (blr))
366
367; Returns the high 24 bits of the FPSCR
368(defppclapfunction %get-fpscr-status ()
369  (mffs fp0)
370  (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext)
371  (lwz imm0 target::tcr.lisp-fpscr-low tsp)
372  (clrrwi imm0 imm0 8)
373  (srwi arg_z imm0 (- 8 target::fixnumshift))
374  (blr))
375
376; Set the high 24 bits of the FPSCR; leave the low 8 unchanged
377(defppclapfunction %set-fpscr-status ((new arg_z))
378  (slwi imm0 new (- 8 target::fixnumshift))
379  (stw imm0 target::tcr.lisp-fpscr-low target::rcontext)
380  (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext)
381  (mtfsf #xfc fp0)                      ; set status fields [0-5]
382  (blr))
383
384; Set the low 8 bits of the FPSCR.  Zero the upper 24 bits
385(defppclapfunction %set-fpscr-control ((new arg_z))
386  (unbox-fixnum imm0 new)
387  (clrlwi imm0 imm0 24)                 ; ensure that "status" fields are clear
388  (stw imm0 target::tcr.lisp-fpscr-low target::rcontext)
389  (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext)
390  (mtfsf #xff fp0)                      ; set all fields [0-7]
391  (blr))
392
393
394(defppclapfunction %ffi-exception-status ()
395  (ldr imm0  target::tcr.ffi-exception target::rcontext)
396  (mtcrf #xfc imm0)
397  (mcrfs :cr6 :cr6)
398  (mcrfs :cr7 :cr7)
399  (crand ppc::fpscr-fex-bit ppc::fpscr-oe-bit ppc::fpscr-ox-bit)
400  (bt ppc::fpscr-fex-bit @set)
401  (crand ppc::fpscr-fex-bit ppc::fpscr-ve-bit ppc::fpscr-vx-bit)
402  (bt ppc::fpscr-fex-bit @set)
403  (crand ppc::fpscr-fex-bit ppc::fpscr-ue-bit ppc::fpscr-ux-bit)
404  (bt ppc::fpscr-fex-bit @set)
405  (crand ppc::fpscr-fex-bit ppc::fpscr-ze-bit ppc::fpscr-zx-bit)
406  (bt ppc::fpscr-fex-bit @set)
407  (crand ppc::fpscr-fex-bit ppc::fpscr-xe-bit ppc::fpscr-xx-bit)
408  (bf ppc::fpscr-fex-bit @ret)
409  @set
410  (oris imm0 imm0 #xc000)
411  @ret
412  (srwi arg_z imm0 (- 8 target::fixnumshift))
413  (blr))
414 
415
416; See if the binary double-float operation OP set any enabled
417; exception bits in the fpscr
418(defun %df-check-exception-2 (operation op0 op1 fp-status)
419  (declare (type (unsigned-byte 24) fp-status))
420  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
421    (%set-fpscr-status 0)
422    ;; Ensure that operands are heap-consed
423    (%fp-error-from-status fp-status 
424                           (%get-fpscr-control)
425                           operation 
426                           (%copy-double-float op0 (%make-dfloat)) 
427                           (%copy-double-float op1 (%make-dfloat)))))
428
429(defun %sf-check-exception-2 (operation op0 op1 fp-status)
430  (declare (type (unsigned-byte 24) fp-status))
431  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
432    (%set-fpscr-status 0)
433    ;; Ensure that operands are heap-consed
434    (%fp-error-from-status fp-status 
435                           (%get-fpscr-control)
436                           operation
437                           #+ppc32-target
438                           (%copy-short-float op0 (%make-sfloat))
439                           #+ppc64-target op0
440                           #+ppc32-target
441                           (%copy-short-float op1 (%make-sfloat))
442                           #+ppc64-target op1)))
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                           #+ppc32-target
463                           (%copy-short-float op0 (%make-sfloat))
464                           #+ppc64-target op0)))
465
466
467(defun fp-condition-from-fpscr (status-bits control-bits)
468  (declare (fixnum status-bits control-bits))
469  (cond 
470   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
471         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
472    'floating-point-invalid-operation)
473   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
474         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
475    'floating-point-overflow)
476   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
477         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
478    'floating-point-underflow)
479   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
480         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
481    'division-by-zero)
482   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
483         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
484    'floating-point-inexact)))
485
486;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
487(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
488  (declare (type (unsigned-byte 16) status-bits))
489  (case operation
490    (sqrt (setq operands (cdr operands))))
491  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
492    (if condition-class
493      (error (make-instance condition-class
494               :operation operation
495               :operands operands)))))
496
497(defun fp-minor-opcode-operation (minor-opcode)
498  (case minor-opcode
499    (25 '*)
500    (18 '/)
501    (20 '-)
502    (21 '+)
503    (22 'sqrt)
504    (t 'unknown)))
505
506;;; Don't we already have about 20 versions of this ?
507(defppclapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
508  (ldr imm0 target::macptr.address ptr)
509  (unbox-fixnum imm1 byte-offset)
510  (lfdx fp1 imm0 imm1)
511  (put-double-float fp1 dest)
512  (blr))
513
514
515(defvar *rounding-mode-alist*
516  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
517
518(defun get-fpu-mode (&optional (mode nil mode-p))
519  (let* ((flags (%get-fpscr-control)))
520    (declare (type (unsigned-byte 8) flags))
521    (if mode-p
522      (ecase mode
523        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
524        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
525        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
526        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
527        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
528        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
529      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
530        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
531        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
532        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
533        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
534        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
535
536;;; did we document this?
537(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
538                          (overflow t overflow-p)
539                          (underflow t underflow-p)
540                          (division-by-zero t zero-p)
541                          (invalid t invalid-p)
542                          (inexact t inexact-p))
543  (let* ((mask (logior (if rounding-p #x03 #x00)
544                       (if invalid-p
545                         (ash 1 (- 31 ppc::fpscr-ve-bit))
546                         #x00)
547                       (if overflow-p
548                         (ash 1 (- 31 ppc::fpscr-oe-bit))
549                         #x00)
550                       (if underflow-p
551                         (ash 1 (- 31 ppc::fpscr-ue-bit))
552                         #x00)
553                       (if zero-p
554                         (ash 1 (- 31 ppc::fpscr-ze-bit))
555                         #x00)
556                       (if inexact-p
557                         (ash 1 (- 31 ppc::fpscr-xe-bit))
558                         #x00)))
559         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
560                          (error "Unknown rounding mode: ~s" rounding-mode))
561                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
562                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
563                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
564                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
565                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
566    (declare (type (unsigned-byte 8) new mask))
567    (%set-fpscr-control (logior (logand new mask)
568                                (logandc2 (%get-fpscr-control) mask)))))
569
570
571;;; Copy a single float pointed at by the macptr in single
572;;; to a double float pointed at by the macptr in double
573
574(defppclapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
575  (check-nargs 2)
576  (macptr-ptr imm0 single)
577  (lfs fp0 0 imm0)
578  (macptr-ptr imm0 double)
579  (stfd fp0 0 imm0)
580  (blr))
581
582;;; Copy a double float pointed at by the macptr in double
583;;; to a single float pointed at by the macptr in single.
584(defppclapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
585  (check-nargs 2)
586  (macptr-ptr imm0 double)
587  (lfd fp0 0 imm0)
588  (macptr-ptr imm0 single)
589  (stfs fp0 0 imm0)
590  (blr))
591
592
593(defppclapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
594  (check-nargs 2)
595  (macptr-ptr imm0 macptr)
596  (get-double-float fp1 src)
597  (stfs fp1 0 imm0)
598  (blr))
599
600#+ppc32-target
601(defun host-single-float-from-unsigned-byte-32 (u32)
602  (let* ((f (%make-sfloat)))
603    (setf (uvref f ppc32::single-float.value-cell) u32)
604    f))
605
606#+ppc64-target
607(defppclapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z))
608  (sldi arg_z arg_z (- 32 ppc64::fixnumshift))
609  (ori arg_z arg_z ppc64::subtag-single-float)
610  (blr))
611
612
613#+ppc32-target
614(defun single-float-bits (f)
615  (uvref f ppc32::single-float.value-cell))
616
617#+ppc64-target
618(defppclapfunction single-float-bits ((f arg_z))
619  (srdi arg_z f (- 32 ppc64::fixnumshift))
620  (blr))
621
622(defun double-float-bits (f)
623  (values (uvref f target::double-float.value-cell)
624          (uvref f target::double-float.val-low-cell)))
625
626(defun double-float-from-bits (high low)
627  (let* ((f (%make-dfloat)))
628    (setf (uvref f target::double-float.value-cell) high
629          (uvref f target::double-float.val-low-cell) low)
630    f))
631
632(defppclapfunction %double-float-sign ((n arg_z))
633  (lwz imm0 target::double-float.value n)
634  (cmpwi imm0 0)
635  (li arg_z nil)
636  (bgelr)
637  (li arg_z t)
638  (blr))
639
640(defppclapfunction %short-float-sign ((n arg_z))
641  #+ppc32-target (lwz imm0 ppc32::single-float.value n)
642  #+ppc64-target (srdi imm0 n 32)
643  (cmpwi imm0 0)
644  (li arg_z nil)
645  (bgelr)
646  (li arg_z t)
647  (blr))
648
649#+32-bit-target
650(defppclapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
651  (get-single-float fp1 src)
652  (fsqrts fp2 fp1)
653  (put-single-float fp2 dest)
654  (blr))
655
656#+64-bit-target
657(defppclapfunction %single-float-sqrt ((arg arg_z))
658  (get-single-float fp1 arg)
659  (fsqrts fp2 fp1)
660  (put-single-float fp2 arg_z)
661  (blr))
662
663(defppclapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
664  (get-double-float fp1 src)
665  (fsqrt fp2 fp1)
666  (put-double-float fp2 dest)
667  (blr))
668
669#+poweropen-target
670(defppclapfunction %get-fp-arg-regs ((ptr arg_z))
671  (macptr-ptr imm0 ptr)
672  (stfd fp1 0 imm0)
673  (stfd fp2 8 imm0)
674  (stfd fp3 16 imm0)
675  (stfd fp4 24 imm0)
676  (stfd fp5 32 imm0)
677  (stfd fp6 40 imm0)
678  (stfd fp7 48 imm0)
679  (stfd fp8 56 imm0)
680  (stfd fp9 64 imm0)
681  (stfd fp10 72 imm0)
682  (stfd fp11 80 imm0)
683  (stfd fp12 88 imm0)
684  (stfd fp13 96 imm0)
685  (blr))
686
687#+poweropen-target
688(defppclapfunction %load-fp-arg-regs ((n arg_y) (ptr arg_z))
689  (cmpdi cr0 n '0)
690  (cmpdi cr1 n '1)
691  (cmpdi cr2 n '2)
692  (cmpdi cr3 n '3)
693  (cmpdi cr4 n '4)
694  (cmpdi cr5 n '5)
695  (cmpdi cr6 n '6)
696  (cmpdi cr7 n '7)
697  (beqlr cr0)
698  (macptr-ptr imm0 ptr)
699  (cmpdi cr0 n '8)
700  (lfd fp1 0 imm0)
701  (beqlr cr1)
702  (cmpdi cr1 n '9)
703  (lfd fp2 8 imm0)
704  (beqlr cr2)
705  (cmpdi cr2 n '10)
706  (lfd fp3 16 imm0)
707  (beqlr cr3)
708  (cmpdi cr3 n '11)
709  (lfd fp4 24 imm0)
710  (beqlr cr4)
711  (cmpdi cr4 n '12)
712  (lfd fp5 32 imm0)
713  (beqlr cr5)
714  (lfd fp6 40 imm0)
715  (beqlr cr6)
716  (lfd fp7 48 imm0)
717  (beqlr cr7)
718  (lfd fp8 56 imm0)
719  (beqlr cr0)
720  (lfd fp9 64 imm0)
721  (beqlr cr1)
722  (lfd fp10 72 imm0)
723  (beqlr cr2)
724  (lfd fp11 80 imm0)
725  (beqlr cr3)
726  (lfd fp12 88 imm0)
727  (beqlr cr4)
728  (lfd fp13 96 imm0)
729  (blr))
Note: See TracBrowser for help on using the repository browser.