Changeset 14037


Ignore:
Timestamp:
Jul 24, 2010, 11:35:30 PM (9 years ago)
Author:
gb
Message:

FFI FP exception stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/level-0/ARM/arm-float.lisp

    r13998 r14037  
    269269
    270270(defarmlapfunction %ffi-exception-status ()
    271   (mov arg_z (:$ 0))                    ;for now
     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)
    272280  (bx lr))
    273281
    274282(defun %sf-check-exception-1 (operation op0 fp-status)
    275   (declare (ignore 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
    276297
    277298(defun %df-check-exception-1 (operation op0 fp-status)
    278   (declare (ignore 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))))))))
    279314
    280315(defvar *rounding-mode-alist*
     
    414449     
    415450 
    416 #+notyet
    417 (progn
    418 
    419 ; See if the binary double-float operation OP set any enabled
    420 ; exception bits in the fpscr
    421 (defun %df-check-exception-2 (operation op0 op1 fp-status)
    422   (declare (type (unsigned-byte 24) fp-status))
    423   (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
    424     (%set-fpscr-status 0)
    425     ;; Ensure that operands are heap-consed
    426     (%fp-error-from-status fp-status
    427                            (%get-fpscr-control)
    428                            operation
    429                            (%copy-double-float op0 (%make-dfloat))
    430                            (%copy-double-float op1 (%make-dfloat)))))
    431 
    432 (defun %sf-check-exception-2 (operation op0 op1 fp-status)
    433   (declare (type (unsigned-byte 24) fp-status))
    434   (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
    435     (%set-fpscr-status 0)
    436     ;; Ensure that operands are heap-consed
    437     (%fp-error-from-status fp-status
    438                            (%get-fpscr-control)
    439                            operation
    440                            
    441                            (%copy-short-float op0 (%make-sfloat))
    442                            
    443                            (%copy-short-float op1 (%make-sfloat)))))
    444 
    445 (defun %df-check-exception-1 (operation op0 fp-status)
    446   (declare (fixnum fp-status))
    447   (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
    448     (%set-fpscr-status 0)
    449     ;; Ensure that operands are heap-consed
    450     (%fp-error-from-status fp-status
    451                               (%get-fpscr-control)
    452                               operation
    453                               (%copy-double-float op0 (%make-dfloat)))))
    454 
    455 (defun %sf-check-exception-1 (operation op0 fp-status)
    456   (declare (type (unsigned-byte 24) fp-status))
    457   (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status)
    458     (%set-fpscr-status 0)
    459                                         ; Ensure that operands are heap-consed
    460     (%fp-error-from-status fp-status
    461                            (%get-fpscr-control)
    462                            operation
    463                            
    464                            (%copy-short-float op0 (%make-sfloat)))))
    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 );#+notyet
    507 
    508451;;; Don't we already have about 20 versions of this ?
    509452(defarmlapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
     
    513456  (strd imm0 (:@ dest (:$ arm::double-float.value)))
    514457  (bx lr))
    515 
    516 
    517 #+notyet
    518 (progn
    519 (defvar *rounding-mode-alist*
    520   '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
    521 
    522 (defun get-fpu-mode (&optional (mode nil mode-p))
    523   (let* ((flags (%get-fpscr-control)))
    524     (declare (type (unsigned-byte 8) flags))
    525     (if mode-p
    526       (ecase mode
    527         (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*)))
    528         (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags))
    529         (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags))
    530         (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags))
    531         (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags))
    532         (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags)))
    533       `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*))
    534         :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags)
    535         :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags)
    536         :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags)
    537         :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags)
    538         :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags)))))
    539 
    540 ;;; did we document this?
    541 (defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
    542                           (overflow t overflow-p)
    543                           (underflow t underflow-p)
    544                           (division-by-zero t zero-p)
    545                           (invalid t invalid-p)
    546                           (inexact t inexact-p))
    547   (let* ((mask (logior (if rounding-p #x03 #x00)
    548                        (if invalid-p
    549                          (ash 1 (- 31 ppc::fpscr-ve-bit))
    550                          #x00)
    551                        (if overflow-p
    552                          (ash 1 (- 31 ppc::fpscr-oe-bit))
    553                          #x00)
    554                        (if underflow-p
    555                          (ash 1 (- 31 ppc::fpscr-ue-bit))
    556                          #x00)
    557                        (if zero-p
    558                          (ash 1 (- 31 ppc::fpscr-ze-bit))
    559                          #x00)
    560                        (if inexact-p
    561                          (ash 1 (- 31 ppc::fpscr-xe-bit))
    562                          #x00)))
    563          (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*))
    564                           (error "Unknown rounding mode: ~s" rounding-mode))
    565                       (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0)
    566                       (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0)
    567                       (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit))  0)
    568                       (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0)
    569                       (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0))))
    570     (declare (type (unsigned-byte 8) new mask))
    571     (%set-fpscr-control (logior (logand new mask)
    572                                 (logandc2 (%get-fpscr-control) mask)))))
    573 )
    574458
    575459
     
    646530
    647531(defarmlapfunction %single-float-sqrt! ((src arg_y) (dest arg_z))
     532  (build-lisp-frame)
    648533  (get-single-float s0 src imm0)
     534  (fmrx imm0 fpscr)
     535  (bic imm0 imm0 (:$ #xff))
     536  (fmxr fpscr imm0)
    649537  (fsqrts s1 s0)
     538  (bl .SPcheck-fpu-exception)
    650539  (put-single-float s1 dest imm0)
    651   (bx lr))
     540  (return-lisp-frame))
    652541
    653542
    654543
    655544(defarmlapfunction %double-float-sqrt! ((src arg_y) (dest arg_z))
     545  (build-lisp-frame)
    656546  (get-double-float d0 src)
     547  (fmrx imm0 fpscr)
     548  (bic imm0 imm0 (:$ #xff))
     549  (fmxr fpscr imm0)
    657550  (fsqrtd d1 d0)
     551  (bl .SPcheck-fpu-exception)
    658552  (put-double-float d1 dest)
    659   (bx lr))
    660 
    661 
     553  (return-lisp-frame))
     554
     555
Note: See TracChangeset for help on using the changeset viewer.