Changeset 14037

Timestamp:

Jul 24, 2010, 11:35:30 PM (9 years ago)

Author:

gb

Message:

FFI FP exception stuff.

File:

• branches/arm/level-0/ARM/arm-float.lisp (modified) (4 diffs)

branches/arm/level-0/ARM/arm-float.lisp

@@ -269 +269 @@
 
 (defarmlapfunction %ffi-exception-status ()
-  (mov arg_z (:$ 0))                    ;for now
+  (ldr imm1 (:@ rcontext (:$ arm::tcr.lisp-fpscr)))
+  (fmrx imm2 fpscr)
+  (and imm0 imm2 (:$ #xff))
+  (ands imm0 imm0 (:lsr imm1 (:$ 8)))
+  (moveq arg_z 'nil)
+  (bxeq lr)
+  (mov arg_z (:lsl imm0 (:$ arm::fixnumshift)))
+  (bic imm0 imm2 (:$ #xff))
+  (fmxr fpscr imm0)
   (bx lr))
 
 (defun %sf-check-exception-1 (operation op0 fp-status)
-  (declare (ignore operation op0 fp-status)))
+  (when fp-status
+    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
+      (error (make-instance (or condition-name 'arithmetic-error)
+                            :operation operation
+                            :operands (list (%copy-short-float op0 (%make-sfloat))))))))
+
+(defun %sf-check-exception-2 (operation op0 op1 fp-status)
+  (when fp-status
+    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
+      (error (make-instance (or condition-name 'arithmetic-error)
+                            :operation operation
+                            :operands (list (%copy-short-float op0 (%make-sfloat))
+                                            (%copy-short-float op1 (%make-sfloat))))))))
+
 
 (defun %df-check-exception-1 (operation op0 fp-status)
-  (declare (ignore operation op0 fp-status)))
+  (when fp-status
+    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
+      (error (make-instance (or condition-name 'arithmetic-error)
+                            :operation operation
+                            :operands (list (%copy-double-float op0 (%make-dfloat))))))))
+
+; See if the binary double-float operation OP set any enabled
+; exception bits in the fpscr
+(defun %df-check-exception-2 (operation op0 op1 fp-status)
+  (when fp-status
+    (let* ((condition-name (fp-condition-name-from-fpscr-status fp-status)))
+      (error (make-instance (or condition-name 'arithmetic-error)
+                            :operation operation
+                            :operands (list (%copy-double-float op0 (%make-dfloat))
+                                            (%copy-double-float op1 (%make-dfloat))))))))
 
 (defvar *rounding-mode-alist*
@@ -414 +449 @@
      
  
-#+notyet
-(progn
-
-; See if the binary double-float operation OP set any enabled
-; exception bits in the fpscr
-(defun %df-check-exception-2 (operation op0 op1 fp-status)
-  (declare (type (unsigned-byte 24) fp-status))
-  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
-    (%set-fpscr-status 0)
-    ;; Ensure that operands are heap-consed
-    (%fp-error-from-status fp-status 
-                           (%get-fpscr-control)
-                           operation 
-                           (%copy-double-float op0 (%make-dfloat)) 
-                           (%copy-double-float op1 (%make-dfloat)))))
-
-(defun %sf-check-exception-2 (operation op0 op1 fp-status)
-  (declare (type (unsigned-byte 24) fp-status))
-  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
-    (%set-fpscr-status 0)
-    ;; Ensure that operands are heap-consed
-    (%fp-error-from-status fp-status 
-                           (%get-fpscr-control)
-                           operation
-                           
-                           (%copy-short-float op0 (%make-sfloat))
-                           
-                           (%copy-short-float op1 (%make-sfloat)))))
-
-(defun %df-check-exception-1 (operation op0 fp-status)
-  (declare (fixnum fp-status))
-  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
-    (%set-fpscr-status 0)
-    ;; Ensure that operands are heap-consed
-    (%fp-error-from-status fp-status 
-                              (%get-fpscr-control)
-                              operation 
-                              (%copy-double-float op0 (%make-dfloat)))))
-
-(defun %sf-check-exception-1 (operation op0 fp-status)
-  (declare (type (unsigned-byte 24) fp-status))
-  (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
-    (%set-fpscr-status 0)
-                                        ; Ensure that operands are heap-consed
-    (%fp-error-from-status fp-status 
-                           (%get-fpscr-control)
-                           operation
-                           
-                           (%copy-short-float op0 (%make-sfloat)))))
-
-
-(defun fp-condition-from-fpscr (status-bits control-bits)
-  (declare (fixnum status-bits control-bits))
-  (cond 
-   ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits)
-         (logbitp (- 31 ppc::fpscr-ve-bit) control-bits))
-    'floating-point-invalid-operation)
-   ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits)
-         (logbitp (- 31 ppc::fpscr-oe-bit) control-bits))
-    'floating-point-overflow)
-   ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits)
-         (logbitp (- 31 ppc::fpscr-ue-bit) control-bits))
-    'floating-point-underflow)
-   ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits)
-         (logbitp (- 31 ppc::fpscr-ze-bit) control-bits))
-    'division-by-zero)
-   ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits)
-         (logbitp (- 31 ppc::fpscr-xe-bit) control-bits))
-    'floating-point-inexact)))
-
-;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set.
-(defun %fp-error-from-status (status-bits control-bits operation &rest operands)
-  (declare (type (unsigned-byte 16) status-bits))
-  (case operation
-    (sqrt (setq operands (cdr operands))))
-  (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits)))
-    (if condition-class
-      (error (make-instance condition-class
-               :operation operation
-               :operands operands)))))
-
-(defun fp-minor-opcode-operation (minor-opcode)
-  (case minor-opcode
-    (25 '*)
-    (18 '/)
-    (20 '-)
-    (21 '+)
-    (22 'sqrt)
-    (t 'unknown)))
-
-);#+notyet
-
 ;;; Don't we already have about 20 versions of this ?
 (defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
@@ -513 +456 @@
   (strd imm0 (:@ dest (:$ arm::double-float.value)))
   (bx lr))
-
-
-#+notyet
-(progn
-(defvar *rounding-mode-alist*
-  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
-
-(defun get-fpu-mode (&optional (mode nil mode-p))
-  (let* ((flags (%get-fpscr-control)))
-    (declare (type (unsigned-byte 8) flags))
-    (if mode-p
-      (ecase mode
-        (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
-        (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
-        (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
-        (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
-        (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
-        (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
-      `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
-        :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
-        :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
-        :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
-        :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
-        :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
-
-;;; did we document this?
-(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
-                          (overflow t overflow-p)
-                          (underflow t underflow-p)
-                          (division-by-zero t zero-p)
-                          (invalid t invalid-p)
-                          (inexact t inexact-p))
-  (let* ((mask (logior (if rounding-p #x03 #x00)
-                       (if invalid-p
-                         (ash 1 (- 31 ppc::fpscr-ve-bit))
-                         #x00)
-                       (if overflow-p
-                         (ash 1 (- 31 ppc::fpscr-oe-bit))
-                         #x00)
-                       (if underflow-p
-                         (ash 1 (- 31 ppc::fpscr-ue-bit))
-                         #x00)
-                       (if zero-p
-                         (ash 1 (- 31 ppc::fpscr-ze-bit))
-                         #x00)
-                       (if inexact-p
-                         (ash 1 (- 31 ppc::fpscr-xe-bit))
-                         #x00)))
-         (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
-                          (error "Unknown rounding mode: ~s" rounding-mode))
-                      (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
-                      (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
-                      (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
-                      (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
-                      (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
-    (declare (type (unsigned-byte 8) new mask))
-    (%set-fpscr-control (logior (logand new mask)
-                                (logandc2 (%get-fpscr-control) mask)))))
-)
 
 
@@ -646 +530 @@
 
 (defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
+  (build-lisp-frame)
   (get-single-float s0 src imm0)
+  (fmrx imm0 fpscr)
+  (bic imm0 imm0 (:$ #xff))
+  (fmxr fpscr imm0)
   (fsqrts s1 s0)
+  (bl .SPcheck-fpu-exception)
   (put-single-float s1 dest imm0)
-  (bx lr))
+  (return-lisp-frame))
 
 
 
 (defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
+  (build-lisp-frame)
   (get-double-float d0 src)
+  (fmrx imm0 fpscr)
+  (bic imm0 imm0 (:$ #xff))
+  (fmxr fpscr imm0)
   (fsqrtd d1 d0)
+  (bl .SPcheck-fpu-exception)
   (put-double-float d1 dest)
-  (bx lr))
-
-
+  (return-lisp-frame))
+
+