diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp
index 373e19c0f953edffa2a1a1afdaea46e19eee8439..d42d09f9d67fe23d24554c86d4da52d586bc693f 100644
--- a/compiler/sparc/insts.lisp
+++ b/compiler/sparc/insts.lisp
@@ -1,484 +1,210 @@
 ;;; -*- Package: SPARC -*-
 ;;;
 ;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.9 1992/07/09 19:46:32 hallgren Exp $")
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.8 1992/03/06 11:01:37 wlott Exp $
+;;; **********************************************************************
 ;;;
 ;;; Description of the SPARC architecture.
 ;;;
-;;; Written by William Lott
+;;; Written by William Lott.
+;;;
+;;; Converted to the SPARC by Sean Hallgren.
 ;;;
 
 (in-package "SPARC")
-(use-package "ASSEM")
+
+(use-package "NEW-ASSEM")
 (use-package "EXT")
 (use-package "C")
 
-(disassem:set-disassem-params
- :instruction-alignment 32
- :storage-class-sets '((register any-reg descriptor-reg base-character-reg
-				 sap-reg signed-reg unsigned-reg
-				 non-descriptor-reg interior-reg)
-		       (float-reg single-reg double-reg)
-		       (control-stack control-stack)
-		       (number-stack signed-stack unsigned-stack
-				     base-character-stack sap-stack
-				     single-stack double-stack))
- )
+(def-assembler-params
+    :scheduler-p nil)
 
 
-;;;; Special argument types and fixups.
-
-(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*))
-
-(define-argument-type reg
-  :type '(and tn
-	      (satisfies (lambda (object)
-			   (or (eq (sc-name (tn-sc object)) 'null)
-			       (eq (sc-name (tn-sc object)) 'zero)
-			       (eq (sb-name (sc-sb (tn-sc object)))
-				   'registers)))))
-  :function (lambda (tn)
-	      (case (sc-name (tn-sc tn))
-		(null null-offset)
-		(zero 0)
-		(t (tn-offset tn))))
-  :disassem-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
-			   'register
-			   regname
-			   dstate)))
-  )
-
-(defconstant float-reg-symbols
-  (coerce 
-   (loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n)))
-   'vector))
-
-(define-argument-type fp-reg
-  :type '(and tn
-	      (satisfies (lambda (object)
-			   (eq (sb-name (sc-sb (tn-sc object)))
-			       'float-registers))))
-  :function tn-offset
-  :disassem-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-reg
-			   regname
-			   dstate)))
-  )
-
-(define-argument-type odd-fp-reg
-  :type '(and tn
-	      (satisfies (lambda (object)
-			   (eq (sb-name (sc-sb (tn-sc object)))
-			       'float-registers))))
-  :function (lambda (tn) (1+ (tn-offset tn))))
-
-
-(define-argument-type relative-label
-  :type 'label
-  :function (lambda (label)
-	      (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
-  (coerce branch-conditions 'vector))
-
-(define-argument-type branch-condition
-  :type '(member . #.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
-  (coerce branch-fp-conditions 'vector))
-
-(define-argument-type branch-fp-condition
-  :type '(member . #.branch-fp-conditions)
-  :function (lambda (fp-cond) (position fp-cond branch-fp-conditions))
-  :disassem-printer branch-fp-cond-name-vec)
-
-
-(define-fixup-type :call :disassem-use-label t)
-(define-fixup-type :sethi
-  :disassem-printer #'(lambda (value stream dstate)
-			(declare (ignore dstate))
-			(format stream "%hi(#x~8,'0x)" (ash value 10))))
-(define-fixup-type :add)
-
+;;;; Functions to convert TN's and random symbolic things into values.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (sc-case tn
+    (zero zero-offset)
+    (null null-offset)
+    (t
+     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
+	 (tn-offset tn)
+	 (error "~S isn't a register." tn)))))
+
+(defun fp-reg-tn-encoding (tn &optional odd)
+  (declare (type tn tn))
+  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
+    (error "~S isn't a floating-point register." tn))
+  (if odd
+      (1+ (tn-offset tn))
+      (tn-offset tn)))
+
+(defconstant branch-conditions
+  '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))
+
+(deftype branch-condition ()
+  `(member ,@branch-conditions))
+
+(defun branch-condition (condition)
+  (or (position condition branch-conditions)
+      (error "Unknown branch condition: ~S~%Must be one of: ~S"
+	     condition branch-conditions)))
+
+(defconstant fp-branch-conditions
+  '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))
+
+(deftype fp-branch-condition ()
+  `(member ,@fp-branch-conditions))
+
+(defun fp-branch-condition (condition)
+  (or (position condition fp-branch-conditions)
+      (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
+	     condition fp-branch-conditions)))
 
 
-;;;; 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)))
-
-(defconstant branch-printer
-  `(:name (:unless (:constant ,branch-cond-true) cond)
-	  (:unless (a :constant 0) "," 'A)
-	  :tab
-	  disp))
-
-(define-format (format-2-branch 32 :disassem-printer branch-printer)
-  (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))
+;;;; Primitive emitters.
+
+(define-emitter emit-word 32
+  (byte 32 0))
+
+(define-emitter emit-short 16
+  (byte 16 0))
+
+(define-emitter emit-format-1 32
+  (byte 2 30) (byte 30 0))
+
+(define-emitter emit-format-2-immed 32
+  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-emitter emit-format-2-branch 32
+  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
+
+(define-emitter emit-format-2-unimp 32
+  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
+
+(define-emitter emit-format-3-reg 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
+  (byte 5 0))
+
+(define-emitter emit-format-3-immed 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
+
+
+(define-emitter emit-format-3-fpop 32
+  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
 
 
 
-;;;; Instructions.
+;;;; Buncha format-3-instructions.
 
+(defun emit-format-3-inst (segment op op3 dst src1 src2 &key load-store fixup)
+  (unless src2
+    (cond ((and (typep src1 'tn) load-store)
+	   (setf src2 0))
+	  (t
+	   (setf src2 src1)
+	   (setf src1 dst))))
+  (etypecase src2
+    (tn
+     (emit-format-3-reg segment op (reg-tn-encoding dst) op3
+			(reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
+    (integer
+     (emit-format-3-immed segment op (reg-tn-encoding dst) op3
+			  (reg-tn-encoding src1) 1 src2))
+    (fixup
+     (unless (or load-store fixup)
+       (error "Fixups aren't allowed."))
+     (note-fixup segment :add src2)
+     (emit-format-3-immed segment op (reg-tn-encoding dst) op3
+			  (reg-tn-encoding src1) 1 0))))
+
+(defun emit-fp-format-3-inst (segment op op3 dst src1 src2
+				      &key load-store fixup odd)
+  (unless src2
+    (cond ((and (typep src1 'tn) load-store)
+	   (setf src2 0))
+	  (t
+	   (setf src2 src1)
+	   (setf src1 dst))))
+  (etypecase src2
+    (tn
+     (emit-format-3-reg segment op (fp-reg-tn-encoding dst odd) op3
+			(reg-tn-encoding src1) 0 0
+			(reg-tn-encoding src2)))
+    (integer
+     (emit-format-3-immed segment op (fp-reg-tn-encoding dst odd) op3
+			  (reg-tn-encoding src1) 1 src2))
+    (fixup
+     (unless (or load-store fixup)
+       (error "Fixups aren't allowed."))
+     (note-fixup segment :add src2)
+     (emit-format-3-immed segment op (fp-reg-tn-encoding dst odd) op3
+			  (reg-tn-encoding src1) 1 0))))
 
 
 (eval-when (compile eval)
 
-;;; 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)
-		   (rs1 :argument reg)
-		   (rs2 :argument reg))
-     ,(if (not load-store)
-	  `(format-3-reg (op :constant ,op)
-			 (rd :argument ,dest-kind)
-			 (op3 :constant ,op3)
-			 (rs1 :same-as rd)
-			 (rs2 :argument reg))
-	  `(format-3-immed (op :constant ,op)
-			   (rd :argument ,dest-kind)
-			   (op3 :constant ,op3)
-			   (rs1 :argument reg)
-			   (immed :constant 0)))
-     (format-3-immed (op :constant ,op)
-		     (rd :argument ,dest-kind)
-		     (op3 :constant ,op3)
-		     (rs1 :argument reg)
-		     (immed :argument (signed-byte 13)))
-     (format-3-immed (op :constant ,op)
-		     (rd :argument ,dest-kind)
-		     (op3 :constant ,op3)
-		     (rs1 :same-as rd)
-		     (immed :argument (signed-byte 13)))
-     ,@(when (or load-store fixup)
-	 `((format-3-immed (op :constant ,op)
-			   (rd :argument ,dest-kind)
-			   (op3 :constant ,op3)
-			   (rs1 :argument reg)
-			   (immed :argument add-fixup))
-	   (format-3-immed (op :constant ,op)
-			   (rd :argument ,dest-kind)
-			   (op3 :constant ,op3)
-			   (rs1 :same-as rd)
-			   (immed :argument add-fixup))))))
-
-(setf (macro-function 'define-f3-inst)
-      (compile nil (function-lambda-expression
-		    (macro-function 'define-f3-inst))))
-
-) ; eval-when
+(defmacro define-f3-inst (name op op3 &key fixup load-store dest-kind)
+  `(define-instruction ,name (segment dst src1 &optional src2)
+     (:declare (type tn dst)
+	       ,(if (or fixup load-store)
+		    '(type (or tn (signed-byte 13) null fixup) src1 src2)
+		    '(type (or tn (signed-byte 13) null) src1 src2)))
+     ,(if dest-kind
+	  `(:emitter (emit-fp-format-3-inst segment ,op ,op3 dst src1 src2
+					    :load-store ,load-store
+					    :fixup ,fixup
+					    :odd (eq ',dest-kind 'odd-fp-reg)))
+	  `(:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
+					 :load-store ,load-store
+					 :fixup ,fixup)))))
+
+) ; eval-when (compile eval)
 
 (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)
-
-(defun note-niss-ref (chunk inst stream dstate)
-  (when stream
-    (disassem:maybe-note-nil-indexed-symbol-slot-ref
-     (disassem:arg-value 'immed chunk inst)
-     dstate)))
-
-(defun note-control-stack-var-ref (chunk inst stream dstate)
-  (when stream
-    (disassem:maybe-note-single-storage-ref
-     (/ (disassem:arg-value 'immed chunk inst) word-bytes)
-     'control-stack
-     dstate))
-  )
-
-(defun note-number-stack-var-ref (chunk inst stream dstate)
-  (when stream
-    (disassem:maybe-note-single-storage-ref
-     (/ (disassem:arg-value 'immed chunk inst) word-bytes)
-     'number-stack
-     dstate))
-  )
-
-(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 #'note-niss-ref)
-  immed
-  (rs1 :constant null-offset))
-
-(disassem:specialize (ld :disassem-control #'note-control-stack-var-ref)
-  immed
-  (rs1 :constant cfp-offset))
-
-(disassem:specialize (ld :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
-;;; ----------------------------------------------------------------
-
 (define-f3-inst ldd #b11 #b000011 :load-store :load)
-(disassem:specialize (ldd :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
 (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
-(disassem:specialize (ldf :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
 (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)
-(disassem:specialize (lddf :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
 (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 #'note-niss-ref)
-  immed
-  (rs1 :constant null-offset))
-
-(disassem:specialize (st :disassem-control #'note-control-stack-var-ref)
-  immed
-  (rs1 :constant cfp-offset))
-
-(disassem:specialize (st :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-;;; ----------------------------------------------------------------
-
 (define-f3-inst std #b11 #b000111 :load-store :store)
-(disassem:specialize (std :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
 (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
-(disassem:specialize (stf :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
-(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)
-(disassem:specialize (stdf :disassem-control #'note-number-stack-var-ref)
-  immed
-  (rs1 :constant nfp-offset))
-
+(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)
-
-(define-instruction (ldfsr)
-  (format-3-immed (op :constant #b11)
-		  (rd :constant 0)
-		  (op3 :constant #b100001)
-		  (rs1 :argument reg)
-		  (immed :argument (signed-byte 13))))
-
-(define-instruction (stfsr)
-  (format-3-immed (op :constant #b11)
-		  (rd :constant 0)
-		  (op3 :constant #b100101)
-		  (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 'rs1 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)
-
 (define-f3-inst taddcc #b10 #b100000)
 (define-f3-inst taddcctv #b10 #b100010)
-
 (define-f3-inst sub #b10 #b000100)
 (define-f3-inst subcc #b10 #b010100)
 (define-f3-inst subx #b10 #b001100)
 (define-f3-inst subxcc #b10 #b011100)
-
 (define-f3-inst tsubcc #b10 #b100001)
 (define-f3-inst tsubcctv #b10 #b100011)
-
 (define-f3-inst mulscc #b10 #b100100)
-
 (define-f3-inst and #b10 #b000001)
 (define-f3-inst andcc #b10 #b010001)
 (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)
@@ -486,267 +212,168 @@
 (define-f3-inst xorcc #b10 #b010011)
 (define-f3-inst xnor #b10 #b000111)
 (define-f3-inst xnorcc #b10 #b010111)
-
 (define-f3-inst sll #b10 #b100101)
 (define-f3-inst srl #b10 #b100110)
 (define-f3-inst sra #b10 #b100111)
-
-(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))))
-  (format-2-immed (rd :argument reg)
-		  (op2 :constant #b100)
-		  (immed :argument sethi-fixup)))
-
 (define-f3-inst save #b10 #b111100)
 (define-f3-inst restore #b10 #b111101)
 
-(define-instruction (b)
-  (format-2-branch (op :constant #b00)
-		   (a :constant 0)
-		   (cond :argument branch-condition)
-		   (op2 :constant #b010)
-		   (disp :argument relative-label))
-  (format-2-branch (op :constant #b00)
-		   (a :constant 0)
-		   (cond :constant branch-cond-true)
-		   (op2 :constant #b010)
-		   (disp :argument relative-label)))
-
-(define-instruction (ba)
-  (format-2-branch (op :constant #b00)
-		   (a :constant 1)
-		   (cond :argument branch-condition)
-		   (op2 :constant #b010)
-		   (disp :argument relative-label))
-  (format-2-branch (op :constant #b00)
-		   (a :constant 1)
-		   (cond :constant #b1000)
-		   (op2 :constant #b010)
-		   (disp :argument relative-label)))
-(disassem:specialize (ba :name 'b))
-
-(define-instruction (t
-		     :disassem-printer '(:name rd :tab immed))
-  (format-3-immed (op :constant #b10)
-		  (rd :argument branch-condition)
-		  (op3 :constant #b111010)
-		  (rs1 :constant 0)
-		  (immed :argument (or (signed-byte 13) (unsigned-byte 13)))))
-
-(define-instruction (fb)
-  (format-2-branch (op :constant #b00)
-		   (a :constant 0)
-		   (cond :argument branch-fp-condition)
-		   (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 :disassem-printer jal-printer)
-  (format-3-reg (op :constant #b10)
-		(rd :argument reg)
-		(op3 :constant #b111000)
-		(rs1 :argument reg)
-		(rs2 :argument reg))
-  (format-3-reg (op :constant #b10)
-		(rd :argument reg)
-		(op3 :constant #b111000)
-		(rs1 :constant 0)
-		(rs2 :argument reg))
-  (format-3-immed (op :constant #b10)
-		  (rd :argument reg)
-		  (op3 :constant #b111000)
-		  (rs1 :argument reg)
-		  (immed :argument (signed-byte 13)))
-  (format-3-immed (op :constant #b10)
-		  (rd :argument reg)
-		  (op3 :constant #b111000)
-		  (rs1 :argument reg)
-		  (immed :argument add-fixup)))
-
-(disassem:specialize (jal :disassem-control #'look-at-sethi-note)
-  immed)
-
-(define-instruction (j :disassem-printer jal-printer)
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b111000)
-		(rs1 :argument reg)
-		(rs2 :argument reg))
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b111000)
-		(rs1 :argument reg)
-		(rs2 :constant 0))
-  (format-3-immed (op :constant #b10)
-		  (rd :constant 0)
-		  (op3 :constant #b111000)
-		  (rs1 :argument reg)
-		  (immed :argument (signed-byte 13)))
-  (format-3-immed (op :constant #b10)
-		  (rd :constant 0)
-		  (op3 :constant #b111000)
-		  (rs1 :argument reg)
-		  (immed :argument add-fixup)))
-
-(disassem:specialize (j :disassem-control #'look-at-sethi-note)
-  immed)
-
-(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
-		     :disassem-printer
-		         '('WR :tab
-			        rs1
-				(:unless (:constant 0) ", " (:choose immed rs2))
-				", " '%Y))
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b110000)
-		(rs1 :argument reg)
-		(rs2 :argument reg))
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b110000)
-		(rs1 :argument reg)
-		(rs2 :constant 0))
-  (format-3-immed (op :constant #b10)
-		  (rd :constant 0)
-		  (op3 :constant #b110000)
-		  (rs1 :argument reg)
-		  (immed :argument (signed-byte 13))))
-
-;;; ----------------------------------------------------------------
-
-(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))))
-
-;;; ----------------------------------------------------------------
+
+;;;; Random instructions.
+
+(define-instruction ldfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:emitter (emit-format-3-immed segment #b11 0 #b100001
+				 (reg-tn-encoding src1) 1 src2)))
+
+(define-instruction stfsr (segment src1 src2)
+  (:declare (type tn src1) (type (signed-byte 13) src2))
+  (:emitter (emit-format-3-immed segment #b11 0 #b100101 
+				 (reg-tn-encoding src1) 1 src2)))
+
+(define-instruction sethi (segment dst src1)
+  (:declare (type tn dst)
+	    (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
+  (:emitter
+   (etypecase src1
+     (integer
+      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
+				 src1))
+     (fixup
+      (note-fixup segment :sethi src1)
+      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
+			   
+
+(define-instruction rdy (segment dst)
+  (:declare (type tn dst))
+  (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
+				 0 1 0)))
+
+(define-instruction wry (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
+  (:emitter
+   (etypecase src2
+     (null 
+      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
+			   src2)))))
+
+(define-instruction unimp (segment data)
+  (:declare (type (unsigned-byte 22) data))
+  (:emitter (emit-format-2-unimp segment 0 0 0 data)))
 
 
+
+;;;; Branch instructions.
+
+(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
+  (emit-back-patch segment 4
+		  #'(lambda (segment posn)
+		      (unless target
+			(setf target cond-or-target)
+			(setf cond-or-target :t))
+		      (emit-format-2-branch
+		       segment #b00 a
+		       (if fp
+			   (fp-branch-condition cond-or-target)
+			   (branch-condition cond-or-target))
+		       op2
+		       (ash (- (label-position target) posn) -2)))))
+
+(define-instruction b (segment cond-or-target &optional target)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target))
+  (:emitter
+   (emit-relative-branch segment 0 #b010 cond-or-target target)))
+
+(define-instruction ba (segment cond-or-target &optional target)
+  (:declare (type (or label branch-condition) cond-or-target)
+	    (type (or label null) target))
+  (:emitter
+   (emit-relative-branch segment 1 #b010 cond-or-target target)))
+
+(define-instruction t (segment condition target)
+  (:declare (type branch-condition condition)
+	    (type (or (signed-byte 13) (unsigned-byte 13)) target))
+  (:emitter (emit-format-3-immed segment #b10 (branch-condition condition)
+				 #b111010 0 1 target)))
+
+(define-instruction fb (segment condition target)
+  (:declare (type fp-branch-condition condition) (type label target))
+  (:emitter
+   (emit-relative-branch segment 0 #b110 condition target t)))
+
+(define-instruction jal (segment dst src1 &optional src2)
+  (:declare (type tn dst)
+	    (type (or tn integer) src1)
+	    (type (or null fixup tn (signed-byte 13)) src2))
+  (:emitter
+   (unless src2
+     (setf src2 src1)
+     (setf src1 0))
+   (etypecase src2
+     (tn
+      (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
+			 (if (integerp src1)
+			     src1
+			     (reg-tn-encoding src1))
+			 0 0 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
+			   (reg-tn-encoding src1) 1 src2))
+     (fixup
+      (note-fixup segment :add src2)
+      (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
+			   #b111000 (reg-tn-encoding src1) 1 0)))))
+
+
+(define-instruction j (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
+  (:emitter
+   (etypecase src2
+     (null
+      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
+			   src2))
+     (fixup
+      (note-fixup segment :add src2)
+      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
+			   0)))))
+
+
+
+;;;; Unary and binary fp insts.
+
+(defun emit-fp-inst (segment opf op3 dst src1 src2)
+  (unless src2
+    (setf src2 src1)
+    (setf src1 dst))
+  (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) op3
+		      (fp-reg-tn-encoding src1) opf (fp-reg-tn-encoding src2)))
+
 (eval-when (compile eval)
 
-(defmacro define-unary-fp-inst (name opf &optional odd)
-  (let ((kind (if odd 'odd-fp-reg 'fp-reg)))
-    `(define-instruction (,name)
-       (format-3-fpop (op :constant #b10)
-		      (rd :argument ,kind)
-		      (op3 :constant #b110100)
-		      (rs1 :argument ,kind)
-		      (opf :constant ,opf)
-		      (rs2 :argument ,kind))
-       (format-3-fpop (op :constant #b10)
-		      (rd :argument ,kind)
-		      (op3 :constant #b110100)
-		      (rs1 :same-as rd)
-		      (opf :constant ,opf)
-		      (rs2 :argument ,kind)))))
+(defmacro define-unary-fp-inst (name opf)
+  `(define-instruction ,name (segment dst src1 &optional src2)
+     (:declare (type tn dst src1) (type (or null tn) src2))
+     (:emitter (emit-fp-inst segment ,opf #b110100 dst src1 src2))))
 
 (defmacro define-binary-fp-inst (name opf &optional (op3 #b110100))
-  `(define-instruction (,name)
-     (format-3-fpop (op :constant #b10)
-		    (rd :argument fp-reg)
-		    (op3 :constant ,op3)
-		    (rs1 :argument fp-reg)
-		    (opf :constant ,opf)
-		    (rs2 :argument fp-reg))
-     (format-3-fpop (op :constant #b10)
-		    (rd :argument fp-reg)
-		    (op3 :constant ,op3)
-		    (rs1 :same-as rd)
-		    (opf :constant ,opf)
-		    (rs2 :argument fp-reg))))
-
+  `(define-instruction ,name (segment dst src1 &optional src2)
+     (:declare (type tn dst src1) (type (or null tn) src2))
+     (:emitter (emit-fp-inst segment ,opf ,op3 dst src1 src2))))
+  
 ); eval-when (compile eval)
 
+
 (define-unary-fp-inst fitos #b011000100)
 (define-unary-fp-inst fitod #b011001000)
 (define-unary-fp-inst fitox #b011001100)
@@ -767,7 +394,7 @@
 (define-unary-fp-inst fxtod #b011001011)
 
 (define-unary-fp-inst fmovs #b000000001)
-(define-unary-fp-inst fmovs-odd #b000000001 t)
+(define-unary-fp-inst fmovs-odd #b000000001)
 (define-unary-fp-inst fnegs #b000000101)
 (define-unary-fp-inst fabss #b000001001)
 
@@ -776,6 +403,7 @@
 (define-unary-fp-inst fsqrtx #b000101011)
 
 
+
 (define-binary-fp-inst fadds #b001000001)
 (define-binary-fp-inst faddd #b001000010)
 (define-binary-fp-inst faddx #b001000011)
@@ -798,197 +426,199 @@
 (define-binary-fp-inst fcmpex #b001010111 #b110101)
 
 
-
 
-;;;; Pseudo-instructions, etc.
-
-(define-pseudo-instruction li 64 (reg value)
-  (etypecase value
-    ((signed-byte 13)
-     (inst add reg zero-tn value))
-    ((or (signed-byte 32) (unsigned-byte 32))
-     (let ((hi (ldb (byte 22 10) value))
-	   (lo (ldb (byte 10 0) value)))
-       (inst sethi reg hi)
-       (unless (zerop lo)
-	 (inst add reg lo))))
-    (fixup
-     (inst sethi reg value)
-     (inst add reg value))))
+;;;; li, jali, ji, nop, cmp, not, neg, move, and more
+
+(define-instruction li (segment reg value)
+  (:declare (type tn reg)
+	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+		      fixup) value))
+  (:vop-var vop)
+  (:emitter
+   (assemble (segment vop)
+	     (etypecase value
+	       ((signed-byte 13)
+		(inst add reg zero-tn value))
+	       ((or (signed-byte 32) (unsigned-byte 32))
+		(let ((hi (ldb (byte 22 10) value))
+		      (lo (ldb (byte 10 0) value)))
+		  (inst sethi reg hi)
+		  (unless (zerop lo)
+		    (inst add reg lo))))
+	       (fixup
+		(inst sethi reg value)
+		(inst add reg value))))))
 
 ;;; Jal to a full 32-bit address.  Tmpreg is trashed.
-(define-pseudo-instruction jali 64 (link tmpreg value)
-  (etypecase value
-    ((signed-byte 13)
-     (inst jal link zero-tn value))
-    ((or (signed-byte 32) (unsigned-byte 32))
-     (let ((hi (ldb (byte 22 10) value))
-	   (lo (ldb (byte 10 0) value)))
-       (inst sethi tmpreg hi)
-       (inst jal link tmpreg lo)))
-    (fixup
-     (inst sethi tmpreg value)
-     (inst jal link tmpreg value))))
+(define-instruction jali (segment link tmpreg value)
+  (:declare (type tn link tmpreg)
+	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+		      fixup) value))
+  (:vop-var vop)
+  (:emitter
+   (assemble (segment vop)
+     (etypecase value
+       ((signed-byte 13)
+	(inst jal link zero-tn value))
+       ((or (signed-byte 32) (unsigned-byte 32))
+	(let ((hi (ldb (byte 22 10) value))
+	      (lo (ldb (byte 10 0) value)))
+	  (inst sethi tmpreg hi)
+	  (inst jal link tmpreg lo)))
+       (fixup
+	(inst sethi tmpreg value)
+	(inst jal link tmpreg value))))))
 
 ;;; Jump to a full 32-bit address.  Tmpreg is trashed.
-(define-pseudo-instruction ji 64 (tmpreg value)
-  (inst jali zero-tn tmpreg value))
-
-(define-instruction (nop :disassem-printer '(:name))
-  (format-2-immed (rd :constant 0)
-		  (op2 :constant #b100)
-		  (immed :constant 0)))
-
-(define-instruction (cmp
-		     :disassem-printer
-		         '(:name :tab rs1 ", " (:choose immed rs2)))
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b010100)
-		(rs1 :argument reg)
-		(rs2 :argument reg))
-  (format-3-reg (op :constant #b10)
-		(rd :constant 0)
-		(op3 :constant #b010100)
-		(rs1 :argument reg)
-		(rs2 :constant 0))
-  (format-3-immed (op :constant #b10)
-		  (rd :constant 0)
-		  (op3 :constant #b010100)
-		  (rs1 :argument reg)
-		  (immed :argument (signed-byte 13))))
-
-(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)
-		(rs1 :argument reg)
-		(rs2 :constant 0))
-  (format-3-reg (op :constant #b10)
-		(rd :argument reg)
-		(op3 :constant #b000111)
-		(rs1 :same-as rd)
-		(rs2 :constant 0)))
-
-(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)
-		(rs1 :constant 0)
-		(rs2 :argument reg))
-  (format-3-reg (op :constant #b10)
-		(rd :argument reg)
-		(op3 :constant #b000100)
-		(rs1 :constant 0)
-		(rs2 :same-as rd)))
-
-(define-instruction (move :disassem-printer '(:name :tab rs2 ", " rd))
-  (format-3-reg (op :constant #b10)
-		(rd :argument reg)
-		(op3 :constant #b000010)
-		(rs1 :constant 0)
-		(rs2 :argument reg)))
+(define-instruction ji (segment tmpreg value)
+  (:declare (type tn tmpreg)
+	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+		      fixup) value))
+  (:vop-var vop)
+  (:emitter
+   (assemble (segment vop)
+	     (inst jali zero-tn tmpreg value))))
+
+(define-instruction nop (segment)
+  (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
+
+(define-instruction cmp (segment src1 &optional src2)
+  (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
+  (:emitter
+   (etypecase src2
+     (null
+      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
+     (tn
+      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
+			 (reg-tn-encoding src2)))
+     (integer
+      (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
+			   src2)))))
+
+(define-instruction not (segment dst &optional src1)
+  (:declare (type tn dst) (type (or tn null) src1))
+  (:emitter
+   (unless src1
+     (setf src1 dst))
+   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
+		      (reg-tn-encoding src1) 0 0 0)))
+
+(define-instruction neg (segment dst &optional src1)
+  (:declare (type tn dst) (type (or tn null) src1))
+  (:emitter
+   (unless src1
+     (setf src1 dst))
+   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
+		      0 0 0 (reg-tn-encoding src1))))
+
+(define-instruction move (segment dst src1)
+  (:declare (type tn dst src1))
+  (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
+			       0 0 0 (reg-tn-encoding src1))))
 
 
-;;; Instructions for dumping data and header objects.
-
-(define-format (word-format 32)
-  (data (byte 32 0)))
-(define-instruction (word)
-  (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
-
-(define-format (short-format 16)
-  (data (byte 16 0)))
-(define-instruction (short)
-  (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
-
-(define-format (byte-format 8)
-  (data (byte 8 0)))
-(define-instruction (byte)
-  (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
-
-
-(define-format (header-object 32)
-  (type (byte 8 0))
-  (data (byte 24 8)
-	:default 0
-	:function (lambda (ignore)
-		    (declare (ignore ignore))
-		    (ash (+ *current-position* (component-header-length))
-			 (- vm:word-shift)))))
-
-(define-instruction (function-header-word)
-  (header-object (type :constant vm:function-header-type)))
-
-(define-instruction (lra-header-word)
-  (header-object (type :constant vm:return-pc-header-type)))
-
+;;;; Instructions for dumping data and header objects.
+
+(define-instruction word (segment word)
+  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
+  :pinned
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction short (segment short)
+  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
+  :pinned
+  (:emitter
+   (emit-short segment short)))
+
+(define-instruction byte (segment byte)
+  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+  :pinned
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-emitter emit-header-object 32
+  (byte 24 8) (byte 8 0))
+
+
+  
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 4
+   #'(lambda (segment posn)
+       (emit-word segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  :pinned
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  :pinned
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
 
 
-;;;; Instructions for converting between code objects, functions, and lras
-
-(eval-when (compile eval)
-
-(defmacro define-compute-instruction (name calculation)
-  (let ((add (symbolicate name "-ADD"))
-	(sethi (symbolicate name "-SETHI"))
-	(or (symbolicate name "-OR")))
-    `(progn
-       (define-instruction (,add)
-	 (format-3-immed
-	  (op :constant #b10)
-	  (rd :argument reg)
-	  (op3 :constant #b000000)
-	  (rs1 :argument reg)
-	  (immed :argument label
-		 :function (lambda (label)
-			     (let ((result ,calculation))
-			       (assert (typep result '(signed-byte 13)))
-			       result)))))
-       (define-instruction (,sethi)
-	 (format-2-immed (rd :argument reg)
-			 (op2 :constant #b100)
-			 (immed :argument label
-				:function (lambda (label)
-					    (ash ,calculation -10)))))
-       (define-instruction (,or)
-	 (format-3-immed (op :constant #b10)
-			 (rd :argument reg)
-			 (op3 :constant #b000010)
-			 (rs1 :same-as rd)
-			 (immed :argument label
-				:function (lambda (label)
-					    (logand ,calculation
-						    (1- (ash 1 10)))))))
-       (define-pseudo-instruction ,name 96 (dst src label temp)
-	 (cond ((typep ,calculation '(signed-byte 13))
-		(inst ,add dst src label))
-	       (t
-		(inst ,sethi temp label)
-		(inst ,or temp label)
-		(inst add dst src temp)))))))
-
-); eval-when (compile eval)
-
+;;;; Instructions for converting between code objects, functions, and lras.
+
+
+(defun emit-compute-inst (segment vop dst src label temp calc)
+  (emit-chooser
+   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
+   segment 12 3
+   #'(lambda (segment posn delta-if-after)
+       (let ((delta (funcall calc label posn delta-if-after)))
+	 (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
+	   (emit-back-patch segment 4
+			    #'(lambda (segment posn)
+				(assemble (segment vop)
+					  (inst add dst src
+						(funcall calc label posn 0)))))
+	   t)))
+   #'(lambda (segment posn)
+       (let ((delta (funcall calc label posn 0)))
+	 (assemble (segment vop)
+		   (inst sethi temp (ldb (byte 22 10) delta))
+		   (inst or temp (ldb (byte 10 0) delta))
+		   (inst add dst src temp))))))
 
 ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
-(define-compute-instruction compute-code-from-fn
-			    (- vm:other-pointer-type
-			       vm:function-pointer-type
-			       (label-position label)
-			       (component-header-length)))
+(define-instruction compute-code-from-fn (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:reads src)
+  (:writes (list dst temp))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- other-pointer-type
+			     function-pointer-type
+			     (label-position label posn delta-if-after)
+			     (component-header-length))))))
 
 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-(define-compute-instruction compute-code-from-lra
-			    (- (+ (label-position label)
-				  (component-header-length))))
+(define-instruction compute-code-from-lra (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:reads src)
+  (:writes (list dst temp))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (- (+ (label-position label posn delta-if-after)
+				(component-header-length)))))))
 
 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-(define-compute-instruction compute-lra-from-code
-			    (+ (label-position label)
-			       (component-header-length)))
-
+(define-instruction compute-lra-from-code (segment dst src label temp)
+  (:declare (type tn dst src temp) (type label label))
+  (:reads src)
+  (:writes (list dst temp))
+  (:vop-var vop)
+  (:emitter
+   (emit-compute-inst segment vop dst src label temp
+		      #'(lambda (label posn delta-if-after)
+			  (+ (label-position label posn delta-if-after)
+			     (component-header-length))))))