diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp index de6c6533b91abebbd1f5f31df6d810b3205ebb9c..a0de9f5619e71b28b8a4de3c4dbdc7f3aacc9997 100644 --- a/compiler/sparc/insts.lisp +++ b/compiler/sparc/insts.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.4 1991/03/19 22:59:26 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.5 1991/11/15 15:29:08 ram Exp $ ;;; ;;; Description of the SPARC architecture. ;;; @@ -19,64 +19,13 @@ (use-package "EXT") (use-package "C") - - -;;;; Formats: - -(define-format (format-1 32) - (op (byte 2 30) :default 1) - (disp (byte 30 0))) - - -(define-format (format-2-immed 32) - (op (byte 2 30) :default 0) - (rd (byte 5 25)) - (op2 (byte 3 22)) - (immed (byte 22 0))) - -(define-format (format-2-branch 32) - (op (byte 2 30) :default 0) - (a (byte 1 29)) - (cond (byte 4 25)) - (op2 (byte 3 22)) - (disp (byte 22 0))) - -(define-format (format-2-unimp 32) - (op (byte 2 30) :default 0) - (ignore (byte 5 25) :default 0) - (op2 (byte 3 22) :default 0) - (data (byte 22 0))) - - -(define-format (format-3-reg 32) - (op (byte 2 30)) - (rd (byte 5 25)) - (op3 (byte 6 19)) - (rs1 (byte 5 14)) - (i (byte 1 13) :default 0) - (asi (byte 8 5) :default 0) - (rs2 (byte 5 0))) - -(define-format (format-3-immed 32) - (op (byte 2 30)) - (rd (byte 5 25)) - (op3 (byte 6 19)) - (rs1 (byte 5 14)) - (i (byte 1 13) :default 1) - (immed (byte 13 0))) - -(define-format (format-3-fpop 32) - (op (byte 2 30)) - (rd (byte 5 25)) - (op3 (byte 6 19)) - (rs1 (byte 5 14)) - (opf (byte 9 5)) - (rs2 (byte 5 0))) - +(disassem:set-disassem-params :instruction-alignment 32) ;;;; Special argument types and fixups. +(defvar *disassem-use-lisp-reg-names* t) + (define-argument-type reg :type '(and tn (satisfies (lambda (object) @@ -88,7 +37,19 @@ (case (sc-name (tn-sc tn)) (null null-offset) (zero 0) - (t (tn-offset tn))))) + (t (tn-offset tn)))) + :disassem-printer #'(lambda (value stream) + (declare (stream stream) (fixnum value)) + (cond (*disassem-use-lisp-reg-names* + (write-char #\% stream) + (princ (aref *register-names* value) stream)) + (t + (multiple-value-bind (set num) + (truncate value 8) + (format stream "%~a~d" + (aref #("g" "o" "l" "i") set) + num))))) +) (define-argument-type fp-reg @@ -96,7 +57,9 @@ (satisfies (lambda (object) (eq (sb-name (sc-sb (tn-sc object))) 'float-registers)))) - :function tn-offset) + :function tn-offset + :disassem-printer "%f~d" + ) (define-argument-type odd-fp-reg :type '(and tn @@ -109,33 +72,120 @@ (define-argument-type relative-label :type 'label :function (lambda (label) - (ash (- (label-position label) *current-position*) -2))) + (ash (- (label-position label) *current-position*) -2)) + :sign-extend t + :disassem-use-label #'(lambda (value dstate) + (declare (type disassem:disassem-state dstate)) + (+ (ash value 2) (disassem:dstate-curpos dstate))) + ) (eval-when (compile eval load) (defconstant branch-conditions '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))) +;;; Note that these aren't the standard names for branch-conditions, I think +;;; they're a bit more readable (e.g., "eq" instead of "e"). You could just +;;; put a vector of the normal ones here too. +(defconstant branch-cond-name-vec + #.(map 'vector #'symbol-name branch-conditions)) + (define-argument-type branch-condition :type '(member . #.branch-conditions) - :function (lambda (cond) (position cond branch-conditions))) + :function (lambda (cond) (position cond branch-conditions)) + :disassem-printer branch-cond-name-vec + ) +(defconstant branch-cond-true + #b1000) (eval-when (compile eval load) (defconstant branch-fp-conditions '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))) +(defconstant branch-fp-cond-name-vec + #.(map 'vector #'symbol-name branch-fp-conditions)) (define-argument-type branch-fp-condition :type '(member . #.branch-fp-conditions) - :function (lambda (fp-cond) (position fp-cond branch-fp-conditions))) + :function (lambda (fp-cond) (position fp-cond branch-fp-conditions)) + :disassem-printer branch-fp-cond-name-vec + ) -(define-fixup-type :call) -(define-fixup-type :sethi) +(define-fixup-type :call :disassem-use-label t) +(define-fixup-type :sethi + :disassem-printer #'(lambda (value stream) + (format stream "%hi(#x~8,'0x)" (ash value 10)))) (define-fixup-type :add) + +;;;; Formats: + +(define-format (format-1 32 + :disassem-printer '(:name :tab disp)) + (op (byte 2 30) :default 1) + (disp (byte 30 0) :default-type (unsigned-byte 30))) + + +(define-format (format-2-immed 32 + :disassem-printer '(:name :tab immed ", " rd)) + (op (byte 2 30) :default 0) + (rd (byte 5 25) :default-type reg) + (op2 (byte 3 22)) + (immed (byte 22 0) :default-type (signed-byte 22))) + +(define-format (format-2-branch 32 + :disassem-printer + `(:name (:unless (:constant ,branch-cond-true) cond) :tab disp)) + (op (byte 2 30) :default 0) + (a (byte 1 29)) + (cond (byte 4 25) :default-type branch-condition) + (op2 (byte 3 22)) + (disp (byte 22 0) :default-type relative-label)) + +(define-format (format-2-unimp 32 + :disassem-printer '(:name :tab data)) + (op (byte 2 30) :default 0) + (ignore (byte 5 25) :default 0) + (op2 (byte 3 22) :default 0) + (data (byte 22 0) :default-type (unsigned-byte 22))) + +(defconstant f3-printer + '(:name :tab + (:unless (:same-as rd) rs1 ", ") + (:choose rs2 immed) ", " + rd)) + +(define-format (format-3-reg 32 :disassem-printer f3-printer) + (op (byte 2 30)) + (rd (byte 5 25) :default-type reg) + (op3 (byte 6 19)) + (rs1 (byte 5 14) :default-type reg) + (i (byte 1 13) :default 0) + (asi (byte 8 5) :default 0) + (rs2 (byte 5 0) :default-type reg)) + +(define-format (format-3-immed 32 :disassem-printer f3-printer) + (op (byte 2 30)) + (rd (byte 5 25) :default-type reg) + (op3 (byte 6 19)) + (rs1 (byte 5 14) :default-type reg) + (i (byte 1 13) :default 1) + (immed (byte 13 0) :default-type (signed-byte 13))) + +(define-format (format-3-fpop 32 + :disassem-printer + '(:name :tab (:unless (:same-as rd) rs1 ", ") rs2 ", " rd)) + (op (byte 2 30)) + (rd (byte 5 25) :default-type fp-reg) + (op3 (byte 6 19)) + (rs1 (byte 5 14) :default-type fp-reg) + (opf (byte 9 5)) + (rs2 (byte 5 0) :default-type fp-reg)) + + ;;;; Instructions. @@ -143,8 +193,31 @@ (eval-when (compile eval) -(defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store) - `(define-instruction (,name) +;;; have to do this because defconstant is evalutated in the null lex env. +(defmacro with-ref-format (printer) + `(let* ((i-or-r + '(:choose immed rs2)) + (ref-format + `("[" rs1 (:unless (:constant 0) "+" ,i-or-r) "]" + (:choose (:unless (:constant 0) asi) nil)))) + ,printer)) + +(defconstant load-printer + (with-ref-format `(:NAME :TAB ,ref-format ", " rd))) +(defconstant store-printer + (with-ref-format `(:NAME :TAB rd ", " ,ref-format))) + +(defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store disassem-printer) + `(define-instruction (,name + ,@(if disassem-printer + `(:disassem-printer ,disassem-printer) + (case load-store + ((:load t) ; note that the sun notation for + ; things (like swap) that do both is + ; like a load + `(:disassem-printer ',load-printer)) + (:store + `(:disassem-printer ',store-printer))))) (format-3-reg (op :constant ,op) (rd :argument ,dest-kind) (op3 :constant ,op3) @@ -189,25 +262,63 @@ ) ; eval-when -(define-f3-inst ldsb #b11 #b001001 :load-store t) -(define-f3-inst ldsh #b11 #b001010 :load-store t) -(define-f3-inst ldub #b11 #b000001 :load-store t) -(define-f3-inst lduh #b11 #b000010 :load-store t) -(define-f3-inst ld #b11 #b000000 :load-store t) -(define-f3-inst ldd #b11 #b000011 :load-store t) - -(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store t) -(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store t) -(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store t) - -(define-f3-inst stb #b11 #b000101 :load-store t) -(define-f3-inst sth #b11 #b000110 :load-store t) -(define-f3-inst st #b11 #b000100 :load-store t) -(define-f3-inst std #b11 #b000111 :load-store t) - -(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store t) -(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store t) -(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store t) +(define-f3-inst ldsb #b11 #b001001 :load-store :load) +(define-f3-inst ldsh #b11 #b001010 :load-store :load) +(define-f3-inst ldub #b11 #b000001 :load-store :load) +(define-f3-inst lduh #b11 #b000010 :load-store :load) + +;;; ---------------------------------------------------------------- +(define-f3-inst ld #b11 #b000000 :load-store :load) + +(disassem:specialize (ld + :disassem-control + #'(lambda (chunk inst stream dstate) + (when stream + (disassem:note-code-constant + (disassem:arg-value 'immed chunk inst) + dstate)))) + immed + (rs1 :constant code-offset)) + +(disassem:specialize (ld + :disassem-control + #'(lambda (chunk inst stream dstate) + (when stream + (disassem:maybe-note-nil-indexed-symbol-slot-ref + (disassem:arg-value 'immed chunk inst) + dstate)))) + immed + (rs1 :constant null-offset)) +;;; ---------------------------------------------------------------- + +(define-f3-inst ldd #b11 #b000011 :load-store :load) + +(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load) +(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load) +(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load) + +(define-f3-inst stb #b11 #b000101 :load-store :store) +(define-f3-inst sth #b11 #b000110 :load-store :store) + +;;; ---------------------------------------------------------------- +(define-f3-inst st #b11 #b000100 :load-store :store) + +(disassem:specialize (st + :disassem-control + #'(lambda (chunk inst stream dstate) + (when stream + (disassem:maybe-note-nil-indexed-symbol-slot-ref + (disassem:arg-value 'immed chunk inst) + dstate)))) + immed + (rs1 :constant null-offset)) +;;; ---------------------------------------------------------------- + +(define-f3-inst std #b11 #b000111 :load-store :store) + +(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store) +(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store) +(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store) (define-f3-inst ldstub #b11 #b001101 :load-store t) (define-f3-inst swap #b11 #b001111 :load-store t) @@ -226,7 +337,49 @@ (rs1 :argument reg) (immed :argument (signed-byte 13)))) +;;; ---------------------------------------------------------------- (define-f3-inst add #b10 #b000000 :fixup t) + +(defstruct sethi-note + target-reg + high-bits + following-addr) + +(defun look-at-sethi-note (chunk inst stream dstate) + (when stream + (let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note))) + (when (and sethi-note + (= (disassem:dstate-curpos dstate) + (sethi-note-following-addr sethi-note)) + (= (disassem:arg-value 'rd chunk inst) + (sethi-note-target-reg sethi-note))) + (let ((value + (+ (sethi-note-high-bits sethi-note) + (disassem:arg-value 'immed + chunk inst)))) + (or (disassem:maybe-note-assembler-routine value dstate) + (disassem:note #'(lambda (stream) + (format stream "#x~x (~d)" + value + (disassem:sign-extend value 32))) + dstate))))))) + +(disassem:specialize (add :disassem-control #'look-at-sethi-note) + immed) + +;;; note: this must be after the above, because the disassem-controls +;;; are exclusive +(disassem:specialize (add + :disassem-control + #'(lambda (chunk inst stream dstate) + (when stream + (disassem:maybe-note-nil-indexed-object + (disassem:arg-value 'immed chunk inst) + dstate)))) + immed + (rs1 :constant null-offset)) +;;; ---------------------------------------------------------------- + (define-f3-inst addcc #b10 #b010000) (define-f3-inst addx #b10 #b001000) (define-f3-inst addxcc #b10 #b011000) @@ -249,6 +402,7 @@ (define-f3-inst andn #b10 #b000101) (define-f3-inst andncc #b10 #b010101) (define-f3-inst or #b10 #b000010) +(disassem:specialize (or :disassem-control #'look-at-sethi-note) immed) (define-f3-inst orcc #b10 #b010010) (define-f3-inst orn #b10 #b000110) (define-f3-inst orncc #b10 #b010110) @@ -261,7 +415,20 @@ (define-f3-inst srl #b10 #b100110) (define-f3-inst sra #b10 #b100111) -(define-instruction (sethi) +(defun sethi-note (chunk inst stream dstate) + (when stream + (let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note))) + (when (null sethi-note) + (setf sethi-note (make-sethi-note) + (disassem:dstate-get-prop dstate 'sethi-note) sethi-note)) + (setf (sethi-note-target-reg sethi-note) + (disassem:arg-value 'rd chunk inst)) + (setf (sethi-note-high-bits sethi-note) + (ash (disassem:arg-value 'immed chunk inst) 10)) + (setf (sethi-note-following-addr sethi-note) + (disassem:dstate-nextpos dstate))))) + +(define-instruction (sethi :disassem-control #'sethi-note) (format-2-immed (rd :argument reg) (op2 :constant #b100) (immed :argument (or (unsigned-byte 22) (signed-byte 22)))) @@ -280,11 +447,12 @@ (disp :argument relative-label)) (format-2-branch (op :constant #b00) (a :constant 0) - (cond :constant #b1000) + (cond :constant branch-cond-true) (op2 :constant #b010) (disp :argument relative-label))) -(define-instruction (ba) +(define-instruction (ba + :disassem-printer '("B" cond ",A" :tab disp)) (format-2-branch (op :constant #b00) (a :constant 1) (cond :argument branch-condition) @@ -296,7 +464,8 @@ (op2 :constant #b010) (disp :argument relative-label))) -(define-instruction (t) +(define-instruction (t + :disassem-printer '(:name rd :tab immed)) (format-3-immed (op :constant #b10) (rd :argument branch-condition) (op3 :constant #b111010) @@ -310,8 +479,16 @@ (op2 :constant #b110) (disp :argument relative-label))) +;;; slightly complicated to handle both jal and j +(defconstant jal-printer + '(:name :tab + (:choose (rs1 (:unless (:constant 0) "+" immed)) + (:cond ((rs2 :constant 0) rs1) + ((rs1 :constant 0) rs2) + (t rs1 "+" rs2))) + (:unless (:constant 0) ", " rd))) -(define-instruction (jal) +(define-instruction (jal :disassem-printer jal-printer) (format-3-reg (op :constant #b10) (rd :argument reg) (op3 :constant #b111000) @@ -328,7 +505,7 @@ (rs1 :argument reg) (immed :argument (signed-byte 13)))) -(define-instruction (j) +(define-instruction (j :disassem-printer jal-printer) (format-3-reg (op :constant #b10) (rd :constant 0) (op3 :constant #b111000) @@ -345,14 +522,19 @@ (rs1 :argument reg) (immed :argument (signed-byte 13)))) -(define-instruction (rdy) +(define-instruction (rdy :disassem-printer '("RD" :tab "%Y, " rd)) (format-3-immed (op :constant #b10) (rd :argument reg) (op3 :constant #b101000) (rs1 :constant 0) (immed :constant 0))) -(define-instruction (wry) +(define-instruction (wry + :disassem-printer + '("WR" :tab + rs1 + (:unless (:constant 0) ", " (:choose immed rs2)) + ", %y")) (format-3-reg (op :constant #b10) (rd :constant 0) (op3 :constant #b110000) @@ -369,9 +551,74 @@ (rs1 :argument reg) (immed :argument (signed-byte 13)))) -(define-instruction (unimp) +;;; ---------------------------------------------------------------- + +(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 (* sparc:byte-bits (1+ offset)) + vector (* sparc:word-bits + sparc:vector-data-offset) + (* length sparc: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 unimp-control (chunk inst stream dstate) + (flet ((nt (x) (if stream (disassem:note x dstate)))) + (break-cases (disassem:arg-value 'data chunk inst) + (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:object-not-list-trap + (nt "Object not list trap")) + (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")) + (vm:object-not-structure-trap + (nt "Object not structure trap")) + ))) + +(define-instruction (unimp :disassem-control #'unimp-control) (format-2-unimp (data :argument (unsigned-byte 22)))) +;;; ---------------------------------------------------------------- + (eval-when (compile eval) @@ -477,12 +724,14 @@ (inst sethi reg value) (inst add reg value)))) -(define-instruction (nop) +(define-instruction (nop :disassem-printer '(:name)) (format-2-immed (rd :constant 0) (op2 :constant #b100) (immed :constant 0))) -(define-instruction (cmp) +(define-instruction (cmp + :disassem-printer + '(:name :tab rs1 ", " (:choose immed rs2))) (format-3-reg (op :constant #b10) (rd :constant 0) (op3 :constant #b010100) @@ -499,7 +748,9 @@ (rs1 :argument reg) (immed :argument (signed-byte 13)))) -(define-instruction (not) +(define-instruction (not + :disassem-printer + '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd)) (format-3-reg (op :constant #b10) (rd :argument reg) (op3 :constant #b000111) @@ -511,7 +762,9 @@ (rs1 :same-as rd) (rs2 :constant 0))) -(define-instruction (neg) +(define-instruction (neg + :disassem-printer + '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd)) (format-3-reg (op :constant #b10) (rd :argument reg) (op3 :constant #b000100) @@ -523,7 +776,7 @@ (rs1 :constant 0) (rs2 :same-as rd))) -(define-instruction (move) +(define-instruction (move :disassem-printer '(:name :tab rs2 ", " rd)) (format-3-reg (op :constant #b10) (rd :argument reg) (op3 :constant #b000010)