Ignore:
Timestamp:
Jul 5, 2010, 4:05:59 PM (9 years ago)
Author:
gb
Message:

More files from last commit.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/level-1/arm-error-signal.lisp

    r13889 r13922  
    1616
    1717(in-package "CCL")
    18 
    19 (defcallback %xerr-disp ()
    20   )
     18(defparameter *arm-xtype-specifiers* (make-array 256 :initial-element nil))
     19
     20(macrolet ((init-arm-xtype-table (&rest pairs)
     21             (let* ((table (gensym)))
     22               (collect ((body))
     23                 (dolist (pair pairs)
     24                   (destructuring-bind (code . spec) pair
     25                     (body `(setf (svref ,table ,code) ',spec))))
     26                 `(let* ((,table *arm-xtype-specifiers*))
     27                   ,@(body))))))
     28  (init-arm-xtype-table
     29   (arm::tag-fixnum . fixnum)
     30   (arm::tag-list . list)
     31   (arm::xtype-integer . integer)
     32   (arm::xtype-s64 . (signed-byte 64))
     33   (arm::xtype-u64 . (unsigned-byte 64))
     34   (arm::xtype-s32 . (signed-byte 32))
     35   (arm::xtype-u32 . (unsigned-byte 32))
     36   (arm::xtype-s16 . (signed-byte 16))
     37   (arm::xtype-u16 . (unsigned-byte 16))
     38   (arm::xtype-s8  . (signed-byte 8))
     39   (arm::xtype-u8  . (unsigned-byte 8))
     40   (arm::xtype-bit . bit)
     41   (arm::xtype-rational . rational)
     42   (arm::xtype-real . real)
     43   (arm::xtype-number . number)
     44   (arm::xtype-char-code . (mod #x110000))
     45   (arm::xtype-unsigned-byte-24 . (unsigned-byte 24))
     46   (arm::xtype-array2d . (array * (* *)))
     47   (arm::xtype-array3d . (array * (* * *)))
     48   (arm::subtag-bignum . bignum)
     49   (arm::subtag-ratio . ratio)
     50   (arm::subtag-single-float . single-float)
     51   (arm::subtag-double-float . double-float)
     52   (arm::subtag-complex . complex)
     53   (arm::subtag-macptr . macptr)
     54   (arm::subtag-code-vector . code-vector)
     55   (arm::subtag-xcode-vector . xcode-vector)
     56   (arm::subtag-catch-frame . catch-frame)
     57   (arm::subtag-function . function)
     58   (arm::subtag-basic-stream . basic-stream)
     59   (arm::subtag-symbol . symbol)
     60   (arm::subtag-lock . lock)
     61   (arm::subtag-hash-vector . hash-vector)
     62   (arm::subtag-pool . pool)
     63   (arm::subtag-weak . population)
     64   (arm::subtag-package . package)
     65   (arm::subtag-slot-vector . slot-vector)
     66   (arm::subtag-instance . standard-object)
     67   (arm::subtag-struct . structure-object)
     68   (arm::subtag-istruct . istruct)      ;??
     69   (arm::subtag-value-cell . value-cell)
     70   (arm::subtag-xfunction . xfunction)
     71   (arm::subtag-arrayH . array-header)
     72   (arm::subtag-vectorH . vector-header)
     73   (arm::subtag-simple-vector . simple-vector)
     74   (arm::subtag-single-float-vector . (simple-array single-float (*)))
     75   (arm::subtag-u32-vector . (simple-array (unsigned-byte 32) (*)))
     76   (arm::subtag-s32-vector . (simple-array (signed-byte 32) (*)))
     77   (arm::subtag-fixnum-vector . (simple-array fixnum (*)))
     78   (arm::subtag-simple-base-string . simple-base-string)
     79   (arm::subtag-u8-vector . (simple-array (unsigned-byte 8) (*)))
     80   (arm::subtag-s8-vector . (simple-array (signed-byte 8) (*)))   
     81   (arm::subtag-u16-vector . (simple-array (unsigned-byte 16) (*)))
     82   (arm::subtag-double-float-vector . (simple-array double-float (*)))
     83   (arm::subtag-bit-vector . simple-bit-vector)))
     84
     85(defun xp-argument-list (xp)
     86  (let ((nargs (xp-gpr-lisp xp arm::nargs))     ; tagged as a fixnum (how convenient)
     87        (arg-x (xp-gpr-lisp xp arm::arg_x))
     88        (arg-y (xp-gpr-lisp xp arm::arg_y))
     89        (arg-z (xp-gpr-lisp xp arm::arg_z)))
     90    (cond ((eql nargs 0) nil)
     91          ((eql nargs 1) (list arg-z))
     92          ((eql nargs 2) (list arg-y arg-z))
     93          (t (let ((args (list arg-x arg-y arg-z)))
     94               (if (eql nargs 3)
     95                 args
     96                 (let ((vsp (xp-gpr-macptr xp arm::vsp)))
     97                   (dotimes (i (- nargs 3))
     98                     (push (%get-object vsp (* i target::node-size)) args))
     99                   args)))))))
     100
     101(defun handle-udf-call (xp frame-ptr)
     102  (let* ((args (xp-argument-list xp))
     103         (values (multiple-value-list
     104                  (%kernel-restart-internal
     105                   $xudfcall
     106                   (list (maybe-setf-name (xp-gpr-lisp xp arm::fname)) args)
     107                   frame-ptr)))
     108         (stack-argcnt (max 0 (- (length args) 3)))
     109         (vsp (%i+ (xp-gpr-lisp xp arm::vsp) stack-argcnt))
     110         (f #'(lambda (values) (apply #'values values))))
     111    (setf (xp-gpr-lisp xp arm::vsp) vsp
     112          (xp-gpr-lisp xp arm::nargs) 1
     113          (xp-gpr-lisp xp arm::arg_z) values
     114          (xp-gpr-lisp xp arm::nfn) f)
     115    ;; handle_uuo() (in the lisp kernel) will not bump the PC here.
     116    (setf (xp-gpr-lisp xp arm::pc) (uvref f 0))))
     117   
     118(defcallback %xerr-disp (:address xp
     119                                  :signed-fullword error-number
     120                                  :unsigned-fullword arg
     121                                  :unsigned-fullword fnreg
     122                                  :unsigned-fullword relative-pc)
     123  ;; We'll clearly need some sort of xcf/fake-stack-frame -like mechanism.
     124  (let* ((frame-ptr (%get-frame-ptr))
     125         (fn (unless (eql fnreg 0) (xp-gpr-lisp xp fnreg))))
     126    (with-error-reentry-detection
     127        (cond
     128          ((eql 0 error-number)         ; Hopefully a UUO.
     129           (if (/= (logand arg #x0ff000f0) #x07f000f0)
     130             (%error "Unknown non-UUO: #x~x" (list arg) frame-ptr)
     131             (let* ((condition (ldb (byte 4 28) arg))
     132                    (uuo (ldb (byte 28 0) arg))
     133                    (format (ldb (byte 4 0) uuo)))
     134               (declare (fixnum condition uuo format))
     135               (case format
     136                 ((2 10)                ; uuo-format-[c]error-lisptag
     137                  (%error (make-condition
     138                           'type-error
     139                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     140                           :expected-type
     141                           (svref #(fixnum list uvector immediate)
     142                                  (ldb (byte 2 12) uuo)))
     143                          nil
     144                          frame-ptr))
     145                 ((3 11)
     146                  (%error (make-condition
     147                           'type-error
     148                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     149                           :expected-type
     150                           (svref #(fixnum cons bogus immediate fixnum null uvector bogus)
     151                                  (ldb (byte 3 12) uuo)))
     152                          nil
     153                          frame-ptr))
     154                 ((4 12)
     155                  (%error (make-condition
     156                           'type-error
     157                           :datum (xp-gpr-lisp xp (ldb (byte 4 8) uuo))
     158                           :expected-type
     159                           (svref *arm-xtype-specifiers* (ldb (byte 8 12) uuo)))
     160                          nil
     161                          frame-ptr))
     162                 (8                     ;nullary error.  Only one, atm.
     163                  (case (ldb (byte 12 8) uuo)
     164                    (1                  ;why 1?
     165                     (let* ((condition-name
     166                             (cond ((eq condition arm::arm-cond-lo)
     167                                    'too-few-arguments)
     168                                   ((eq condition arm::arm-cond-hs)
     169                                    'too-many-arguments)
     170                                   (t
     171                                    ;;(assert condition arm::arm-cond-ne)
     172                                    (let* ((cpsr (xp-gpr-signed-long xp
     173                                                                     xp-cpsr-regno)))
     174                                      (if (logbitp 29 cpsr)
     175                                        'too-many-arguments
     176                                        'too-few-arguments))))))
     177                       (%error condition-name
     178                               (list :nargs (xp-gpr-lisp xp arm::nargs)
     179                                     :fn fn)
     180                               frame-ptr)))
     181                    (t
     182                     (%error "Unknown nullary UUO code ~d"
     183                             (list (ldb (byte 12 8) uuo))
     184                             frame-ptr))))
     185                 (9                     ;unary error
     186                  (let* ((code (ldb (byte 8 12) uuo))
     187                         (regno (ldb (byte 4 8) uuo))
     188                         (arg (xp-gpr-lisp xp regno)))
     189                    (case code
     190                      ((0 1)
     191                       (setf (xp-gpr-lisp xp regno)
     192                             (%kernel-restart-internal $xvunbnd
     193                                                       (list arg)
     194                                                       frame-ptr)))
     195                      (2
     196                       (%error (make-condition 'type-error
     197                                               :datum arg
     198                                               :expected-type '(or symbol function)
     199                                               :format-control
     200                                               "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
     201                               nil frame-ptr))
     202                      (4
     203                       (%error (make-condition 'cant-throw-error
     204                                               :tag arg)
     205                               nil frame-ptr))
     206                      (5
     207                       (handle-udf-call xp frame-ptr))
     208                      (6
     209                       (%err-disp-internal $xfunbnd (list arg) frame-ptr))
     210                      (t
     211                       (error "Unknown unary UUO with code ~d." code)))))
     212                 (14
     213                  (let* ((reg-a (ldb (byte 4 8) uuo))
     214                         (arg-b (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     215                         (arg-c (xp-gpr-lisp xp (ldb (byte 4 16) uuo))))
     216                    (setf (xp-gpr-lisp xp reg-a)
     217                          (%slot-unbound-trap arg-b arg-c frame-ptr))))
     218                 (15
     219                  (let* ((reg-a (ldb (byte 4 8) uuo))
     220                         (arga (xp-gpr-lisp xp reg-a))
     221                         (argb (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     222                         (code (ldb (byte 4 16) uuo)))
     223                    (case code
     224                      ((0 1)            ;do we report these the same way?
     225                       (%error (%rsc-string $xarroob)
     226                               (list arga argb)
     227                               frame-ptr))
     228                      (4
     229                       (let* ((eep-or-fv (xp-gpr-lisp xp (ldb (byte 4 12) uuo)))
     230                              (dest-reg (ldb (byte 4 8) uuo)))
     231                         (etypecase eep-or-fv
     232                           (external-entry-point
     233                            (resolve-eep eep-or-fv)
     234                            (setf (xp-gpr-lisp xp dest-reg)
     235                                  (eep.address eep-or-fv)))
     236                           (foreign-variable
     237                            (resolve-foreign-variable eep-or-fv)
     238                            (setf (xp-gpr-lisp xp dest-reg)
     239                                  (fv.addr eep-or-fv))))))
     240                      (t
     241                       (error "Unknown code in binary UUO: ~d" code)))))
     242                 (t
     243                  (error "Unknown UUO, format ~d" format))))))
     244          (t
     245           (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
     246                  error-number arg fnreg relative-pc))))))
Note: See TracChangeset for help on using the changeset viewer.