;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 2010 Clozure Associates
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")
(defparameter *arm-xtype-specifiers* (make-array 256 :initial-element nil))

(macrolet ((init-arm-xtype-table (&rest pairs)
             (let* ((table (gensym)))
               (collect ((body))
                 (dolist (pair pairs)
                   (destructuring-bind (code . spec) pair
                     (body `(setf (svref ,table ,code) ',spec))))
                 `(let* ((,table *arm-xtype-specifiers*))
                   ,@(body))))))
  (init-arm-xtype-table
   (arm::tag-fixnum . fixnum)
   (arm::tag-list . list)
   (arm::xtype-integer . integer)
   (arm::xtype-s64 . (signed-byte 64))
   (arm::xtype-u64 . (unsigned-byte 64))
   (arm::xtype-s32 . (signed-byte 32))
   (arm::xtype-u32 . (unsigned-byte 32))
   (arm::xtype-s16 . (signed-byte 16))
   (arm::xtype-u16 . (unsigned-byte 16))
   (arm::xtype-s8  . (signed-byte 8))
   (arm::xtype-u8  . (unsigned-byte 8))
   (arm::xtype-bit . bit)
   (arm::xtype-rational . rational)
   (arm::xtype-real . real)
   (arm::xtype-number . number)
   (arm::xtype-char-code . (mod #x110000))
   (arm::xtype-unsigned-byte-24 . (unsigned-byte 24))
   (arm::xtype-array2d . (array * (* *)))
   (arm::xtype-array3d . (array * (* * *)))
   (arm::subtag-bignum . bignum)
   (arm::subtag-ratio . ratio)
   (arm::subtag-single-float . single-float)
   (arm::subtag-double-float . double-float)
   (arm::subtag-complex . complex)
   (arm::subtag-macptr . macptr)
   (arm::subtag-code-vector . code-vector)
   (arm::subtag-xcode-vector . xcode-vector)
   (arm::subtag-catch-frame . catch-frame)
   (arm::subtag-function . function)
   (arm::subtag-basic-stream . basic-stream)
   (arm::subtag-symbol . symbol)
   (arm::subtag-lock . lock)
   (arm::subtag-hash-vector . hash-vector)
   (arm::subtag-pool . pool)
   (arm::subtag-weak . population)
   (arm::subtag-package . package)
   (arm::subtag-slot-vector . slot-vector)
   (arm::subtag-instance . standard-object)
   (arm::subtag-struct . structure-object)
   (arm::subtag-istruct . istruct)      ;??
   (arm::subtag-value-cell . value-cell)
   (arm::subtag-xfunction . xfunction)
   (arm::subtag-arrayH . array-header)
   (arm::subtag-vectorH . vector-header)
   (arm::subtag-simple-vector . simple-vector)
   (arm::subtag-single-float-vector . (simple-array single-float (*)))
   (arm::subtag-u32-vector . (simple-array (unsigned-byte 32) (*)))
   (arm::subtag-s32-vector . (simple-array (signed-byte 32) (*)))
   (arm::subtag-fixnum-vector . (simple-array fixnum (*)))
   (arm::subtag-simple-base-string . simple-base-string)
   (arm::subtag-u8-vector . (simple-array (unsigned-byte 8) (*)))
   (arm::subtag-s8-vector . (simple-array (signed-byte 8) (*)))   
   (arm::subtag-u16-vector . (simple-array (unsigned-byte 16) (*)))
   (arm::subtag-double-float-vector . (simple-array double-float (*)))
   (arm::subtag-bit-vector . simple-bit-vector)))

(defun xp-argument-list (xp)
  (let ((nargs (xp-gpr-lisp xp arm::nargs))     ; tagged as a fixnum (how convenient)
        (arg-x (xp-gpr-lisp xp arm::arg_x))
        (arg-y (xp-gpr-lisp xp arm::arg_y))
        (arg-z (xp-gpr-lisp xp arm::arg_z)))
    (cond ((eql nargs 0) nil)
          ((eql nargs 1) (list arg-z))
          ((eql nargs 2) (list arg-y arg-z))
          (t (let ((args (list arg-x arg-y arg-z)))
               (if (eql nargs 3)
                 args
                 (let ((vsp (xp-gpr-macptr xp arm::vsp)))
                   (dotimes (i (- nargs 3))
                     (push (%get-object vsp (* i target::node-size)) args))
                   args)))))))

(defun handle-udf-call (xp frame-ptr)
  (let* ((args (xp-argument-list xp))
         (values (multiple-value-list
                  (%kernel-restart-internal
                   $xudfcall
                   (list (maybe-setf-name (xp-gpr-lisp xp arm::fname)) args)
                   frame-ptr)))
         (stack-argcnt (max 0 (- (length args) 3)))
         (vsp (%i+ (xp-gpr-lisp xp arm::vsp) stack-argcnt))
         (f #'(lambda (values) (apply #'values values))))
    (setf (xp-gpr-lisp xp arm::vsp) vsp
          (xp-gpr-lisp xp arm::nargs) 1
          (xp-gpr-lisp xp arm::arg_z) values
          (xp-gpr-lisp xp arm::nfn) f)
    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
    (setf (xp-gpr-lisp xp arm::pc) (uvref f 0))))

  
(defcallback %xerr-disp (:address xp
                                  :signed-fullword error-number
                                  :unsigned-fullword arg
                                  :unsigned-fullword fnreg
                                  :unsigned-fullword relative-pc
                                  :int)
  (let* ((fn (unless (eql 0 fnreg) (xp-gpr-lisp xp fnreg)))
         (delta 0))
    (with-xp-stack-frames (xp fn frame-ptr)
      (with-error-reentry-detection
          (cond
            ((eql 0 error-number)       ; Hopefully a UUO.
             (setq delta 4)
             (if (/= (logand arg #x0ff000f0) #x07f000f0)
               (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
               (let* ((condition (ldb (byte 4 28) arg))
                      (uuo (ldb (byte 28 0) arg))
                      (format (ldb (byte 4 0) uuo)))
                 (declare (fixnum condition uuo format))
                 (case format
                   ((2 10)              ; uuo-format-[c]error-lisptag
                    (%error (make-condition
                             'type-error
                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
                             :expected-type
                             (svref #(fixnum list uvector immediate)
                                    (ldb (byte 2 12) uuo)))
                            nil
                            frame-ptr))
                   ((3 11)
                    (%error (make-condition
                             'type-error
                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
                             :expected-type
                             (svref #(fixnum null bogus immediate fixnum cons uvector bogus)
                                    (ldb (byte 3 12) uuo)))
                            nil
                            frame-ptr))
                   ((4 12)
                    (%error (make-condition
                             'type-error
                             :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
                             :expected-type
                             (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
                            nil
                            frame-ptr))
                   (8                   ;nullary error.  Only one, atm.
                    (case (ldb (byte 12 8) uuo)
                      (1                ;why 1?
                       (let* ((condition-name
                               (cond ((eq condition arm::arm-cond-lo)
                                      'too-few-arguments)
                                     ((eq condition arm::arm-cond-hs)
                                      'too-many-arguments)
                                     (t
                                      ;;(assert condition arm::arm-cond-ne)
                                      (let* ((cpsr (xp-gpr-signed-long xp
                                                                       xp-cpsr-regno)))
                                        (if (logbitp 29 cpsr)
                                          'too-many-arguments
                                          'too-few-arguments))))))
                         (%error condition-name
                                 (list :nargs (xp-gpr-lisp xp arm::nargs)
                                       :fn fn)
                                 frame-ptr)))
                      (t
                       (%error "Unknown nullary UUO code ~d"
                               (list (ldb (byte 12 8) uuo))
                               frame-ptr))))
                   (9                   ;unary error
                    (let* ((code (ldb (byte 8 12) uuo))
                           (regno (ldb (byte 4 8) uuo))
                           (arg (xp-gpr-lisp xp regno)))
                      (case code
                        ((0 1)
                         (setf (xp-gpr-lisp xp regno)
                               (%kernel-restart-internal $xvunbnd
                                                         (list arg)
                                                         frame-ptr)))
                        (2
                         (%error (make-condition 'type-error
                                                 :datum arg
                                                 :expected-type '(or symbol function)
                                                 :format-control
                                                 "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
                                 nil frame-ptr))
                        (4
                         (%error (make-condition 'cant-throw-error
                                                 :tag arg)
                                 nil frame-ptr))
                        (5
                         (setq delta 0)
                         (handle-udf-call xp frame-ptr))
                        (6
                         (%err-disp-internal $xfunbnd (list arg) frame-ptr))
                        (t
                         (error "Unknown unary UUO with code ~d." code)))))
                   (14
                    (let* ((reg-a (ldb (byte 4 8) uuo))
                           (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
                           (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
                      (setq *error-reentry-count* 0)
                      (setf (xp-gpr-lisp xp reg-a)
                            (%slot-unbound-trap arg-b arg-c frame-ptr))))
                   (15
                    (let* ((reg-a (ldb (byte 4 8) uuo))
                           (arga (xp-gpr-lisp xp reg-a))
                           (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
                           (code (ldb (byte 4 16) uuo)))
                      (case code
                        ((0 1)          ;do we report these the same way?
                         (%error (%rsc-string $xarroob)
                                 (list arga argb)
                                 frame-ptr))
                        (4
                         (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
                                (dest-reg (ldb (byte 4 8) uuo)))
                           (etypecase eep-or-fv
                             (external-entry-point
                              (resolve-eep eep-or-fv)
                              (setf (xp-gpr-lisp xp dest-reg)
                                    (eep.address eep-or-fv)))
                             (foreign-variable
                              (resolve-foreign-variable eep-or-fv)
                              (setf (xp-gpr-lisp xp dest-reg)
                                    (fv.addr eep-or-fv))))))
                        (5              ;fpu
                         (let* ((reginfo (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
                                (instruction (logand (xp-gpr-signed-long xp (ldb (byte 4 12) uuo)) (1- (ash 1 32))))
                                (condition-name (fp-condition-name-from-fpscr-status (aref reginfo 0))))
                           (if condition-name
                             (let* ((template (find-arm-instruction-template instruction))
                                    (operation (if template (arithmetic-error-operation-from-instruction template) 'unknown))
                                    (operands (if template (arithmetic-error-operands-from-instruction template instruction reginfo xp))))
                               (%error condition-name `(:operation ,operation :operands ,operands) frame-ptr))
                             (%error "FPU exception, fpscr = ~d" (list (aref reginfo 0)) frame-ptr)))
                         )
                        (6              ;array rank
                         (%err-disp-internal $XNDIMS
                                             (list
                                              argb
                                              arga)
                                             frame-ptr))
                        (7              ;array flags
                         ;; This is currently only used to signal that
                         ;; a (purported) array header doesn't have the
                         ;; flags which denote a simple-array with
                         ;; a particular subtype.  Decode things, then
                         ;; signal a TYPE-ERROR.
                         (let* ((array (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
                                (flags (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
                                (subtag (ldb target::arrayH.flags-cell-subtag-byte flags))
                                (element-type
                                 (type-specifier
                                  (array-ctype-element-type
                                   (specifier-type (svref *arm-xtype-specifiers* subtag))))))
                           (%error (make-condition
                                    'type-error
                                    :datum array
                                    :expected-type `(simple-array ,element-type))
                                   nil
                                   frame-ptr)))                        
                        (t
                         (error "Unknown code in binary UUO: ~d" code)))))
                   (5
                    (%error "Index value ~s is out of bounds for axis ~s of ~s."
                            (list
                             (xp-gpr-lisp xp (ldb (byte 4 16) uuo))
                             (xp-gpr-lisp xp (ldb (byte 4 12) uuo))
                             (xp-gpr-lisp xp (ldb (byte 4 8) uuo)))
                            frame-ptr))
                   (t
                    (error "Unknown UUO, format ~d" format))))))
            ((eql error-number arch::error-stack-overflow)
             (%error
              (make-condition
               'stack-overflow-condition 
               :format-control "Stack overflow on ~a stack."
               :format-arguments (list (if (eql arg arm::vsp) "value" "control")))
              nil frame-ptr))
            ((eql error-number arch::error-allocation-disabled)
             (restart-case (%error 'allocation-disabled nil frame-ptr)
               (continue ()
                         :report (lambda (stream)
                                   (format stream "retry the heap allocation.")))))
            (t
             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
                    error-number arg fnreg relative-pc)))))
    delta))
