diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp index 0c88e5ab8ad69904c8dcf75c208bd682abbc2109..89dde81a81d54757d2e5b0bbc1a7851368482c2e 100644 --- a/compiler/mips/insts.lisp +++ b/compiler/mips/insts.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/insts.lisp,v 1.42 1992/07/12 20:41:20 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/insts.lisp,v 1.43 1992/07/23 16:25:22 hallgren Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,8 +15,6 @@ ;;; ;;; Written by William Lott ;;; - - (in-package "MIPS") (use-package "NEW-ASSEM") @@ -27,7 +25,7 @@ :scheduler-p nil) -;;;; Functions to convert TN's and random symbolic things into values. +;;;; Constants, types, conversion functions, some disassembler stuff. (defun reg-tn-encoding (tn) (declare (type tn tn)) @@ -45,6 +43,54 @@ (error "~S isn't a floating-point register." tn)) (tn-offset tn)) +(disassem:set-disassem-params :instruction-alignment 32) + +(defvar *disassem-use-lisp-reg-names* t) + +(defconstant reg-symbols + (map 'vector + #'(lambda (name) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) + *register-names*)) + +(disassem:define-argument-type reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'registers + regname + dstate)))) + +(defconstant float-reg-symbols + (coerce + (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n))) + 'vector)) + +(disassem:define-argument-type fp-reg + :printer #'(lambda (value stream dstate) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) + +(disassem:define-argument-type control-reg + :printer "(CR:#x~X)") + +(disassem:define-argument-type relative-label + :sign-extend t + :use-label #'(lambda (value dstate) + (declare (type (signed-byte 16) value) + (type disassem:disassem-state dstate)) + (+ (ash (1+ value) 2) (disassem:dstate-cur-addr dstate)))) + (deftype float-format () '(member :s :single :d :double :w :word)) @@ -54,9 +100,24 @@ ((:d :double) 1) ((:w :word) 4))) +(disassem:define-argument-type float-format + :printer #'(lambda (value stream dstate) + (declare (ignore dstate) + (stream stream) + (fixnum value)) + (princ (case value + (0 's) + (1 'd) + (4 'w) + (t '?)) + stream))) + (defconstant compare-kinds '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)) +(defconstant compare-kinds-vec + (apply #'vector compare-kinds)) + (deftype compare-kind () `(member ,@compare-kinds)) @@ -66,18 +127,127 @@ kind compare-kinds))) +(disassem:define-argument-type compare-kind + :printer compare-kinds-vec) (defconstant float-operations '(+ - * /)) (deftype float-operation () `(member ,@float-operations)) +(defconstant float-operation-names + ;; this gets used for output only + #(add sub mul div)) + (defun float-operation (op) (or (position op float-operations) (error "Unknown floating point operation: ~S~%Must be one of: ~S" op float-operations))) +(disassem:define-argument-type float-operation + :printer float-operation-names) + + + +;;;; Constants used by instruction emitters. + +(defconstant special-op #b000000) +(defconstant bcond-op #b000001) +(defconstant cop0-op #b010000) +(defconstant cop1-op #b010001) +(defconstant cop2-op #b010010) +(defconstant cop3-op #b010011) + + + +;;;; dissassem:define-instruction-formats + +(defconstant immed-printer + '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate)) + +;;; for things that use rt=0 as a nop +(defconstant immed-zero-printer + '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate)) + +(disassem:define-instruction-format + (immediate 32 :default-printer immed-printer) + (op :field (byte 6 26)) + (rs :field (byte 5 21) :type 'reg) + (rt :field (byte 5 16) :type 'reg) + (immediate :field (byte 16 0) :sign-extend t)) + +(defconstant jump-printer + #'(lambda (value stream dstate) + (let ((addr (ash value 2))) + (disassem:maybe-note-assembler-routine addr dstate) + (write addr :base 16 :radix t :stream stream)))) + +(disassem:define-instruction-format + (jump 32 :default-printer '(:name :tab target)) + (op :field (byte 6 26)) + (target :field (byte 26 0) :printer jump-printer)) + +(defconstant reg-printer + '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt)) + +(disassem:define-instruction-format + (register 32 :default-printer reg-printer) + (op :field (byte 6 26)) + (rs :field (byte 5 21) :type 'reg) + (rt :field (byte 5 16) :type 'reg) + (rd :field (byte 5 11) :type 'reg) + (shamt :field (byte 5 6) :value 0) + (funct :field (byte 6 0))) + +(disassem:define-instruction-format + (break 32 :default-printer + '(:name :tab code (:unless (:constant 0) subcode))) + (op :field (byte 6 26) :value special-op) + (code :field (byte 10 16)) + (subcode :field (byte 10 6) :value 0) + (funct :field (byte 6 0) :value #b001101)) + +(disassem:define-instruction-format + (coproc-branch 32 :default-printer '(:name :tab offset)) + (op :field (byte 6 26)) + (funct :field (byte 10 16)) + (offset :field (byte 16 0))) + +(defconstant float-fmt-printer + '((:unless :constant funct) + (:choose (:unless :constant sub-funct) nil) + "." format)) + +(defconstant float-printer + `(:name ,@float-fmt-printer + :tab + fd + (:unless (:same-as fd) ", " fs) + ", " ft)) + +(disassem:define-instruction-format + (float 32 :default-printer float-printer) + (op :field (byte 6 26) :value cop1-op) + (filler :field (byte 1 25) :value 1) + (format :field (byte 4 21) :type 'float-format) + (ft :field (byte 5 16) :value 0) + (fs :field (byte 5 11) :type 'fp-reg) + (fd :field (byte 5 6) :type 'fp-reg) + (funct :field (byte 6 0))) + +(disassem:define-instruction-format + (float-aux 32 :default-printer float-printer) + (op :field (byte 6 26) :value cop1-op) + (filler-1 :field (byte 1 25) :value 1) + (format :field (byte 4 21) :type 'float-format) + (ft :field (byte 5 16) :type 'fp-reg) + (fs :field (byte 5 11) :type 'fp-reg) + (fd :field (byte 5 6) :type 'fp-reg) + (funct :field (byte 2 4)) + (sub-funct :field (byte 4 0))) + + ;;;; Primitive emitters. @@ -96,7 +266,6 @@ (define-emitter emit-register-inst 32 (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0)) - (define-emitter emit-break-inst 32 (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0)) @@ -105,17 +274,6 @@ (byte 5 11) (byte 5 6) (byte 6 0)) - -;;;; Constants used by instruction emitters. - -(defconstant special-op #b000000) -(defconstant bcond-op #b000001) -(defconstant cop0-op #b010000) -(defconstant cop1-op #b010001) -(defconstant cop2-op #b010010) -(defconstant cop3-op #b010011) - - ;;;; Math instructions. @@ -142,6 +300,8 @@ (define-instruction add (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (signed-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b100000))) + (:printer immediate ((op #b001000))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -150,6 +310,8 @@ (define-instruction addu (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (signed-byte 16) fixup null) src1 src2)) + (:printer register ((op special-op) (funct #b100001))) + (:printer immediate ((op #b001001))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -159,6 +321,7 @@ (:declare (type tn dst) (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2)) + (:printer register ((op special-op) (funct #b100010))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -174,6 +337,7 @@ (type tn dst) (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2)) + (:printer register ((op special-op) (funct #b100011))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -187,6 +351,8 @@ (define-instruction and (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b100100))) + (:printer immediate ((op #b001100) (immediate nil :sign-extend nil))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -195,6 +361,8 @@ (define-instruction or (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b100101))) + (:printer immediate ((op #b001101))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -203,6 +371,8 @@ (define-instruction xor (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b100110))) + (:printer immediate ((op #b001110))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -210,6 +380,7 @@ (define-instruction nor (segment dst src1 &optional src2) (:declare (type tn dst src1) (type (or tn null) src2)) + (:printer register ((op special-op) (funct #b100111))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -218,6 +389,8 @@ (define-instruction slt (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (signed-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b101010))) + (:printer immediate ((op #b001010))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -226,15 +399,20 @@ (define-instruction sltu (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (signed-byte 16) null) src1 src2)) + (:printer register ((op special-op) (funct #b101011))) + (:printer immediate ((op #b001011))) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter (emit-math-inst segment dst src1 src2 #b101011 #b001011))) +(defconstant divmul-printer '(:name :tab rs ", " rt)) + (define-instruction div (segment src1 src2) (:declare (type tn src1 src2)) + (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer) (:reads (list src1 src2)) - (:writes :hi-and-lo-regs) + (:writes (list :hi-reg :low-reg)) (:delay 1) (:emitter (emit-register-inst segment special-op (reg-tn-encoding src1) @@ -242,8 +420,10 @@ (define-instruction divu (segment src1 src2) (:declare (type tn src1 src2)) + (:printer register ((op special-op) (rd 0) (funct #b011011)) + divmul-printer) (:reads (list src1 src2)) - (:writes :hi-and-low-regs) + (:writes (list :hi-reg :low-reg)) (:delay 1) (:emitter (emit-register-inst segment special-op (reg-tn-encoding src1) @@ -251,8 +431,9 @@ (define-instruction mult (segment src1 src2) (:declare (type tn src1 src2)) + (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer) (:reads (list src1 src2)) - (:writes :hi-and-low-regs) + (:writes (list :hi-reg :low-reg)) (:delay 1) (:emitter (emit-register-inst segment special-op (reg-tn-encoding src1) @@ -260,8 +441,9 @@ (define-instruction multu (segment src1 src2) (:declare (type tn src1 src2)) + (:printer register ((op special-op) (rd 0) (funct #b011001))) (:reads (list src1 src2)) - (:writes :hi-and-low-regs) + (:writes :hi-reg :low-reg) (:delay 1) (:emitter (emit-register-inst segment special-op (reg-tn-encoding src1) @@ -280,9 +462,19 @@ (emit-register-inst segment special-op 0 (reg-tn-encoding src1) (reg-tn-encoding dst) src2 opcode)))) +(defconstant shift-printer + '(:name :tab + rd + (:unless (:same-as rd) ", " rt) + ", " (:cond ((rs :constant 0) shamt) + (t rs)))) + (define-instruction sll (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 5) null) src1 src2)) + (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000)) + shift-printer) + (:printer register ((op special-op) (funct #b000100)) shift-printer) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -291,6 +483,9 @@ (define-instruction sra (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 5) null) src1 src2)) + (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011)) + shift-printer) + (:printer register ((op special-op) (funct #b000111)) shift-printer) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -299,6 +494,9 @@ (define-instruction srl (segment dst src1 &optional src2) (:declare (type tn dst) (type (or tn (unsigned-byte 5) null) src1 src2)) + (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010)) + shift-printer) + (:printer register ((op special-op) (funct #b000110)) shift-printer) (:reads (if src2 (list src1 src2) (list dst src1))) (:writes dst) (:emitter @@ -318,8 +516,12 @@ (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1) (fp-reg-tn-encoding dst) (float-operation operation)))) +(defconstant float-unop-printer + `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs))) + (define-instruction fabs (segment format dst &optional (src dst)) (:declare (type float-format format) (type tn dst src)) +; (:printer float ((funct #b000101)) float-unop-printer) (:reads src) (:writes dst) (:emitter @@ -329,6 +531,7 @@ (define-instruction fneg (segment format dst &optional (src dst)) (:declare (type float-format format) (type tn dst src)) +; (:printer float ((funct #b000111)) float-unop-printer) (:reads src) (:writes dst) (:emitter @@ -338,6 +541,8 @@ (define-instruction fcvt (segment format1 format2 dst src) (:declare (type float-format format1 format2) (type tn dst src)) + (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format)) + `(:name "." sub-funct "." format :tab fd ", " fs)) (:reads src) (:writes dst) (:emitter @@ -349,8 +554,11 @@ (:declare (type compare-kind operation) (type float-format format) (type tn fs ft)) + (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind)) + `(:name "-" sub-funct "." format :tab fs ", " ft)) (:reads (list fs ft)) (:writes :float-status) + (:delay 1) (:emitter (emit-float-inst segment cop1-op 1 (float-format-value format) (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0 @@ -376,6 +584,9 @@ (define-instruction b (segment target) (:declare (type label target)) + (:printer immediate ((op #b000100) (rs 0) (rt 0) + (immediate nil :type 'relative-label)) + '(:name :tab immediate)) (:attributes branch) (:delay 1) (:emitter @@ -386,6 +597,7 @@ (:declare (type tn r1) (type (or tn fixnum label) r2-or-target) (type (or label null) target)) + (:printer immediate ((op #b000100) (immediate nil :type 'relative-label))) (:attributes branch) (:delay 1) (:reads (list r1 r2-or-target)) @@ -399,6 +611,7 @@ (:declare (type tn r1) (type (or tn fixnum label) r2-or-target) (type (or label null) target)) + (:printer immediate ((op #b000101) (immediate nil :type 'relative-label))) (:attributes branch) (:delay 1) (:reads (list r1 r2-or-target)) @@ -408,8 +621,14 @@ (setf r2-or-target 0)) (emit-relative-branch segment #b000101 r1 r2-or-target target))) +(defconstant cond-branch-printer + '(:name :tab rs ", " immediate)) + (define-instruction blez (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -418,6 +637,9 @@ (define-instruction bgtz (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -426,6 +648,9 @@ (define-instruction bltz (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -434,6 +659,9 @@ (define-instruction bgez (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -442,6 +670,9 @@ (define-instruction bltzal (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -451,6 +682,9 @@ (define-instruction bgezal (segment reg target) (:declare (type label target) (type tn reg)) + (:printer + immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label)) + cond-branch-printer) (:attributes branch) (:delay 1) (:reads reg) @@ -458,8 +692,13 @@ (:emitter (emit-relative-branch segment bcond-op reg #b01001 target))) +(defconstant j-printer + '(:name :tab (:choose rs target))) + (define-instruction j (segment target) (:declare (type (or tn fixup) target)) + (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000)) j-printer) + (:printer jump ((op #b000010)) j-printer) (:attributes branch) (:delay 1) (:emitter @@ -474,9 +713,11 @@ (define-instruction jal (segment reg-or-target &optional target) (:declare (type (or null tn fixup) target) (type (or tn fixup (integer -16 31)) reg-or-target)) + (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer) + (:printer jump ((op #b000011)) j-printer) (:attributes branch) (:delay 1) - (:writes (if target (reg-tn-location reg-or-target) :r31)) + (:writes (if target reg-or-target :r31)) ; ### fix this (:emitter (unless target (setf target reg-or-target) @@ -491,6 +732,8 @@ (define-instruction bc1f (segment target) (:declare (type label target)) + (:printer coproc-branch ((op cop1-op) (funct #x100) + (offset nil :type 'relative-label))) (:reads :float-status) (:attributes branch) (:delay 1) @@ -499,6 +742,8 @@ (define-instruction bc1t (segment target) (:declare (type label target)) + (:printer coproc-branch ((op cop1-op) (funct #x101) + (offset nil :type 'relative-label))) (:reads :float-status) (:attributes branch) (:delay 1) @@ -509,10 +754,15 @@ ;;;; Random movement instructions. +(eval-when (compile load eval) + (defun lui-arg-printer (value stream dstate) + (declare (ignore dstate)) + (format stream "#x~4,'0X" value))) + (define-instruction lui (segment reg value) (:declare (type tn reg) (type (or fixup (signed-byte 16) (unsigned-byte 16)) value)) - (:reads) + (:printer immediate ((op #b001111) (immed nil :printer #'lui-arg-printer))) (:writes reg) (:emitter (when (fixup-p value) @@ -520,41 +770,54 @@ (setf value 0)) (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value))) +(defconstant mvsreg-printer '(:name :tab rd)) + (define-instruction mfhi (segment reg) (:declare (type tn reg)) - (:reads :hi-and-low-regs) + (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000)) + mvsreg-printer) + (:reads :hi-reg) (:writes reg) + (:delay 2) (:emitter (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 #b010000))) (define-instruction mthi (segment reg) (:declare (type tn reg)) + (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001)) + mvsreg-printer) (:reads reg) - (:writes :hi-and-low-regs) - (:delay 1) ;; ### Is there a delay here? + (:writes :hi-reg) (:emitter (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 #b010001))) (define-instruction mflo (segment reg) (:declare (type tn reg)) - (:reads :hi-and-low-regs) + (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010)) + mvsreg-printer) + (:reads :low-reg) (:writes reg) + (:delay 2) (:emitter (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 #b010010))) (define-instruction mtlo (segment reg) (:declare (type tn reg)) - (:writes :hi-and-low-regs) - (:delay 1) ;; ### Is there a delay here? + (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011)) + mvsreg-printer) + (:reads reg) + (:writes :low-reg) (:emitter (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0 #b010011))) (define-instruction move (segment dst src) (:declare (type tn dst src)) + (:printer register ((op special-op) (rt 0) (funct #b100001)) + '(:name :tab rd ", " rs)) (:reads src) (:writes dst) (:attributes flushable) @@ -564,6 +827,7 @@ (define-instruction fmove (segment format dst src) (:declare (type float-format format) (type tn dst src)) + (:printer float ((funct #b000110)) '(:name :tab fd ", " fs)) (:reads src) (:writes dst) (:attributes flushable) @@ -588,11 +852,14 @@ (define-instruction-macro li (reg value) `(%li ,reg ,value)) +(defconstant sub-op-printer '(:name :tab rd ", " rt)) + (define-instruction mtc1 (segment to from) (:declare (type tn to from)) + (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer) (:reads from) (:writes to) - (:delay 1) ;; ### Is this delay correct? + (:delay 1) (:emitter (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from) (fp-reg-tn-encoding to) 0 0))) @@ -601,16 +868,17 @@ (:declare (type tn to from)) (:reads from) (:writes to) - (:delay 1) ;; ### Is this delay correct? + (:delay 1) (:emitter (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from) (1+ (fp-reg-tn-encoding to)) 0 0))) (define-instruction mfc1 (segment to from) (:declare (type tn to from)) + (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0)) + sub-op-printer) (:reads from) (:writes to) - (:delay 1) ;; ### Is this delay correct? (:emitter (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to) (fp-reg-tn-encoding from) 0 0))) @@ -619,21 +887,26 @@ (:declare (type tn to from)) (:reads from) (:writes to) - (:delay 1) ;; ### Is this delay correct? (:emitter (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to) (1+ (fp-reg-tn-encoding from)) 0 0))) (define-instruction cfc1 (segment reg cr) (:declare (type tn reg) (type (unsigned-byte 5) cr)) - ;; ### reads/writes for this? + (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg) + (funct 0)) sub-op-printer) + (:reads nil) ;; ### fix this + (:writes reg) (:emitter (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding reg) cr 0 0))) (define-instruction ctc1 (segment reg cr) (:declare (type tn reg) (type (unsigned-byte 5) cr)) - ;; ### reads/writes for this? + (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg) + (funct 0)) sub-op-printer) + (:reads reg) + (:writes nil) ;; ### fix this (:emitter (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg) cr 0 0))) @@ -648,19 +921,83 @@ (define-emitter emit-break-inst 32 (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0)) +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (system:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond (length-only + (values 0 (1+ length) nil nil)) + (t + (kernel:copy-from-system-area sap (* mips:byte-bits (1+ offset)) + vector (* mips:word-bits + mips:vector-data-offset) + (* length mips:byte-bits)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (c::read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defmacro break-cases (breaknum &body cases) + (let ((bn-temp (gensym))) + (collect ((clauses)) + (dolist (case cases) + (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) + `(let ((,bn-temp ,breaknum)) + (cond ,@(clauses)))))) + +(defun break-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (disassem:note x dstate)))) + (case (break-code chunk dstate) + (#.vm:error-trap + (nt "Error trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:cerror-trap + (nt "Cerror trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.vm:halt-trap + (nt "Halt trap")) + (#.vm:function-end-breakpoint-trap + (nt "Function end breakpoint trap")) + ))) + (define-instruction break (segment code &optional (subcode 0)) (:declare (type (unsigned-byte 10) code subcode)) + (:printer break ((op special-op) (funct #b001101)) + '(:name :tab code (:unless (:constant 0) subcode)) + :control #'break-control ) :pinned (:emitter (emit-break-inst segment special-op code subcode #b001101))) (define-instruction syscall (segment) :pinned + (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100)) + '(:name)) (:emitter (emit-register-inst segment special-op 0 0 0 0 #b001100))) (define-instruction nop (segment) (:attributes flushable) + (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name)) (:emitter (emit-word segment 0))) @@ -770,9 +1107,16 @@ (emit-immediate-inst segment opcode (reg-tn-encoding reg) (reg-tn-encoding base) index)) +(defconstant load-store-printer + '(:name :tab + rt ", " + rs + (:unless (:constant 0) "[" immediate "]"))) + (define-instruction lb (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100000)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -782,6 +1126,7 @@ (define-instruction lh (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100001)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -791,6 +1136,7 @@ (define-instruction lwl (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100010)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -800,6 +1146,7 @@ (define-instruction lw (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100011)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -809,6 +1156,7 @@ (define-instruction lbu (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100100)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -818,6 +1166,7 @@ (define-instruction lhu (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100101)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -827,6 +1176,7 @@ (define-instruction lwr (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b100110)) load-store-printer) (:reads (list base :memory)) (:writes reg) (:delay 1) @@ -836,6 +1186,7 @@ (define-instruction sb (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b101000)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -844,6 +1195,7 @@ (define-instruction sh (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b101001)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -852,6 +1204,7 @@ (define-instruction swl (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b101010)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -860,6 +1213,7 @@ (define-instruction sw (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b101011)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -868,6 +1222,7 @@ (define-instruction swr (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b101110)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -884,6 +1239,7 @@ (define-instruction lwc1 (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer) (:reads base :memory) (:writes reg) (:delay 1) @@ -902,6 +1258,7 @@ (define-instruction swc1 (segment reg base &optional (index 0)) (:declare (type tn reg base) (type (or (signed-byte 16) fixup) index)) + (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer) (:reads base reg) (:writes :memory) (:emitter @@ -914,4 +1271,3 @@ (:writes :memory) (:emitter (emit-fp-load/store-inst segment #b111001 reg 1 base index))) -