Changeset 10138


Ignore:
Timestamp:
Jul 19, 2008, 5:09:31 AM (11 years ago)
Author:
rme
Message:

Add x8632 support.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/x86-error-signal.lisp

    r7892 r10138  
    1818(in-package "CCL")
    1919
     20#+x8664-target
    2021(defun xp-argument-count (xp)
    2122  (ldb (byte (- 16 x8664::fixnumshift) 0)
    2223                    (encoded-gpr-lisp xp x8664::nargs.q)))
    2324
    24 
    25 
     25#+x8632-target
     26(defun xp-argument-count (xp)
     27  (encoded-gpr-lisp xp target::nargs))
     28
     29#+x8664-target
    2630(defun xp-argument-list (xp)
    2731  (let ((nargs (xp-argument-count xp))
     
    4145                   (push (%get-object sp (* i x8664::node-size)) args))
    4246                 args)))))))
    43                          
     47
     48#+x8632-target
     49(defun xp-argument-list (xp)
     50  (let ((nargs (xp-argument-count xp))
     51        (arg-y (encoded-gpr-lisp xp x8632::arg_y))
     52        (arg-z (encoded-gpr-lisp xp x8632::arg_z)))
     53    (cond ((eql nargs 0) nil)
     54          ((eql nargs 1) (list arg-z))
     55          (t
     56           (let ((args (list arg-y arg-z)))
     57             (if (eql nargs 2)
     58               args
     59               (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8632::esp)
     60                                   (+ x8632::node-size x8632::xcf.size))))
     61                 (dotimes (i (- nargs 2))
     62                   (push (%get-object sp (* i x8632::node-size)) args))
     63                 args)))))))
     64
    4465;;; Making this be continuable is hard, because of the xcf on the
    4566;;; stack and the way that the kernel saves/restores rsp and rbp
     
    5576                  (%kernel-restart-internal
    5677                   $xudfcall
    57                    (list (maybe-setf-name (encoded-gpr-lisp xp x8664::fname)) args)
     78                   (list (maybe-setf-name (encoded-gpr-lisp xp target::fname)) args)
    5879                   frame-ptr)))
    5980         (f #'(lambda (values) (apply #'values values))))
    60     (setf (encoded-gpr-lisp xp x8664::arg_z) values
    61           (encoded-gpr-lisp xp x8664::fn) f)))
    62  
     81    (setf (encoded-gpr-lisp xp target::arg_z) values
     82          (encoded-gpr-lisp xp target::fn) f)))
     83
     84#+x8664-target
    6385(defcallback %xerr-disp (:address xp :address xcf :int)
    6486  (with-error-reentry-detection
     
    232254          skip))))
    233255
    234 
    235          
     256;;; lots of duplicated code here
     257#+x8632-target
     258(defcallback %xerr-disp (:address xp :address xcf :int)
     259  (with-error-reentry-detection
     260      (let* ((frame-ptr (macptr->fixnum xcf))
     261             (fn (%get-object xcf x8632::xcf.nominal-function))
     262             (op0 (%get-xcf-byte xcf 0))
     263             (op1 (%get-xcf-byte xcf 1))
     264             (op2 (%get-xcf-byte xcf 2)))
     265        (declare (type (unsigned-byte 8) op0 op1 op2))
     266        (let* ((skip 2))
     267          (if (and (= op0 #xcd)
     268                   (>= op1 #x70))
     269            (cond ((< op1 #x90)
     270                   (setq skip 3)
     271                   (setq *error-reentry-count* 0)
     272                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
     273                         (%slot-unbound-trap
     274                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     275                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     276                          frame-ptr)))
     277                  ((< op1 #xa0)
     278                   ;; #x9x - register X is a symbol.  It's unbound.
     279                   (%kernel-restart-internal $xvunbnd
     280                                             (list
     281                                              (encoded-gpr-lisp
     282                                               xp
     283                                               (ldb (byte 4 0) op1)))
     284                                             frame-ptr))
     285                  ((< op1 #xb0)
     286                   (%err-disp-internal $xfunbnd
     287                                       (list (encoded-gpr-lisp
     288                                              xp
     289                                              (ldb (byte 4 0) op1)))
     290                                       frame-ptr))
     291                  ((< op1 #xc0)
     292                   (setq skip 3)
     293                   (%err-disp-internal
     294                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
     295                    (list (encoded-gpr-lisp
     296                           xp
     297                           (ldb (byte 4 0) op1))
     298                          (logandc2 op2 arch::error-type-error))
     299                    frame-ptr))
     300                  ((= op1 #xc0)
     301                   (%error 'too-few-arguments
     302                           (list :nargs (xp-argument-count xp)
     303                                 :fn fn)
     304                           frame-ptr))
     305                  ((= op1 #xc1)
     306                   (%error 'too-many-arguments
     307                           (list :nargs (xp-argument-count xp)
     308                                 :fn fn)
     309                           frame-ptr))
     310                  ((= op1 #xc2)
     311                   (let* ((flags (xp-flags-register xp))
     312                          (nargs (xp-argument-count xp))
     313                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
     314                     (if carry-bit
     315                       (%error 'too-few-arguments
     316                               (list :nargs nargs
     317                                     :fn fn)
     318                               frame-ptr)
     319                       (%error 'too-many-arguments
     320                               (list :nargs nargs
     321                                     :fn fn)
     322                               frame-ptr))))
     323                  ((= op1 #xc3)         ;array rank
     324                   (%err-disp-internal $XNDIMS
     325                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     326                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
     327                                       frame-ptr))
     328                  ((= op1 #xc6)
     329                   (%error (make-condition 'type-error
     330                                           :datum (encoded-gpr-lisp xp x8632::temp0)
     331                                           :expected-type '(or symbol function)
     332                                           :format-control
     333                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
     334                           nil frame-ptr))
     335                  ((= op1 #xc7)
     336                   (handle-udf-call xp frame-ptr)
     337                   (setq skip 0))
     338                  ((or (= op1 #xc8) (= op1 #xcb))
     339                   (setq skip 3)
     340                   (%error (%rsc-string $xarroob)
     341                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     342                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
     343                           frame-ptr))
     344                  ((= op1 #xc9)
     345                   (%err-disp-internal $xnotfun
     346                                       (list (encoded-gpr-lisp xp x8632::temp0))
     347                                       frame-ptr))
     348                  ;; #xca = uuo-error-debug-trap
     349                  ((= op1 #xcc)
     350                   ;; external entry point or foreign variable
     351                   (setq skip 3)
     352                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
     353                     (etypecase eep-or-fv
     354                       (external-entry-point
     355                        (resolve-eep eep-or-fv)
     356                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     357                              (eep.address eep-or-fv)))
     358                       (foreign-variable
     359                        (resolve-foreign-variable eep-or-fv)
     360                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     361                              (fv.addr eep-or-fv))))))
     362                  ((< op1 #xe0)
     363                   (setq skip 3)
     364                   (if (= op2 x8632::subtag-catch-frame)
     365                     (%error (make-condition 'cant-throw-error
     366                                             :tag (encoded-gpr-lisp
     367                                                   xp
     368                                                   (ldb (byte 4 0) op1)))
     369                             nil frame-ptr)
     370                     (let* ((typename
     371                             (cond ((= op2 x8632::tag-fixnum) 'fixnum)
     372                                   ((= op2 x8632::subtag-character) 'character)
     373                                   ((= op2 x8632::fulltag-cons) 'cons)
     374                                   ((= op2 x8632::tag-misc) 'uvector)
     375                                   (t (let* ((class (logand op2 x8632::fulltagmask))
     376                                             (high5 (ash op2 (- x8632::ntagbits))))
     377                                        (cond ((= class x8632::fulltag-nodeheader)
     378                                               (svref *nodeheader-types* high5))
     379                                              ((= class x8632::fulltag-immheader)
     380                                               (svref *immheader-types* high5))
     381                                              (t (list 'bogus op2))))))))
     382                       (%error (make-condition 'type-error
     383                                               :datum (encoded-gpr-lisp
     384                                                       xp
     385                                                       (ldb (byte 4 0) op1))
     386                                               :expected-type typename)
     387                               nil
     388                               frame-ptr))))
     389                  ((< op1 #xf0)
     390                   (%error (make-condition 'type-error
     391                                           :datum (encoded-gpr-lisp
     392                                                   xp
     393                                                   (ldb (byte 4 0) op1))
     394                                           :expected-type 'list)
     395                           nil
     396                           frame-ptr))
     397                  (t
     398                   (%error (make-condition 'type-error
     399                                           :datum (encoded-gpr-lisp
     400                                                   xp
     401                                                   (ldb (byte 4 0) op1))
     402                                           :expected-type 'fixnum)
     403                           nil
     404                           frame-ptr)))
     405            (%error "Unknown trap: #x~x~%xp=~s"
     406                    (list (list op0 op1 op2) xp)
     407                    frame-ptr))
     408          skip))))
    236409                 
    237                  
    238                
    239                
    240                  
    241 
    242 
    243 
    244 
    245 
    246                    
    247                
    248            
Note: See TracChangeset for help on using the changeset viewer.