;;; ppc-trap-support ;;; ;;; Copyright (C) 2009 Clozure Associates ;;; Copyright (C) 1994-2001 Digitool, Inc ;;; 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 ;;; Support for PPC traps, this includes the event-poll trap ;;; and all the trxxx traps for type checks & arg count checks. (in-package "CCL") (eval-when (:compile-toplevel :execute) (require "NUMBER-MACROS") (defparameter *ppc-instruction-fields* `((:opcode . ,(byte 6 26)) (:rt . ,(byte 5 21)) (:to . ,(byte 5 21)) (:ra . ,(byte 5 16)) (:rb . ,(byte 5 11)) (:d . ,(byte 16 0)) (:ds . ,(byte 14 2)) (:ds-xo . ,(byte 2 0)) (:sh . ,(byte 5 11)) (:mb . ,(byte 5 6)) (:me . ,(byte 5 1)) (:mb6 . ,(byte 6 5)) (:me6 . ,(byte 6 5)) (:sh6 . ,(byte 1 1)) (:x-minor . ,(byte 10 1)) (:fulltag32 . ,(byte ppc32::ntagbits 0)) (:lisptag32 . ,(byte ppc32::nlisptagbits 0)) (:fulltag64 . ,(byte ppc64::ntagbits 0)) (:lisptag64 . ,(byte ppc64::nlisptagbits 0)) (:lowtag64 . ,(byte ppc64::nlowtagbits 0)))) (defun ppc-instruction-field (field-name) (or (cdr (assoc field-name *ppc-instruction-fields*)) (error "Unknown PPC instruction field: ~s" field-name))) (defun ppc-instruction-field-mask (field-spec) (let* ((name (if (atom field-spec) field-spec (car field-spec))) (value (if (atom field-spec) -1 (cadr field-spec)))) (dpb value (ppc-instruction-field name) 0))) #+darwinppc-target (progn (def-foreign-type nil (:struct :darwin-ppc-float-state (:fpregs (:array :double 32)) (:fpscr-pad (:unsigned 32)) (:fpscr (:unsigned 32)))) (def-foreign-type nil (:struct :darwin-ppc-vector-state (:save-vr (:array (:array (:unsigned 32) 4) 32)) (:save-vscr (:array (:unsigned 32) 4)) (:save-pad5 (:array (:unsigned 32) 4)) (:save-vrvalid (:unsigned 32)) (:save-pad6 (:array (:unsigned 32) 7)))) #+ppc64-target (progn (def-foreign-type nil (:struct :darwin-ppc-exception-state64 (:dar (:unsigned 64)) (:dsisr (:unsigned 32)) (:exception (:unsigned 32)) (:pad1 (:array (:unsigned 32) 4)))) (def-foreign-type nil ;; The real record type is defined with ;; #pragma pack(4) in effect. ;; The :struct parser should really accept ;; some option to deal with that, but Apple ;; should also stop mis-aligning things. (:struct :darwin-ppc-thread-state64 (:srr0 (:unsigned 64)) (:srr1 (:unsigned 64)) (:r0 (:unsigned 64)) (:r1 (:unsigned 64)) (:r2 (:unsigned 64)) (:r3 (:unsigned 64)) (:r4 (:unsigned 64)) (:r5 (:unsigned 64)) (:r6 (:unsigned 64)) (:r7 (:unsigned 64)) (:r8 (:unsigned 64)) (:r9 (:unsigned 64)) (:r10 (:unsigned 64)) (:r11 (:unsigned 64)) (:r12 (:unsigned 64)) (:r13 (:unsigned 64)) (:r14 (:unsigned 64)) (:r15 (:unsigned 64)) (:r16 (:unsigned 64)) (:r17 (:unsigned 64)) (:r18 (:unsigned 64)) (:r19 (:unsigned 64)) (:r20 (:unsigned 64)) (:r21 (:unsigned 64)) (:r22 (:unsigned 64)) (:r23 (:unsigned 64)) (:r24 (:unsigned 64)) (:r25 (:unsigned 64)) (:r26 (:unsigned 64)) (:r27 (:unsigned 64)) (:r28 (:unsigned 64)) (:r29 (:unsigned 64)) (:r30 (:unsigned 64)) (:r31 (:unsigned 64)) (:cr (:unsigned 32)) (:xer (:unsigned 32)) (:xer-low (:unsigned 32)) (:lr (:unsigned 32)) (:lr-low (:unsigned 32)) (:ctr (:unsigned 32)) (:ctr-low (:unsigned 32)) (:vrsave (:unsigned 32)))) (def-foreign-type nil (:struct :darwin-sigaltstack64 (:ss-sp (:* :void)) (:ss-size (:unsigned 64)) (:ss-flags (:unsigned 32)))) (def-foreign-type nil (:struct :darwin-mcontext64 (:es (:struct :darwin-ppc-exception-state64)) (:ss (:struct :darwin-ppc-thread-state64)) (:fs (:struct :darwin-ppc-float-state)) (:vs (:struct :darwin-ppc-vector-state)))) (def-foreign-type nil (:struct :darwin-ucontext64 (:uc-onstack (:signed 32)) (:uc-sigmask (:signed 32)) (:uc-stack (:struct :darwin-sigaltstack64)) (:uc-link (:* (:struct :darwin-ucontext64))) (:uc-mcsize (:signed 64)) (:uc-mcontext64 (:* (:struct :darwin-mcontext64))))) ) #+ppc32-target (progn (def-foreign-type nil (:struct :darwin-ppc-exception-state32 (:dar (:unsigned 32)) (:dsisr (:unsigned 32)) (:exception (:unsigned 32)) (:pad0 (:unsigned 32)) (:pad1 (:array (:unsigned 32) 4)))) (def-foreign-type nil (:struct :darwin-ppc-thread-state32 (:srr0 (:unsigned 32)) (:srr1 (:unsigned 32)) (:r0 (:unsigned 32)) (:r1 (:unsigned 32)) (:r2 (:unsigned 32)) (:r3 (:unsigned 32)) (:r4 (:unsigned 32)) (:r5 (:unsigned 32)) (:r6 (:unsigned 32)) (:r7 (:unsigned 32)) (:r8 (:unsigned 32)) (:r9 (:unsigned 32)) (:r10 (:unsigned 32)) (:r11 (:unsigned 32)) (:r12 (:unsigned 32)) (:r13 (:unsigned 32)) (:r14 (:unsigned 32)) (:r15 (:unsigned 32)) (:r16 (:unsigned 32)) (:r17 (:unsigned 32)) (:r18 (:unsigned 32)) (:r19 (:unsigned 32)) (:r20 (:unsigned 32)) (:r21 (:unsigned 32)) (:r22 (:unsigned 32)) (:r23 (:unsigned 32)) (:r24 (:unsigned 32)) (:r25 (:unsigned 32)) (:r26 (:unsigned 32)) (:r27 (:unsigned 32)) (:r28 (:unsigned 32)) (:r29 (:unsigned 32)) (:r30 (:unsigned 32)) (:r31 (:unsigned 32)) (:cr (:unsigned 32)) (:xer (:unsigned 32)) (:lr (:unsigned 32)) (:ctr (:unsigned 32)) (:mq (:unsigned 32)) ; ppc 601! (:vrsave (:unsigned 32)))) (def-foreign-type nil (:struct :darwin-sigaltstack32 (:ss-sp (:* :void)) (:ss-size (:unsigned 32)) (:ss-flags (:unsigned 32)))) (def-foreign-type nil (:struct :darwin-mcontext32 (:es (:struct :darwin-ppc-exception-state32)) (:ss (:struct :darwin-ppc-thread-state32)) (:fs (:struct :darwin-ppc-float-state)) (:vs (:struct :darwin-ppc-vector-state)))) (def-foreign-type nil (:struct :darwin-ucontext32 (:uc-onstack (:signed 32)) (:uc-sigmask (:signed 32)) (:uc-stack (:struct :darwin-sigaltstack32)) (:uc-link (:* (:struct :darwin-ucontext32))) (:uc-mcsize (:signed 32)) (:uc-mcontext32 (:* (:struct :darwin-mcontext32))))) ) ) (defmacro with-xp-registers-and-gpr-offset ((xp register-number) (registers offset) &body body) (let* ((regform #+linuxppc-target `(pref ,xp :ucontext.uc_mcontext.regs) #+darwinppc-target (target-arch-case ;; Gak. Apple gratuitously renamed things ;; for Leopard. Hey, it's not as if anyone ;; has better things to do than to deal with ;; this crap ... (:ppc32 `(pref ,xp :darwin-ucontext32.uc-mcontext32.ss)) (:ppc64 `(pref ,xp :darwin-ucontext64.uc-mcontext64.ss))))) `(with-macptrs ((,registers ,regform)) (let ((,offset (xp-gpr-offset ,register-number))) ,@body)))) (defmacro RA-field (instr) `(ldb (byte 5 16) ,instr)) (defmacro RB-field (instr) `(ldb (byte 5 11) ,instr)) (defmacro D-field (instr) `(ldb (byte 16 0) ,instr)) (defmacro RS-field (instr) `(ldb (byte 5 21) ,instr)) (defmacro lisp-reg-p (reg) `(>= ,reg ppc::fn)) (defmacro ppc-lap-word (instruction-form) (uvref (uvref (compile nil `(lambda (&lap 0) (ppc-lap-function () ((?? 0)) ,instruction-form))) 0) #+ppc32-host 0 #+ppc64-host 1)) (defmacro ppc-instruction-mask (&rest fields) `(logior ,@(mapcar #'ppc-instruction-field-mask (cons :opcode fields)))) ) (defun xp-gpr-offset (register-number) (unless (and (fixnump register-number) (<= -2 (the fixnum register-number)) (< (the fixnum register-number) 48)) (setq register-number (require-type register-number '(integer -2 48)))) (the fixnum (* (the fixnum #+linuxppc-target register-number #+darwinppc-target (+ register-number 2)) target::node-size))) (defun xp-gpr-lisp (xp register-number) (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) (values (%get-object registers offset)))) (defun (setf xp-gpr-lisp) (value xp register-number) (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) (%set-object registers offset value))) (defun xp-gpr-signed-long (xp register-number) (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) (values (%get-signed-long registers offset)))) (defun xp-gpr-signed-doubleword (xp register-number) (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) (values (%%get-signed-longlong registers offset)))) (defun xp-gpr-macptr (xp register-number) (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) (values (%get-ptr registers offset)))) (defun xp-argument-list (xp) (let ((nargs (xp-gpr-lisp xp ppc::nargs)) ; tagged as a fixnum (how convenient) (arg-x (xp-gpr-lisp xp ppc::arg_x)) (arg-y (xp-gpr-lisp xp ppc::arg_y)) (arg-z (xp-gpr-lisp xp ppc::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 ppc::vsp))) (dotimes (i (- nargs 3)) (push (%get-object vsp (* i target::node-size)) args)) args))))))) (defun xp-fpscr-info (xp) (let* ((fpscr #+(and linuxppc-target 32-bit-target) (%get-unsigned-long (pref xp :ucontext.uc_mcontext.regs) (ash #$PT_FPSCR 2)) #+(and linuxppc-target 64-bit-target) (%get-unsigned-long (pref xp :ucontext.uc_mcontext.fp_regs) (ash 65 2)) #+(and darwinppc-target ppc32-target) (pref xp :darwin-ucontext32.uc-mcontext32.fs.fpscr) #+(and darwinppc-target ppc64-target) (pref xp :darwin-ucontext64.uc-mcontext64.fs.fpscr))) (values (ldb (byte 24 8) fpscr) (ldb (byte 8 0) fpscr)))) #+linuxppc-target (defun xp-double-float (xp fpr) #+32-bit-target (%get-double-float (pref xp :ucontext.uc_mcontext.regs) (+ (ash #$PT_FPR0 2) (ash fpr 3))) #+64-bit-target (%get-double-float (pref xp :ucontext.uc_mcontext.fp_regs) (ash fpr 3)) ) #+darwinppc-target (defun xp-double-float (xp fpr) (%get-double-float #+ppc32-target (pref xp :darwin-ucontext32.uc-mcontext32.fs) #+ppc64-target (pref xp :darwin-ucontext64.uc-mcontext64.fs) (ash fpr 3))) (defparameter *trap-lookup-tries* 5) (defun %scan-for-instr (mask opcode fn pc-index tries) (let ((code-vector (and fn (uvref fn 0))) (offset 0)) (declare (fixnum offset)) (flet ((get-instr () (if code-vector (let ((index (+ pc-index offset))) (when (< index 0) (return-from %scan-for-instr nil)) (uvref code-vector index)) (%get-long pc-index (the fixnum (* 4 offset)))))) (declare (dynamic-extent #'get-instr)) (dotimes (i tries) (decf offset) (let ((instr (get-instr))) (when (match-instr instr mask opcode) (return instr)) (when (codevec-header-p instr) (return nil))))))) (defun return-address-offset (xp fn machine-state-offset) (with-macptrs ((regs (pref xp #+linuxppc-target :ucontext.uc_mcontext.regs #+(and darwinppc-target ppc32-target) :darwin-ucontext32.uc-mcontext32 #+(and darwinppc-target ppc64-target) :darwin-ucontext64.uc-mcontext64))) (if (functionp fn) (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset)) (%get-ptr regs machine-state-offset)) (%get-ptr regs machine-state-offset)))) (defconstant lr-offset-in-register-context #+linuxppc-target (ash #$PT_LNK target::word-shift) #+(and darwinppc-target ppc32-target) (+ (get-field-offset :darwin-mcontext32.ss) (get-field-offset :darwin-ppc-thread-state32.lr)) #+(and darwinppc-target ppc64-target) (+ (get-field-offset :darwin-mcontext64.ss) (get-field-offset :darwin-ppc-thread-state64.lr))) (defconstant pc-offset-in-register-context #+linuxppc-target (ash #$PT_NIP target::word-shift) #+(and darwinppc-target ppc32-target) (+ (get-field-offset :darwin-mcontext32.ss) (get-field-offset :darwin-ppc-thread-state32.srr0)) #+(and darwinppc-target ppc64-target) (+ (get-field-offset :darwin-mcontext64.ss) (get-field-offset :darwin-ppc-thread-state64.srr0))) ;;; When a trap happens, we may have not yet created control ;;; stack frames for the functions containing PC & LR. ;;; If that is the case, we add fake-stack-frame's to *fake-stack-frames* ;;; There are 4 cases: ;;; ;;; PC in FN ;;; Push 1 stack frame: PC/FN ;;; This might miss one recursive call, but it won't miss any variables ;;; PC in NFN ;;; Push 2 stack frames: ;;; 1) PC/NFN/VSP ;;; 2) LR/FN/VSP ;;; This might think some of NFN's variables are part of FN's stack frame, ;;; but that's the best we can do. ;;; LR in FN ;;; Push 1 stack frame: LR/FN ;;; None of the above ;;; Push no new stack frames ;;; ;;; The backtrace support functions in "ccl:l1;l1-lisp-threads.lisp" know how ;;; to find the fake stack frames and handle them as arguments. (defun funcall-with-xp-stack-frames (xp trap-function thunk) (cond ((null trap-function) ; Maybe inside a subprim from a lisp function (let* ((fn (xp-gpr-lisp xp ppc::fn)) (lr (return-address-offset xp fn lr-offset-in-register-context))) (if (fixnump lr) (let* ((sp (xp-gpr-lisp xp ppc::sp)) (vsp (xp-gpr-lisp xp ppc::vsp)) (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) (*fake-stack-frames* frame)) (declare (dynamic-extent frame)) (funcall thunk frame)) (funcall thunk (xp-gpr-lisp xp ppc::sp))))) ((eq trap-function (xp-gpr-lisp xp ppc::fn)) (let* ((sp (xp-gpr-lisp xp ppc::sp)) (fn trap-function) (lr (return-address-offset xp fn pc-offset-in-register-context)) (vsp (xp-gpr-lisp xp ppc::vsp)) (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) (*fake-stack-frames* frame)) (declare (dynamic-extent frame)) (funcall thunk frame))) ((eq trap-function (xp-gpr-lisp xp ppc::nfn)) (let* ((sp (xp-gpr-lisp xp ppc::sp)) (fn (xp-gpr-lisp xp ppc::fn)) (lr (return-address-offset xp fn lr-offset-in-register-context)) (vsp (xp-gpr-lisp xp ppc::vsp)) (lr-frame (%cons-fake-stack-frame sp sp fn lr vsp xp)) (pc-fn trap-function) (pc-lr (return-address-offset xp pc-fn pc-offset-in-register-context)) (pc-frame (%cons-fake-stack-frame sp lr-frame pc-fn pc-lr vsp xp *fake-stack-frames*)) (*fake-stack-frames* pc-frame)) (declare (dynamic-extent lr-frame pc-frame)) (funcall thunk pc-frame))) (t (funcall thunk (xp-gpr-lisp xp ppc::sp))))) ;;; Enter here from handle-trap in "lisp-exceptions.c". ;;; xp is a pointer to an ExceptionInformationPowerPC record. ;;; the-trap is the trap instruction that got us here. ;;; fn-reg is either fn, nfn or 0. If it is fn or nfn, then ;;; the trap occcurred in that register's code vector. ;;; If it is 0, then the trap occurred somewhere else. ;;; pc-index is either the index in fn-reg's code vector ;;; or, if fn-reg is 0, the address of the PC at the trap instruction. ;;; This code parallels the trap decoding code in ;;; "lisp-exceptions.c" that runs if (symbol-value 'cmain) ;;; is not a macptr. ;;; Some of these could probably call %err-disp instead of error, ;;; but I was too lazy to look them up. #+ppc32-target (defcallback xcmain (:without-interrupts t :address xp :unsigned-fullword fn-reg :address pc-or-index :unsigned-fullword the-trap :signed-fullword arg-0 :signed-fullword arg-1) ;; twgti nargs,0 ;; time for event polling. ;; This used to happen a lot so we test for it first. (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) (with-xp-stack-frames (xp fn frame-ptr) (if (eql the-trap (ppc-lap-word (twgti nargs 0))) (cmain) (with-error-reentry-detection (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) instr ra temp rs condition) (cond ((= the-trap #$SIGBUS) (%error (make-condition 'invalid-memory-access :address arg-0 :write-p (not (zerop arg-1))) () frame-ptr)) ;; tweqi RA nil-value - resolve-eep, or resolve-foreign-variable ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tweqi ?? (target-nil-value)))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lwz ?? (+ 4 ppc32::misc-data-offset) ??)) fn pc-index))) (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) (etypecase eep-or-fv (external-entry-point (resolve-eep eep-or-fv) (setf (xp-gpr-lisp xp (RA-field the-trap)) (eep.address eep-or-fv))) (foreign-variable (resolve-foreign-variable eep-or-fv) (setf (xp-gpr-lisp xp (RA-field the-trap)) (fv.addr eep-or-fv)))))) ;; twnei RA,N; RA = nargs ;; nargs check, no optional or rest involved ((match-instr the-trap (ppc-instruction-mask :opcode :to :ra) (ppc-lap-word (twnei nargs ??))) (%error (if (< (xp-GPR-signed-long xp ppc::nargs) (D-field the-trap)) 'too-few-arguments 'too-many-arguments ) (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) (- ppc32::fixnumshift)) :fn fn) frame-ptr)) ;; twnei RA,N; RA != nargs, N = fulltag_node/immheader ;; type check; look for "lbz rt-imm,-3(ra-node)" ((and (or (match-instr the-trap (ppc-instruction-mask :opcode :to :fulltag32) (ppc-lap-word (twnei ?? ppc32::fulltag-nodeheader))) (match-instr the-trap (ppc-instruction-mask :opcode :to :fulltag32) (ppc-lap-word (twnei ?? ppc32::fulltag-immheader)))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lbz ?? ppc32::misc-subtag-offset ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (let* ((typecode (D-field the-trap)) (type-tag (logand typecode ppc32::fulltagmask)) (type-name (svref (if (eql type-tag ppc32::fulltag-nodeheader) *nodeheader-types* *immheader-types*) (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) typecode)))) (%error (make-condition 'type-error :format-control (%rsc-string $XWRONGTYPE) :datum (xp-GPR-lisp xp ra) :expected-type type-name) nil frame-ptr))) ;; twnei RA,N; RA != nargs, N = subtag_character ;; type check; look for "clrlwi rs-node,ra-imm,24" = "rlwinm rs,ra,0,24,31" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (twnei ?? ppc32::subtag-character))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb :mb :me) (ppc-lap-word (rlwinm ?? ?? 0 24 31)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'character) nil frame-ptr)) ;; twnei RA,N; RA != nargs, N != fulltag_node/immheader ;; (since that case was handled above.) ;; type check; look for "clrlwi rs-node,ra-imm,29/30" = "rlwinm rs,ra,0,29/30,31" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to) (ppc-lap-word (twnei ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb (:mb 28) :me) (ppc-lap-word (rlwinm ?? ?? 0 28 31)) fn pc-index)) (or (eql (- 32 ppc32::ntagbits) (setq temp (ldb #.(ppc-instruction-field :mb) instr))) (eql (- 32 ppc32::nlisptagbits) temp)) (lisp-reg-p (setq rs (RS-field instr)))) (let* ((tag (logand the-trap ppc32::tagmask)) (type-name (case tag (#.ppc32::tag-fixnum 'fixnum) (#.ppc32::tag-list (if (eql temp (- 32 ppc32::ntagbits)) 'cons 'list)) (#.ppc32::tag-misc 'uvector) (#.ppc32::tag-imm 'immediate)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type type-name) nil frame-ptr))) ;; twlgti RA,N; RA = nargs (xy = 01) ;; twllti RA,N; RA = nargs (xy = 10) ;; nargs check, optional or rest involved ((and (match-instr the-trap (ppc-instruction-mask :opcode (:to #x1c) :ra) (ppc-lap-word (twi ?? ppc::nargs ??))) (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) (eql #b10 temp))) (%error (if (eql temp #b10) 'too-few-arguments 'too-many-arguments) (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) (- ppc32::fixnumshift)) :fn fn) frame-ptr)) ;; tweqi RA,N; N = unbound ;; symeval boundp check; look for "lwz RA,symbol.vcell(nodereg)" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tweqi ?? ppc32::unbound-marker))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lwz ?? ppc32::symbol.vcell ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (setf (xp-GPR-lisp xp (RA-field the-trap)) (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) ;; tweqi RA,N: n = (%slot-unbound-marker) ;; slot-unbound trap. Look for preceding "lwzx RA,rx,ry". ;; rx = slots-vector, ry = scaled index in slots vector. ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tweqi ?? ppc32::slot-unbound-marker))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rt :x-minor) (dpb (RA-field the-trap) (byte 5 21) (ppc-lap-word (lwzx ?? ?? ??))) fn pc-index))) (setq *error-reentry-count* 0) ; succesfully reported error ;; %SLOT-UNBOUND-TRAP will decode the arguments further, ;; then call the generic function SLOT-UNBOUND. That ;; might return a value; if so, set the value of the ;; register that caused the trap to that value. (setf (xp-gpr-lisp xp (ra-field the-trap)) (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) (ash (- (xp-gpr-signed-long xp (RB-field instr)) ppc32::misc-data-offset) (- ppc32::word-shift)) frame-ptr))) ;; twlge RA,RB ;; vector bounds check; look for "lwz immreg, misc_header_offset(nodereg)" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :x-minor) (ppc-lap-word (twlge 0 0))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|#) (ppc-lap-word (lwz ?? ?? #|ppc32::misc-header-offset|# ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (%error (%rsc-string $xarroob) (list (xp-GPR-lisp xp (RA-field the-trap)) (xp-GPR-lisp xp ra)) frame-ptr)) ;; twi 27 ra d - array header rank check ((and (match-instr the-trap (ppc-instruction-mask :opcode :to) (ppc-lap-word (twi 27 ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lwz ?? ppc32::arrayH.rank ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (%error (%rsc-string $xndims) (list (xp-gpr-lisp xp ra) (ash (ldb (byte 16 0) the-trap) (- ppc32::fixnumshift))) frame-ptr)) ;; tw 27 ra rb - array flags check ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :x-minor) (ppc-lap-word (tw 27 ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lwz ?? ppc32::arrayH.flags ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr))) (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) (expected-subtype (ldb ppc32::arrayH.flags-cell-subtag-byte expected)) (expect-simple (= (ldb ppc32::arrayH.flags-cell-bits-byte expected) (ash 1 $arh_simple_bit))) (type-name (case expected-subtype (#.ppc32::subtag-double-float-vector 'double-float)))) (and type-name expect-simple (setq condition (make-condition 'type-error :datum (xp-gpr-lisp xp ra) :expected-type `(simple-array ,type-name)))))) (%error condition nil frame-ptr)) ;; Unknown trap (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" (list the-trap xp fn (ash pc-index ppc32::fixnumshift)) frame-ptr))))))))) #+ppc64-target (defcallback xcmain (:without-interrupts t :address xp :unsigned-fullword fn-reg :address pc-or-index :unsigned-fullword the-trap :signed-doubleword arg0 :signed-doubleword arg1) ;; tdgti nargs,0 ;; time for event polling. ;; This used to happen a lot so we test for it first. (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) (with-xp-stack-frames (xp fn frame-ptr) (if (eql the-trap (ppc-lap-word (tdgti nargs 0))) (cmain) (with-error-reentry-detection (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) instr ra temp rs condition) (cond ;; tdeqi RA nil-value - resolve-eep, or resolve-foreign-variable ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdeqi ?? (target-nil-value)))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) (ppc-lap-word (ld ?? (+ 8 ppc64::misc-data-offset) ??)) fn pc-index))) (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) (etypecase eep-or-fv (external-entry-point (resolve-eep eep-or-fv) (setf (xp-gpr-lisp xp (RA-field the-trap)) (eep.address eep-or-fv))) (foreign-variable (resolve-foreign-variable eep-or-fv) (setf (xp-gpr-lisp xp (RA-field the-trap)) (fv.addr eep-or-fv)))))) ((= the-trap #$SIGBUS) (%error (make-condition 'invalid-memory-access :address arg0 :write-p (not (zerop arg1))) () frame-ptr)) ;; tdnei RA,N; RA = nargs ;; nargs check, no optional or rest involved ((match-instr the-trap (ppc-instruction-mask :opcode :to :ra) (ppc-lap-word (tdnei nargs ??))) (%error (if (< (xp-GPR-signed-doubleword xp ppc::nargs) (D-field the-trap)) 'too-few-arguments 'too-many-arguments ) (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) (- ppc64::fixnumshift)) :fn fn) frame-ptr)) ;; tdnei RA,N; RA != nargs, N = lowtag_node/immheader ;; type check; look for "lbz rt-imm,-5(ra-node)" ((and (or (match-instr the-trap (ppc-instruction-mask :opcode :to :lowtag64) (ppc-lap-word (tdnei ?? ppc64::lowtag-nodeheader))) (match-instr the-trap (ppc-instruction-mask :opcode :rt :lowtag64) (ppc-lap-word (tdnei ?? ppc64::lowtag-immheader)))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) (ppc-lap-word (lbz ?? ppc64::misc-subtag-offset ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (let* ((typecode (D-field the-trap)) (type-tag (logand typecode ppc64::lowtagmask)) (type-name (svref (if (eql type-tag ppc64::lowtag-nodeheader) *nodeheader-types* *immheader-types*) (ash typecode (- ppc64::nlowtagbits))))) (%error (make-condition 'type-error :format-control (%rsc-string $XWRONGTYPE) :datum (xp-GPR-lisp xp ra) :expected-type type-name) nil frame-ptr))) ;; tdnei RA,N; RA != nargs, N = subtag_character type ;; check; look for "clrldi rs-node,ra-imm,56" = "rldicl ;; rs,ra,0,55" ((and (match-instr the-trap (ppc-instruction-mask :opcode :rt :d) (ppc-lap-word (tdnei ?? ppc64::subtag-character))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 56)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'character) nil frame-ptr)) ;; tdnei RA,N; RA != nargs, N = ppc64::tag-fixnum. type ;; check; look for "clrldi rs-node,ra-imm,61" = "rldicl ;; rs,ra,61" ((and (match-instr the-trap (ppc-instruction-mask :opcode :rt) (ppc-lap-word (tdnei ?? ppc64::tag-fixnum))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 61)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'fixnum) nil frame-ptr)) ;; tdi 3,RA,ppc64::fulltag-cons; RA != nargs type check; ;; look for "clrldi rs-node,ra-imm,60" = "rldicl ;; rs,ra,60" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdi 3 ?? ppc64::fulltag-cons))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 60)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'list) nil frame-ptr)) ;; tdnei RA,ppc64::fulltag-cons; RA != nargs type check; ;; look for "clrldi rs-node,ra-imm,60" = "rldicl ;; rs,ra,60" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdnei ?? ppc64::fulltag-cons))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 60)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'cons) nil frame-ptr)) ;; tdnei RA,ppc64::subtag-single-float; RA != nargs type check; ;; look for "clrldi rs-node,ra-imm,60" = "rldicl ;; rs,ra,60" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdnei ?? ppc64::subtag-single-float))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 60)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'short-float) nil frame-ptr)) ;; tdnei RA,ppc64::fulltag-misc; RA != nargs type check; ;; look for "clrldi rs-node,ra-imm,60" = "rldicl ;; rs,ra,60" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdnei ?? ppc64::fulltag-misc))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) (ppc-lap-word (rldicl ?? ?? 0 60)) fn pc-index)) (lisp-reg-p (setq rs (RS-field instr)))) (%error (make-condition 'type-error :datum (xp-GPR-lisp xp rs) :expected-type 'uvector) nil frame-ptr)) ;; tdlgti RA,N; RA = nargs (xy = 01) ;; tdllti RA,N; RA = nargs (xy = 10) ;; nargs check, optional or rest involved ((and (match-instr the-trap (ppc-instruction-mask :opcode (:to #x1c) :ra) (ppc-lap-word (tdi ?? ppc::nargs ??))) (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) (eql #b10 temp))) (%error (if (eql temp #b10) 'too-few-arguments 'too-many-arguments) (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) (- ppc64::fixnumshift)) :fn fn) frame-ptr)) ;; tdeqi RA,N; N = unbound ;; symeval boundp check; look for "ld RA,symbol.vcell(nodereg)" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdeqi ?? ppc64::unbound-marker))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) (ppc-lap-word (ld ?? ppc64::symbol.vcell ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (setf (xp-GPR-lisp xp (RA-field the-trap)) (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) ;; tdeqi RA,N: n = (%slot-unbound-marker) ;; slot-unbound trap. Look for preceding "ldx RA,rx,ry". ;; rx = slots-vector, ry = scaled index in slots vector. ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :d) (ppc-lap-word (tdeqi ?? ppc64::slot-unbound-marker))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rt :x-minor) (dpb (RA-field the-trap) (byte 5 21) (ppc-lap-word (ldx ?? ?? ??))) fn pc-index))) (setq *error-reentry-count* 0) ; succesfully reported error ;; %SLOT-UNBOUND-TRAP will decode the arguments further, ;; then call the generic function SLOT-UNBOUND. That ;; might return a value; if so, set the value of the ;; register that caused the trap to that value. (setf (xp-gpr-lisp xp (ra-field the-trap)) (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) (ash (- (xp-gpr-signed-doubleword xp (RB-field instr)) ppc64::misc-data-offset) (- ppc64::word-shift)) frame-ptr))) ;; tdlge RA,RB ;; vector bounds check; look for "ld immreg, misc_header_offset(nodereg)" ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :x-minor) (ppc-lap-word (tdlge ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|# :ds-xo) (ppc-lap-word (ld ?? ?? #|ppc32::misc-header-offset|# ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (%error (%rsc-string $xarroob) (list (xp-GPR-lisp xp (RA-field the-trap)) (xp-GPR-lisp xp ra)) frame-ptr)) ;; tdi 27 ra d - array header rank check ((and (match-instr the-trap (ppc-instruction-mask :opcode :to) (ppc-lap-word (tdi 27 ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) (ppc-lap-word (ld ?? ppc64::arrayH.rank ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr)))) (%error (%rsc-string $xndims) (list (xp-gpr-lisp xp ra) (ash (ldb (byte 16 0) the-trap) (- ppc64::fixnumshift))) frame-ptr)) ;; td 27 ra rb - array flags check ((and (match-instr the-trap (ppc-instruction-mask :opcode :to :x-minor) (ppc-lap-word (td 27 ?? ??))) (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) (ppc-lap-word (ld ?? ppc64::arrayH.flags ??)) fn pc-index)) (lisp-reg-p (setq ra (RA-field instr))) (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) (expected-subtype (ldb ppc64::arrayH.flags-cell-subtag-byte expected)) (expect-simple (= (ldb ppc64::arrayH.flags-cell-bits-byte expected) (ash 1 $arh_simple_bit))) (type-name (case expected-subtype (#.ppc64::subtag-double-float-vector 'double-float)))) (and type-name expect-simple (setq condition (make-condition 'type-error :datum (xp-gpr-lisp xp ra) :expected-type `(simple-array ,type-name)))))) (%error condition nil frame-ptr)) ;; Unknown trap (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" (list the-trap xp fn (ash pc-index ppc64::fixnumshift)) frame-ptr)))))))))