From 5a92380648b268184c2e955a1f89b35a5416464d Mon Sep 17 00:00:00 2001
From: hallgren <hallgren>
Date: Fri, 16 Oct 1992 15:10:00 +0000
Subject: [PATCH] Added disassembler info.

---
 compiler/hppa/insts.lisp | 472 ++++++++++++++++++++++++++++++++++++++-
 1 file changed, 470 insertions(+), 2 deletions(-)

diff --git a/compiler/hppa/insts.lisp b/compiler/hppa/insts.lisp
index 33ed010ab..94fe81adf 100644
--- a/compiler/hppa/insts.lisp
+++ b/compiler/hppa/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/hppa/insts.lisp,v 1.1 1992/07/13 03:48:23 wlott Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/insts.lisp,v 1.2 1992/10/16 15:10:00 hallgren Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -131,6 +131,359 @@
        (byte 2 1)
        (ldb (byte 1 2) space)))
 
+
+;;;; Initial disassembler setup.
+
+(disassem:set-disassem-params :instruction-alignment 32)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(defparameter 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))))
+
+(defparameter 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 fp-fmt-0c
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (ecase value
+		 (0 (format stream ",SGL"))
+		 (1 (format stream ",DBL"))
+		 (3 (format stream ",QUAD")))))
+
+(defun low-sign-extend (x n)
+  (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
+    (if (logbitp 0 x)
+	(logior (ash -1 (1- n)) normal)
+	normal)))
+
+(defun sign-extend (x n)
+  (if (logbitp (1- n) x)
+      (logior (ash -1 (1- n)) x)
+      x))
+
+(defun assemble-bits (x list)
+  (let ((result 0)
+	(offset 0))
+    (dolist (e (reverse list))
+      (setf result (logior result (ash (ldb e x) offset)))
+      (incf offset (byte-size e)))
+    result))
+
+(defmacro define-imx-decode (name bits)
+  `(disassem:define-argument-type ,name
+     :printer #'(lambda (value stream dstate)
+		  (declare (ignore dstate) (stream stream) (fixnum value))
+		  (format stream "~S" (low-sign-extend value ,bits)))))
+
+(define-imx-decode im5 5)
+(define-imx-decode im11 11)
+(define-imx-decode im14 14)
+
+(disassem:define-argument-type im3
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (format stream "~S" (assemble-bits value `(,(byte 1 0)
+							  ,(byte 2 1))))))
+
+(disassem:define-argument-type im21
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (format stream "~S"
+		       (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
+					      ,(byte 2 14) ,(byte 5 16)
+					      ,(byte 2 12))))))
+
+(disassem:define-argument-type cp
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (format stream "~S" (- 31 value))))
+
+(disassem:define-argument-type clen
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (format stream "~S" (- 32 value))))
+
+(disassem:define-argument-type compare-condition
+  :printer #("" ",=" ",<" ",<=" ",<<" ",<<=" ",SV" ",OD" ",TR" ",<>" ",>="
+	     ",>" ",>>=" ",>>" ",NSV" ",EV"))
+
+(disassem:define-argument-type add-condition
+  :printer #("" ",=" ",<" ",<=" ",NUV" ",ZNV" ",SV" ",OD" ",TR" ",<>" ",>="
+	     ",>" ",UV" ",VNZ" ",NSV" ",EV"))
+
+(disassem:define-argument-type logical-condition
+  :printer #("" ",=" ",<" ",<=" "" "" "" ",OD" ",TR" ",<>" ",>=" ",>" "" ""
+	     "" ",EV"))
+
+(disassem:define-argument-type unit-condition
+  :printer #("" "" ",SBZ" ",SHZ" ",SDC" ",SBC" ",SHC" ",TR" "" ",NBZ" ",NHZ"
+	     ",NDC" ",NBC" ",NHC"))
+
+(disassem:define-argument-type extract/deposit-condition
+  :printer #("" ",=" ",<" ",OD" ",TR" ",<>" ",>=" ",EV"))
+
+(disassem:define-argument-type nullify
+  :printer #("" ",N"))
+
+(disassem:define-argument-type fcmp-cond
+  :printer #("false?" "false" "?" "!<=>" "=" "=T" "?=" "!<>" "!?>=" "<" "?<"
+	     "!>=" "!?>" "<=" "?<=" "!>" "!?<=" ">" "?>" "!<=" "!?<" ">="
+	     "?>=" "!<" "!?=" "<>" "!=" "!=T" "!?" "<=>" "true?" "true"))
+
+(disassem:define-argument-type integer
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore dstate) (stream stream) (fixnum value))
+	       (format stream "~S" value)))
+
+
+;;;; Define-instruction-formats for disassembler.
+
+(disassem:define-instruction-format
+    (load/store 32)
+  (op   :field (byte 6 26))
+  (b    :field (byte 5 21) :type 'reg)
+  (t/r  :field (byte 5 16) :type 'reg)
+  (s    :field (byte 2 14))
+  (im14 :field (byte 14 0) :type 'im14))
+
+(defconstant cmplt-index-print '((:cond ((u :constant 1) ",S"))
+				 (:cond ((m :constant 1) ",M"))))
+
+(defconstant cmplt-disp-print '((:cond ((m :constant 1)
+				  (:cond ((s :constant 0) ",MA")
+					 (t ",MB"))))))
+
+(defconstant cmplt-store-print '((:cond ((s :constant 0) ",B")
+					 (t ",E"))
+				  (:cond ((m :constant 1) ",M"))))
+
+(disassem:define-instruction-format
+    (extended-load/store 32)
+  (op1     :field (byte 6 26) :value 3)
+  (b       :field (byte 5 21) :type 'reg)
+  (x/im5/r :field (byte 5 16) :type 'reg)
+  (s       :field (byte 2 14))
+  (u       :field (byte 1 13))
+  (op2     :field (byte 3 10))
+  (ext4/c  :field (byte 4 6))
+  (m       :field (byte 1 5))
+  (t/im5   :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (ldil 32 :default-printer '(:name :tab im21 "," t))
+  (op    :field (byte 6 26))
+  (t   :field (byte 5 21) :type 'reg)
+  (im21 :field (byte 21 0) :type 'im21))
+
+(disassem:define-instruction-format
+    (branch17 32)
+  (op1 :field (byte 6 26))
+  (t   :field (byte 5 21) :type 'reg)
+  (w   :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
+       :use-label
+       #'(lambda (value dstate)
+	   (declare (type disassem:disassem-state dstate) (list value))
+	   (let ((x (logior (ash (first value) 12) (ash (second value) 1)
+			    (third value))))
+	     (+ (ash (sign-extend
+		      (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
+					 ,(byte 10 2))) 17) 2)
+		(disassem:dstate-cur-addr dstate) 8))))
+  (op2 :field (byte 3 13))
+  (n   :field (byte 1 1) :type 'nullify))
+
+(disassem:define-instruction-format
+    (branch12 32)
+  (op1 :field (byte 6 26))
+  (r2  :field (byte 5 21) :type 'reg)
+  (r1  :field (byte 5 16) :type 'reg)
+  (w   :fields `(,(byte 11 2) ,(byte 1 0))
+       :use-label
+       #'(lambda (value dstate)
+	   (declare (type disassem:disassem-state dstate) (list value))
+	   (let ((x (logior (ash (first value) 1) (second value))))
+	     (+ (ash (sign-extend
+		      (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
+		      12) 2)
+		(disassem:dstate-cur-addr dstate) 8))))
+  (c   :field (byte 3 13))
+  (n   :field (byte 1 1) :type 'nullify))
+
+(disassem:define-instruction-format
+    (branch 32)
+  (op1 :field (byte 6 26))
+  (t   :field (byte 5 21) :type 'reg)
+  (x   :field (byte 5 15) :type 'reg)
+  (op2 :field (byte 3 13))
+  (x1  :field (byte 11 2))
+  (n   :field (byte 1 1) :type 'nullify)
+  (x2  :field (byte 1 0)))
+
+(disassem:define-instruction-format
+     (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
+  (r3 :field (byte 6 26) :value 2)
+  (r2 :field (byte 5 21) :type 'reg)
+  (r1 :field (byte 5 16) :type 'reg)
+  (c  :field (byte 3 13))
+  (f  :field (byte 1 12))
+  (op :field (byte 7 5))
+  (t  :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
+  (op   :field (byte 6 26))
+  (r    :field (byte 5 21) :type 'reg)
+  (t    :field (byte 5 16) :type 'reg)
+  (c    :field (byte 3 13))
+  (f    :field (byte 1 12))
+  (o    :field (byte 1 11))
+  (im11 :field (byte 11 0) :type 'im11))
+
+(disassem:define-instruction-format
+    (extract/deposit-inst 32)
+  (op1    :field (byte 6 26))
+  (r2     :field (byte 5 21) :type 'reg)
+  (r1     :field (byte 5 16) :type 'reg)
+  (c      :field (byte 3 13) :type 'extract/deposit-condition)
+  (op2    :field (byte 3 10))
+  (cp     :field (byte 5 5) :type 'cp)
+  (t/clen :field (byte 5 0) :type 'clen))
+
+(disassem:define-instruction-format
+    (break 32 :default-printer '(:name :tab im13 "," im5))
+  (op1  :field (byte 6 26) :value 0)
+  (im13 :field (byte 13 13))
+  (q2   :field (byte 8 5) :value 0)
+  (im5  :field (byte 5 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 (* hppa:byte-bits (1+ offset))
+                                         vector (* hppa:word-bits
+                                                   hppa:vector-data-offset)
+                                         (* length hppa: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))))))))
+
+(defun break-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (disassem:note x dstate))))
+    (case (break-im5 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"))
+    )))
+
+(disassem:define-instruction-format
+    (system-inst 32)
+  (op1 :field (byte 6 26) :value 0)
+  (r1  :field (byte 5 21) :type 'reg)
+  (r2  :field (byte 5 16) :type 'reg)
+  (s   :field (byte 3 13))
+  (op2 :field (byte 8 5))
+  (r3  :field (byte 5 0) :type 'reg))
+
+(disassem:define-instruction-format
+    (fp-load/store 32)
+  (op :field (byte 6 26))
+  (b  :field (byte 5 21) :type 'reg)
+  (x  :field (byte 5 16) :type 'reg)
+  (s  :field (byte 2 14))
+  (u  :field (byte 1 13))
+  (x1 :field (byte 1 12))
+  (x2 :field (byte 2 10))
+  (x3 :field (byte 1 9))
+  (x4 :field (byte 3 6))
+  (m  :field (byte 1 5))
+  (t  :field (byte 5 0) :type 'fp-reg))
+
+(disassem:define-instruction-format
+    (fp-class-0-inst 32)
+  (op1 :field (byte 6 26))
+  (r   :field (byte 5 21) :type 'fp-reg)
+  (x1  :field (byte 5 16) :type 'fp-reg)
+  (op2 :field (byte 3 13))
+  (fmt :field (byte 2 11) :type 'fp-fmt-0c)
+  (x2  :field (byte 2 9))
+  (x3  :field (byte 3 6))
+  (x4  :field (byte 1 5))
+  (t   :field (byte 5 0) :type 'fp-reg))
+
+(disassem:define-instruction-format
+    (fp-class-1-inst 32)
+  (op1 :field (byte 6 26))
+  (r   :field (byte 5 21) :type 'fp-reg)
+  (x1  :field (byte 4 17) :value 0)
+  (x2  :field (byte 2 15))
+  (df  :field (byte 2 13) :type 'fp-fmt-0c)
+  (sf  :field (byte 2 11) :type 'fp-fmt-0c)
+  (x3  :field (byte 2 9) :value 1)
+  (x4  :field (byte 3 6) :value 0)
+  (x5  :field (byte 1 5) :value 0)
+  (t   :field (byte 5 0) :type 'fp-reg))
+
 
 
 ;;;; Load and Store stuff.
@@ -159,6 +512,8 @@
     `(define-instruction ,name (segment disp base reg)
        (:declare (type tn reg base)
 		 (type (or fixup (signed-byte 14)) disp))
+       (:printer load/store ((op ,opcode) (s 0))
+		 '(:name :tab im14 "(" s "," b ")," t/r))
        (:emitter
 	(emit-load/store segment ,opcode
 			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
@@ -167,6 +522,8 @@
     `(define-instruction ,name (segment reg disp base)
        (:declare (type tn reg base)
 		 (type (or fixup (signed-byte 14)) disp))
+       (:printer load/store ((op ,opcode) (s 0))
+		 '(:name :tab t/r "," im14 "(" s "," b ")"))
        (:emitter
 	(emit-load/store segment ,opcode
 			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
@@ -191,6 +548,10 @@
     `(define-instruction ,name (segment index base reg &key modify scale)
        (:declare (type tn reg base index)
 		 (type (member t nil) modify scale))
+       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
+				      (op2 0))
+				      `(:name ,@cmplt-index-print :tab x/im5/r
+					      "(" s "," b ")" t/im5))
        (:emitter
 	(emit-extended-load/store
 	 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
@@ -220,6 +581,10 @@
        (:declare (type tn base reg)
 		 (type (or fixup (signed-byte 5)) disp)
 		 (type (member :before :after nil) modify))
+       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+				      (op2 4))
+				      `(:name ,@cmplt-disp-print :tab x/im5/r
+					      "(" s "," b ")" t/im5))
        (:emitter
 	(multiple-value-bind
 	    (m a)
@@ -236,6 +601,10 @@
        (:declare (type tn reg base)
 		 (type (or fixup (signed-byte 5)) disp)
 		 (type (member :before :after nil) modify))
+       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+				      (op2 4))
+				      `(:name ,@cmplt-disp-print :tab x/im5/r
+					      "," t/im5 "(" s "," b ")"))
        (:emitter
 	(multiple-value-bind
 	    (m a)
@@ -262,6 +631,8 @@
 	    (type (signed-byte 5) disp)
 	    (type (member :begin :end) where)
 	    (type (member t nil) modify))
+  (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
+	    `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s "," b ")"))
   (:emitter
    (emit-extended-load/store segment #x03 (reg-tn-encoding base)
 			     (reg-tn-encoding reg) 0
@@ -296,6 +667,7 @@
 (define-instruction ldil (segment value reg)
   (:declare (type tn reg)
 	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+  (:printer ldil ((op #x08)))
   (:emitter
    (emit-ldil segment #x08 (reg-tn-encoding reg)
 	      (immed-21-encoding segment value))))
@@ -303,6 +675,7 @@
 (define-instruction addil (segment value reg)
   (:declare (type tn reg)
 	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+  (:printer ldil ((op #x0A)))
   (:emitter
    (emit-ldil segment #x0A (reg-tn-encoding reg)
 	      (immed-21-encoding segment value))))
@@ -358,11 +731,13 @@
 
 (define-instruction bl (segment target reg &key nullify)
   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+  (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
   (:emitter
    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
 
 (define-instruction gateway (segment target reg &key nullify)
   (:declare (type tn reg) (type label target) (type (member t nil) nullify))
+  (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
   (:emitter
    (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
 
@@ -372,6 +747,7 @@
   (:declare (type tn base)
 	    (type (member t nil) nullify)
 	    (type (or tn null) offset))
+  (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "," t))
   (:emitter
    (emit-branch segment #x3A (reg-tn-encoding base)
 		(if offset (reg-tn-encoding offset) 0)
@@ -382,6 +758,8 @@
 	    (type tn base)
 	    (type (unsigned-byte 3) space)
 	    (type (member t nil) nullify))
+  (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
+	    '(:name n :tab w "(" op2 "," t ")"))
   (:emitter
    (multiple-value-bind
        (w1 w2 w)
@@ -394,6 +772,8 @@
 	    (type tn base)
 	    (type (unsigned-byte 3) space)
 	    (type (member t nil) nullify))
+  (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
+	    '(:name n :tab w "(" op2 "," t ")"))
   (:emitter
    (multiple-value-bind
        (w1 w2 w)
@@ -427,6 +807,12 @@
 		     (type tn r1 r2)
 		     (type label target)
 		     (type (member t nil) nullify))
+	   (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
+		     '(:name "T" c n :tab r1 "," r2 "," w))
+	   ,@(unless (= r-opcode #x32)
+	       `((:printer branch12 ((op1 ,(+ 2 r-opcode))
+				     (c nil :type ',conditional))
+			 '(:name "F" c n :tab r1 "," r2 "," w))))
 	   (:emitter
 	    (multiple-value-bind
 		(cond-encoding false)
@@ -440,6 +826,13 @@
 		     (type (signed-byte 5) imm)
 		     (type tn reg)
 		     (type (member t nil) nullify))
+	   (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
+			       (c nil :type ',conditional))
+		     '(:name "T" c n :tab r1 "," r2 w))
+	   ,@(unless (= r-opcode #x32)
+	       `((:printer branch12 ((op1 ,(+ 2 i-opcode))
+				     (c nil :type ',conditional))
+			 '(:name "F" c n :tab r1 "," r2 "," w))))
 	   (:emitter
 	    (multiple-value-bind
 		(cond-encoding false)
@@ -457,11 +850,13 @@
   (:declare (type (member t nil) cond nullify)
 	    (type tn reg)
 	    (type (or (member :variable) (unsigned-byte 5)) posn))
+  (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
+		      '("BVB" c n :tab r1 "," w))
   (:emitter
    (multiple-value-bind
        (opcode posn-encoding)
        (if (eq posn :variable)
-	   (values  0)
+	   (values #x30 0)
 	   (values #x31 posn))
      (emit-conditional-branch segment opcode posn-encoding
 			      (reg-tn-encoding reg)
@@ -478,6 +873,9 @@
   (defmacro define-r3-inst (name cond-kind opcode)
     `(define-instruction ,name (segment r1 r2 res &optional cond)
        (:declare (type tn res r1 r2))
+       (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
+						       cond-kind 
+						       "-CONDITION"))))
        (:emitter
 	(multiple-value-bind
 	    (cond false)
@@ -534,6 +932,9 @@
     `(define-instruction ,name (segment imm src dst &optional cond)
        (:declare (type tn dst src)
 		 (type (signed-byte 11) imm))
+       (:printer imm-inst ((op ,opcode) (o ,subcode)
+			   (c nil :type 
+			      ',(symbolicate cond-kind "-CONDITION"))))
        (:emitter
 	(multiple-value-bind
 	    (cond false)
@@ -558,6 +959,10 @@
 (define-instruction shd (segment r1 r2 count res &optional cond)
   (:declare (type tn res r1 r2)
 	    (type (or (member :variable) (integer 0 31)) count))
+  (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
+	    '(:name c :tab r1 "," r2 "," cp "," t/clen))
+  (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
+	    '("VSHD" c :tab r1 "," r2 "," t/clen))
   (:emitter
    (etypecase count
      ((member :variable)
@@ -578,6 +983,11 @@
        (:declare (type tn res src)
 		 (type (or (member :variable) (integer 0 31)) posn)
 		 (type (integer 1 32) len))
+       (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
+				       (op2 ,opcode))
+		 '(:name c :tab r2 "," cp "," t/clen "," r1))
+       (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
+		 '("V" :name c :tab r2 "," t/clen "," r1))
        (:emitter
 	(etypecase posn
 	  ((member :variable)
@@ -601,6 +1011,20 @@
 		 (type (or tn (signed-byte 5)) src)
 		 (type (or (member :variable) (integer 0 31)) posn)
 		 (type (integer 1 32) len))
+       (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
+		 ',(let ((base '("VDEP" c :tab r1 "," t/clen "," r2)))
+		     (if (= opcode 0) (cons "Z" base) base)))
+       (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
+		 ',(let ((base '("DEP" c :tab r1 "," cp "," t/clen "," r2)))
+		     (if (= opcode 0) (cons "Z" base) base)))
+       (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+				       (op2 ,(+ 4 opcode)))
+		 ',(let ((base '("VDEPI" c :tab r1 "," t/clen "," r2)))
+		     (if (= opcode 0) (cons "Z" base) base)))
+       (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+				       (op2 ,(+ 6 opcode)))
+		 ',(let ((base '( "DEPI" c :tab r1 "," cp "," t/clen "," r2)))
+		     (if (= opcode 0) (cons "Z" base) base)))
        (:emitter
 	(multiple-value-bind
 	    (opcode src-encoding)
@@ -634,6 +1058,7 @@
 (define-instruction break (segment &optional (im5 0) (im13 0))
   (:declare (type (unsigned-byte 13) im13)
 	    (type (unsigned-byte 5) im5))
+  (:printer break () :default :control #'break-control)
   (:emitter
    (emit-break segment 0 im13 0 im5)))
 
@@ -643,18 +1068,22 @@
 (define-instruction ldsid (segment res base &optional (space 0))
   (:declare (type tn res base)
 	    (type (integer 0 3) space))
+  (:printer system-inst ((op2 #x85) (s nil  :printer #(0 0 1 1 2 2 3 3)))
+	    `(:name :tab "(" s "," r1 ")," r3))
   (:emitter
    (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
 		     (reg-tn-encoding res))))
 
 (define-instruction mtsp (segment reg space)
   (:declare (type tn reg) (type (integer 0 7) space))
+  (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
   (:emitter
    (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
 		     #xC1 0)))
 
 (define-instruction mfsp (segment space reg)
   (:declare (type tn reg) (type (integer 0 7) space))
+  (:printer system-inst ((op2 #x25)) '(:name :tab s "," r3))
   (:emitter
    (emit-system-inst segment 0 0 0 (space-encoding space) #x25
 		     (reg-tn-encoding reg))))
@@ -672,12 +1101,14 @@
 
 (define-instruction mtctl (segment reg ctrl-reg)
   (:declare (type tn reg) (type control-reg ctrl-reg))
+  (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
   (:emitter
    (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
 		     0 #xC2 0)))
 
 (define-instruction mfctl (segment ctrl-reg reg)
   (:declare (type tn reg) (type control-reg ctrl-reg))
+  (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
   (:emitter
    (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
 		     (reg-tn-encoding reg))))
@@ -694,6 +1125,10 @@
   (:declare (type tn index base result)
 	    (type (member t nil) modify scale)
 	    (type (member nil 0 1) side))
+  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
+	    `("FLDDX" ,@cmplt-index-print :tab x "(" s "," b ")" "," t))
+  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
+	    `("FLDWX" ,@cmplt-index-print :tab x "(" s "," b ")" "," t))
   (:emitter
    (multiple-value-bind
        (result-encoding double-p)
@@ -709,6 +1144,10 @@
   (:declare (type tn index base value)
 	    (type (member t nil) modify scale)
 	    (type (member nil 0 1) side))
+  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
+	    `("FSTDX",@cmplt-index-print :tab t "," x "(" s "," b ")"))
+  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
+	    `("FSTWX" ,@cmplt-index-print :tab t "," x "(" s "," b ")"))
   (:emitter
    (multiple-value-bind
        (value-encoding double-p)
@@ -725,6 +1164,10 @@
 	    (type (signed-byte 5) disp)
 	    (type (member :before :after nil) modify)
 	    (type (member nil 0 1) side))
+  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
+	    `("FLDDS" ,@cmplt-disp-print :tab x "(" s "," b ")," t))
+  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
+	    `("FLDWS" ,@cmplt-disp-print :tab x "(" s "," b ")," t))
   (:emitter
    (multiple-value-bind
        (result-encoding double-p)
@@ -742,6 +1185,10 @@
 	    (type (signed-byte 5) disp)
 	    (type (member :before :after nil) modify)
 	    (type (member nil 0 1) side))
+  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
+	    `("FSTDS" ,@cmplt-disp-print :tab t "," x "(" s "," b ")"))
+  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
+	    `("FSTWS" ,@cmplt-disp-print :tab t "," x "(" s "," b ")"))
   (:emitter
    (multiple-value-bind
        (value-encoding double-p)
@@ -774,6 +1221,14 @@
 (define-instruction funop (segment op from to)
   (:declare (type funop op)
 	    (type tn from to))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
+	    '("FCPY" fmt :tab r "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
+	    '("FABS" fmt  :tab r "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
+	    '("FSQRT" fmt :tab r "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
+	    '("FRND" fmt :tab r "," t))
   (:emitter
    (multiple-value-bind
        (from-encoding from-double-p)
@@ -790,6 +1245,8 @@
   (defmacro define-class-1-fp-inst (name subcode)
     `(define-instruction ,name (segment from to)
        (:declare (type tn from to))
+       (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
+		 '(:name sf df :tab r "," t))
        (:emitter
 	(multiple-value-bind
 	    (from-encoding from-double-p)
@@ -809,6 +1266,8 @@
 (define-instruction fcmp (segment cond r1 r2)
   (:declare (type (unsigned-byte 5) cond)
 	    (type tn r1 r2))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
+	    '(:name fmt t :tab r "," x1))
   (:emitter
    (multiple-value-bind
        (r1-encoding r1-double-p)
@@ -821,6 +1280,7 @@
 			     (if r1-double-p 1 0) 2 0 0 cond)))))
 
 (define-instruction ftest (segment)
+  (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
   (:emitter
    (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
 
@@ -832,6 +1292,14 @@
 (define-instruction fbinop (segment op r1 r2 result)
   (:declare (type fbinop op)
 	    (type tn r1 r2 result))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
+	    '("FADD" fmt :tab r "," x1 "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
+	    '("FSUB" fmt :tab r "," x1 "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
+	    '("FMPY" fmt :tab r "," x1 "," t))
+  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
+	    '("FDIV" fmt :tab r "," x1 "," t))
   (:emitter
    (multiple-value-bind
        (r1-encoding r1-double-p)
-- 
GitLab