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)