;;; x86-trap-support ;;; ;;; Copyright (C) 2005-2009 Clozure Associates and contributors ;;; 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") #+x8664-target (defun xp-argument-count (xp) (ldb (byte (- 16 x8664::fixnumshift) 0) (encoded-gpr-lisp xp x8664::nargs.q))) #+x8632-target (defun xp-argument-count (xp) (encoded-gpr-lisp xp target::nargs)) #+x8664-target (defun xp-argument-list (xp) (let ((nargs (xp-argument-count xp)) (arg-x (encoded-gpr-lisp xp x8664::arg_x)) (arg-y (encoded-gpr-lisp xp x8664::arg_y)) (arg-z (encoded-gpr-lisp xp x8664::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 ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp) (+ x8664::node-size x8664::xcf.size)))) (dotimes (i (- nargs 3)) (push (%get-object sp (* i x8664::node-size)) args)) args))))))) #+x8632-target (defun xp-argument-list (xp) (let ((nargs (xp-argument-count xp)) (arg-y (encoded-gpr-lisp xp x8632::arg_y)) (arg-z (encoded-gpr-lisp xp x8632::arg_z))) (cond ((eql nargs 0) nil) ((eql nargs 1) (list arg-z)) (t (let ((args (list arg-y arg-z))) (if (eql nargs 2) args (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8632::ebp) (+ x8632::node-size x8632::xcf.size)))) (dotimes (i (- nargs 2)) (push (%get-object sp (* i x8632::node-size)) args)) args))))))) ;;; Making this be continuable is hard, because of the xcf on the ;;; stack and the way that the kernel saves/restores rsp and rbp ;;; before calling out. If we get around those problems, then ;;; we have to also deal with the fact that the return address ;;; is on the stack. Easiest to make the kernel deal with that, ;;; and just set %fn to the function that returns the values ;;; returned by the (newly defined) function and %arg_z to ;;; that list of values. (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 (encoded-gpr-lisp xp target::fname)) args) frame-ptr))) (f #'(lambda (values) (apply #'values values)))) (setf (encoded-gpr-lisp xp target::arg_z) values (encoded-gpr-lisp xp target::fn) f))) #+x8664-target (defcallback %xerr-disp (:address xp :address xcf :int) (with-error-reentry-detection (let* ((frame-ptr (macptr->fixnum xcf)) (fn (%get-object xcf x8664::xcf.nominal-function)) (op0 (%get-xcf-byte xcf 0)) (op1 (%get-xcf-byte xcf 1)) (op2 (%get-xcf-byte xcf 2))) (declare (type (unsigned-byte 8) op0 op1 op2)) (let* ((skip 2)) (if (and (= op0 #xcd) (>= op1 #x70)) (cond ((< op1 #x90) (setq skip (%check-anchored-uuo xcf 3)) (setq *error-reentry-count* 0) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) (%slot-unbound-trap (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) frame-ptr))) ((= op1 #x90) (setq skip (%check-anchored-uuo xcf 3)) (setf (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (%kernel-restart-internal $xvunbnd (list (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) frame-ptr))) ((< op1 #xa0) (setq skip (%check-anchored-uuo xcf 2)) ;; #x9x, x>0 - register X is a symbol. It's unbound, ;; but we don't have enough info to offer USE-VALUE, ;; STORE-VALUE, or CONTINUE restarts. (%error (make-condition 'unbound-variable :name (encoded-gpr-lisp xp (ldb (byte 4 0) op1))) () frame-ptr)) ((< op1 #xb0) (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xfunbnd (list (encoded-gpr-lisp xp (ldb (byte 4 0) op1))) frame-ptr)) ((< op1 #xc0) (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal #.(car (rassoc 'type-error *kernel-simple-error-classes*)) (list (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) (logandc2 op2 arch::error-type-error)) frame-ptr)) ((= op1 #xc0) (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-few-arguments (list :nargs (xp-argument-count xp) :fn fn) frame-ptr)) ((= op1 #xc1) (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-many-arguments (list :nargs (xp-argument-count xp) :fn fn) frame-ptr)) ((= op1 #xc2) (setq skip (%check-anchored-uuo xcf 2)) (let* ((flags (xp-flags-register xp)) (nargs (xp-argument-count xp)) (carry-bit (logbitp x86::x86-carry-flag-bit flags))) (if carry-bit (%error 'too-few-arguments (list :nargs nargs :fn fn) frame-ptr) (%error 'too-many-arguments (list :nargs nargs :fn fn) frame-ptr)))) ((= op1 #xc3) ;array rank (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal $XNDIMS (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) frame-ptr)) ((= op1 #xc6) (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp x8664::temp0) :expected-type '(or symbol function) :format-control "~S is not of type ~S, and can't be FUNCALLed or APPLYed") nil frame-ptr)) ((= op1 #xc7) (handle-udf-call xp frame-ptr) (setq skip 0)) ((or (= op1 #xc8) (= op1 #xcb)) (setq skip (%check-anchored-uuo xcf 3)) (%error (%rsc-string $xarroob) (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) frame-ptr)) ((= op1 #xc9) (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xnotfun (list (encoded-gpr-lisp xp x8664::temp0)) frame-ptr)) ;; #xca = uuo-error-debug-trap ((= op1 #xcc) ;; external entry point or foreign variable (setq skip (%check-anchored-uuo xcf 3)) (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) (etypecase eep-or-fv (external-entry-point (resolve-eep eep-or-fv) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) (eep.address eep-or-fv))) (foreign-variable (resolve-foreign-variable eep-or-fv) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) (fv.addr eep-or-fv)))))) ((< op1 #xe0) (setq skip (%check-anchored-uuo xcf 3)) (if (= op2 x8664::subtag-catch-frame) (%error (make-condition 'cant-throw-error :tag (encoded-gpr-lisp xp (ldb (byte 4 0) op1))) nil frame-ptr) (let* ((typename (cond ((= op2 x8664::tag-fixnum) 'fixnum) ((= op2 x8664::tag-single-float) 'single-float) ((= op2 x8664::subtag-character) 'character) ((= op2 x8664::fulltag-cons) 'cons) ((= op2 x8664::tag-misc) 'uvector) ((= op2 x8664::fulltag-symbol) 'symbol) ((= op2 x8664::fulltag-function) 'function) (t (let* ((class (logand op2 x8664::fulltagmask)) (high4 (ash op2 (- x8664::ntagbits)))) (cond ((= class x8664::fulltag-nodeheader-0) (svref *nodeheader-0-types* high4)) ((= class x8664::fulltag-nodeheader-1) (svref *nodeheader-1-types* high4)) ((= class x8664::fulltag-immheader-0) (svref *immheader-0-types* high4)) ((= class x8664::fulltag-immheader-1) (svref *immheader-1-types* high4)) ((= class x8664::fulltag-immheader-2) (svref *immheader-2-types* high4)) (t (list 'bogus op2)))))))) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) :expected-type typename) nil frame-ptr)))) ((< op1 #xf0) (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) :expected-type 'list) nil frame-ptr)) (t (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) :expected-type 'fixnum) nil frame-ptr))) (%error "Unknown trap: #x~x~%xp=~s" (list (list op0 op1 op2) xp) frame-ptr)) skip)))) ;;; lots of duplicated code here #+x8632-target (defcallback %xerr-disp (:address xp :address xcf :int) (with-error-reentry-detection (let* ((frame-ptr (macptr->fixnum xcf)) (fn (%get-object xcf x8632::xcf.nominal-function)) (op0 (%get-xcf-byte xcf 0)) (op1 (%get-xcf-byte xcf 1)) (op2 (%get-xcf-byte xcf 2))) (declare (type (unsigned-byte 8) op0 op1 op2)) (let* ((skip 2)) (if (and (= op0 #xcd) (>= op1 #x70)) (cond ((< op1 #x90) (setq skip (%check-anchored-uuo xcf 3)) (setq *error-reentry-count* 0) (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) (%slot-unbound-trap (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) frame-ptr))) ((= op1 #x90) (setq skip (%check-anchored-uuo xcf 3)) (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op2)) (%kernel-restart-internal $xvunbnd (list (encoded-gpr-lisp xp (ldb (byte 3 0) op2))) frame-ptr))) ((< op1 #xa0) (setq skip (%check-anchored-uuo xcf 2)) ;; #x9x, x>- - register X is a symbol. It's unbound, ;; but we don't have enough info to offer USE-VALUE, ;; STORE-VALUE, or CONTINUE restart (%error (make-condition 'unbound-variable :name (encoded-gpr-lisp xp (ldb (byte 3 0) op1))) () frame-ptr)) ((< op1 #xb0) (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xfunbnd (list (encoded-gpr-lisp xp (ldb (byte 3 0) op1))) frame-ptr)) ((< op1 #xc0) (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal #.(car (rassoc 'type-error *kernel-simple-error-classes*)) (list (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) (logandc2 op2 arch::error-type-error)) frame-ptr)) ((= op1 #xc0) (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-few-arguments (list :nargs (xp-argument-count xp) :fn fn) frame-ptr)) ((= op1 #xc1) (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-many-arguments (list :nargs (xp-argument-count xp) :fn fn) frame-ptr)) ((= op1 #xc2) (setq skip (%check-anchored-uuo xcf 2)) (let* ((flags (xp-flags-register xp)) (nargs (xp-argument-count xp)) (carry-bit (logbitp x86::x86-carry-flag-bit flags))) (if carry-bit (%error 'too-few-arguments (list :nargs nargs :fn fn) frame-ptr) (%error 'too-many-arguments (list :nargs nargs :fn fn) frame-ptr)))) ((= op1 #xc3) ;array rank (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal $XNDIMS (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) frame-ptr)) ((= op1 #xc6) (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp x8632::temp0) :expected-type '(or symbol function) :format-control "~S is not of type ~S, and can't be FUNCALLed or APPLYed") nil frame-ptr)) ((= op1 #xc7) (handle-udf-call xp frame-ptr) (setq skip 0)) ((or (= op1 #xc8) (= op1 #xcb)) (setq skip (%check-anchored-uuo xcf 3)) (%error (%rsc-string $xarroob) (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) frame-ptr)) ((= op1 #xc9) (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xnotfun (list (encoded-gpr-lisp xp x8632::temp0)) frame-ptr)) ;; #xca = uuo-error-debug-trap ((= op1 #xcc) ;; external entry point or foreign variable (setq skip (%check-anchored-uuo xcf 3)) (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) (etypecase eep-or-fv (external-entry-point (resolve-eep eep-or-fv) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) (eep.address eep-or-fv))) (foreign-variable (resolve-foreign-variable eep-or-fv) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) (fv.addr eep-or-fv)))))) ((< op1 #xe0) (setq skip (%check-anchored-uuo xcf 3)) (if (= op2 x8632::subtag-catch-frame) (%error (make-condition 'cant-throw-error :tag (encoded-gpr-lisp xp (ldb (byte 3 0) op1))) nil frame-ptr) (let* ((typename (cond ((= op2 x8632::tag-fixnum) 'fixnum) ((= op2 x8632::subtag-character) 'character) ((= op2 x8632::fulltag-cons) 'cons) ((= op2 x8632::tag-misc) 'uvector) (t (let* ((class (logand op2 x8632::fulltagmask)) (high5 (ash op2 (- x8632::ntagbits)))) (cond ((= class x8632::fulltag-nodeheader) (svref *nodeheader-types* high5)) ((= class x8632::fulltag-immheader) (svref *immheader-types* high5)) (t (list 'bogus op2)))))))) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) :expected-type typename) nil frame-ptr)))) ((< op1 #xf0) (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) :expected-type 'list) nil frame-ptr)) (t (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) :expected-type 'fixnum) nil frame-ptr))) (%error "Unknown trap: #x~x~%xp=~s" (list (list op0 op1 op2) xp) frame-ptr)) skip))))