Initial revision
authorrlaakso <rlaakso>
Fri, 5 Aug 2005 13:13:29 +0000 (5 13:13 +0000)
committerrlaakso <rlaakso>
Fri, 5 Aug 2005 13:13:29 +0000 (5 13:13 +0000)
18 files changed:
TODO [new file with mode: 0644]
cpuid-vop.lisp [new file with mode: 0644]
cpuid.lisp [new file with mode: 0644]
example-test.lisp [new file with mode: 0644]
generate-sse-instructions.lisp [new file with mode: 0644]
sbcl-src/makepatch.sh [new file with mode: 0755]
sbcl-src/patch_against_sbcl_0_9_3 [new file with mode: 0644]
sbcl-src/src-093/compiler/x86/insts.lisp [new file with mode: 0644]
sbcl-src/src-093/compiler/x86/vm.lisp [new file with mode: 0644]
sbcl-src/src/compiler/x86/insts.lisp [new file with mode: 0644]
sbcl-src/src/compiler/x86/vm.lisp [new file with mode: 0644]
scratch/.emacs.desktop [new file with mode: 0644]
scratch/README [new file with mode: 0644]
scratch/asm-t1.asm [new file with mode: 0644]
scratch/foo.lisp [new file with mode: 0644]
scratch/sse.lisp [new file with mode: 0644]
scratch/sse2.lisp [new file with mode: 0644]
sse-vop.lisp [new file with mode: 0644]

diff --git a/TODO b/TODO
new file mode 100644 (file)
index 0000000..0260311
--- /dev/null
+++ b/TODO
@@ -0,0 +1,20 @@
+
+operations from AMD manual:
+
+
+sign:
+
+andps xmm0, #x8000 0000 8000 0000 ..
+
+neg:
+
+xorps xmm0, #x8000 0000 8000 0000 ..
+
+abs:
+
+andps xmm0, #x7FFF FFFF 7FFF FFFF ..
+
+clear:
+
+xorps xmm0, xmm0
+
diff --git a/cpuid-vop.lisp b/cpuid-vop.lisp
new file mode 100644 (file)
index 0000000..2f79c70
--- /dev/null
@@ -0,0 +1,96 @@
+(in-package :sb-c)
+(ignore-errors (defknown cl-user::%read-cpu (unsigned-byte-32 simple-array-unsigned-byte-16) nil))
+
+(in-package :sb-vm)
+
+(defmacro vect-ea (vect idx)
+  `(make-ea :dword :base ,vect :index ,idx
+    :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+
+(define-vop (%read-cpu/x86)
+    (:translate cl-user::%read-cpu)
+  (:policy :fast)
+
+  (:args (n :scs (unsigned-reg) :target eax)
+        (result :scs (descriptor-reg)))
+  (:arg-types unsigned-byte-32 simple-array-unsigned-byte-16)
+
+  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
+  (:temporary (:sc unsigned-reg :offset ebx-offset) ebx)
+  (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+  (:temporary (:sc unsigned-reg :offset edx-offset) edx)
+  (:temporary (:sc unsigned-reg) index)
+
+  (:generator 10
+
+             (inst xor index index)
+
+             (inst mov eax n)
+
+             ;; zero regs
+             (inst xor ebx ebx)
+             (inst xor ecx ecx)
+             (inst xor edx edx)
+
+             ;; cpuid
+             (inst cpuid)
+
+             (inst push edx)
+
+             ;; EAX
+             (inst mov edx eax)
+             (inst shr edx 16)
+             (inst and edx #xFFFF)
+             (inst mov (vect-ea result index) edx)
+             (inst add index 2)
+
+             (inst mov edx eax)
+             (inst and edx #xFFFF)
+             (inst mov (vect-ea result index) edx)
+             (inst add index 2)
+
+             (inst pop edx)
+
+             ;; EBX
+
+             (inst mov eax ebx)
+             (inst shr eax 16)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+
+             (inst mov eax ebx)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+
+             ;; ECX
+
+             (inst mov eax ecx)
+             (inst shr eax 16)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+
+             (inst mov eax ecx)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+
+             ;; EDX
+             (inst mov eax edx)
+             (inst shr eax 16)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+
+             (inst mov eax edx)
+             (inst and eax #xFFFF)
+             (inst mov (vect-ea result index) eax)
+             (inst add index 2)
+             ))
+
+
+
+
+
diff --git a/cpuid.lisp b/cpuid.lisp
new file mode 100644 (file)
index 0000000..55c4f9c
--- /dev/null
@@ -0,0 +1,139 @@
+(defpackage :cpuid (:use :cl))
+(in-package :cpuid)
+
+
+(defvar +cpu-std-feat-fields+
+  #(:fpu :vme :de :pse :tsc :k86-msr :pae :mce :cmpxchg8b :apic :res10 :sysenter/exit :mtrr :gpe :mca :cmov :pat :pse-36 :psn :clflush :res20 :ds :acpi :mmx :fxsave/rstor :sse :sse2 :self-snoop :htt :tm :res30 :pbe))
+    
+(defvar +cpu-std-feat-fields-ecx+
+  #(:sse3 :res1 :res2 :monitor :ds-cpl :res5 :res6 :eist :tm2 :res9 :cid :res11 :res12 :cmpxchg16b :stpm :res14 :res15
+    0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+
+;; low bits are mostly same as in std-feat, so skip them.. 
+(defvar +cpu-ext-feat-fields+
+  #(0 1 2 3 4 5 6 7 8 9 10 :syscall/ret 12 13 14 15 16 17 18 19 :nx 21 :mmx-ext :mmx 24 25 26 27 28 :longmode/em64t :3dnow-ext :3dnow))
+
+
+(defvar *cpu-features* nil)
+(defvar *cpu-vendor* nil) ;; eg authenticamd
+(defvar *cpu-name* nil)        ;; eg AMD Athlon XP 
+(defvar *cpu-cache* nil)
+
+
+(defun inspect-cpu ()
+
+  (let ((array (make-array 8 :element-type '(unsigned-byte 16) :initial-element 0)) c d)
+
+    ;; vendor
+
+    (sb-sys:%primitive sb-vm::%read-cpu/x86 #x00000000 array)
+
+    (let ((temp (make-array 12 :element-type '(unsigned-byte 8) :initial-element 0)))
+      (flet ((load-word (i u v) (setf (aref temp (+ i 3)) (ash (aref array u) -8)
+                                     (aref temp (+ i 2)) (logand (aref array u) 255)
+                                     (aref temp (+ i 1)) (ash (aref array v) -8)
+                                     (aref temp (+ i 0)) (logand (aref array v) 255))))
+      (loop for i from 0 below 12 by 4
+           for (u v) in '((2 3) (6 7) (4 5))
+           do (load-word i u v))
+
+      (setq *cpu-vendor* (map 'string #'code-char temp))))
+                                        
+
+    ;; std features
+    (setq *cpu-features* nil)
+
+    (sb-sys:%primitive sb-vm::%read-cpu/x86 #x00000001 array)
+
+    (setq
+;;     a (logior (ash (aref array 0) 16) (aref array 1))
+;;     b (logior (ash (aref array 2) 16) (aref array 3))
+     c (logior (ash (aref array 4) 16) (aref array 5))
+     d (logior (ash (aref array 6) 16) (aref array 7)))
+
+    (loop for i from 0 below 32 do
+         (if (= (ldb (byte 1 i) d) 1)
+             (push (aref +cpu-std-feat-fields+ i) *cpu-features*)))
+
+    (loop for i from 0 below 32 do
+         (if (= (ldb (byte 1 i) c) 1)
+             (push (aref +cpu-std-feat-fields-ecx+ i) *cpu-features*))))
+  )
+
+(defun inspect-cpu-ext ()
+  (let ((array (make-array 8 :element-type '(unsigned-byte 16) :initial-element 0)) 
+       c d (max-ext-func 0))
+
+    ;; determine max ext func
+    (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000000 array)
+    (setq max-ext-func (logior (ash (aref array 0) 16) (aref array 1)))
+
+    ;; ext features (AMD/Intel)
+    (if (>= max-ext-func #x80000001)
+       (progn
+         (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000001 array)
+         (setq d (logior (ash (aref array 6) 16) (aref array 7)))
+
+         (loop for i from 0 below 32 do
+               (let ((flag (ldb (byte 1 i) d))
+                     (feat (aref +cpu-ext-feat-fields+ i)))
+                 (if (and (= flag 1) (keywordp feat))
+                     (pushnew feat *cpu-features*))))))
+
+    ;; cpu name (AMD/Intel)
+    (setq *cpu-name* nil)
+    (if (>= max-ext-func #x80000004)
+       (let ((cpuname #())
+             (temp (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)))
+         (flet ((load-word (i u v) (setf (aref temp (+ i 3)) (ash (aref array u) -8)
+                                         (aref temp (+ i 2)) (logand (aref array u) 255)
+                                         (aref temp (+ i 1)) (ash (aref array v) -8)
+                                         (aref temp (+ i 0)) (logand (aref array v) 255))))
+           (flet ((conc-word ()
+                    (loop for i from 0 below 16 by 4
+                          for (u v) in '((0 1) (2 3) (4 5) (6 7))
+                          do
+                          (load-word i u v))
+                    (setq cpuname (concatenate '(simple-array (unsigned-byte 8) (*)) cpuname temp))))
+
+             (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000002 array) (conc-word)
+             (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000003 array) (conc-word)
+             (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000004 array) (conc-word)
+             ))
+
+         ;; cut to null
+         (if (position 0 cpuname)
+             (setq cpuname (subseq cpuname 0 (position 0 cpuname))))
+         ;; coerce to string
+         (setq cpuname (map 'string #'code-char cpuname))
+         (setq *cpu-name* cpuname)))
+
+    ;; cache (AMD)
+    (setq *cpu-cache* nil)
+    (if (>= max-ext-func #x80000005)
+       (progn
+         (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000005 array)
+         (setq c (logior (ash (aref array 4) 16) (aref array 5))
+               d (logior (ash (aref array 6) 16) (aref array 7)))
+
+         (push (list :l1-data :size (* 1024 (ldb (byte 8 24) c))) *cpu-cache*)
+         (push (list :l1-inst :size (* 1024 (ldb (byte 8 24) d))) *cpu-cache*)))
+
+
+    (if (>= max-ext-func #x80000006)
+       (progn
+         (sb-sys:%primitive sb-vm::%read-cpu/x86 #x80000006 array)
+         (setq c (logior (ash (aref array 4) 16) (aref array 5)))
+         (push (list :l2 :size (* 1024 (ldb (byte 16 16) c))) *cpu-cache*)))
+
+    t))
+
+(defun dump-cpu ()
+
+    ;; dump
+
+    (format t "~&")
+    (format t "Vendor: ~A.~%" *cpu-vendor*)
+    (format t "Features: ~S.~%" *cpu-features*)
+    (format t "cpu: ~A, cache: ~S.~%" *cpu-name* *cpu-cache*)
+    )
diff --git a/example-test.lisp b/example-test.lisp
new file mode 100644 (file)
index 0000000..222f522
--- /dev/null
@@ -0,0 +1,23 @@
+(in-package :cl-user)
+
+(defun test-foo ()
+  (let ((arr1 (make-array 10 :element-type 'single-float :initial-element 0f0))
+       (arr2 (make-array 10 :element-type 'single-float :initial-element 0f0)))
+
+    (loop for i from 0 below 10 
+         do (setf 
+             (aref arr1 i) (float (* i 100)) 
+             (aref arr2 i) (float i)))
+
+    (format t "Before: ~S~%~S~%" arr1 arr2)
+
+    (sb-sys:%primitive sb-vm::%sse-sqrt/simple-array-single-float-1 arr2 arr1 4)
+
+    (format t "After: ~S~%~S~%" arr1 arr2)
+
+    (sb-sys:%primitive sb-vm::%sse-recip/simple-array-single-float-1 arr1 arr2 4)
+
+    (format t "After: ~S~%~S~%" arr1 arr2)
+
+    ))
+
diff --git a/generate-sse-instructions.lisp b/generate-sse-instructions.lisp
new file mode 100644 (file)
index 0000000..6717ebc
--- /dev/null
@@ -0,0 +1,79 @@
+#|
+
+instruction reference:
+
+http://www.amd.com/us-en/assets/content_type/white_papers_and_tech_docs/26568.pdf
+
+|#
+
+(declaim (optimize (debug 3)))
+
+(defun emit-ops (ops)
+  (loop for op in ops 
+       collect `(emit-byte segment ,op) into result
+       finally (return result)))
+
+
+(defun gen-ops (&optional (stream t))
+
+  ;; single prec packed sse
+  ;;; like :
+  ;;; ADDPS xmm1, xmm2/mem128 0F 58 /r
+  (loop for (inst . ops) in 
+       '(
+         ;; single precision float
+         (addps #x0F #x58)
+         (addsubps #xF2 #x0F #xD0)
+         (andnps #x0F #x55)
+         (andps #x0F #x54)
+         (divps #x0F #x5E)
+         (maxps #x0F #x5F)
+         (minps #x0F #x5D)
+         (mulps #x0F #x59)
+         (orps #x0F #x56)
+         (rcpps #x0F #x53)
+         (rsqrtps #x0F #x52)
+         (sqrtps #x0F #x51)
+         (subps #x0F #x5C)
+         (xorps #x0F #x57)
+         ;; double precision float
+         (addpd #x66 #x0F #x58)
+         (addsubpd #x66 #x0F #xD0)
+         (andnpd #x66 #x0F #x55)
+         (andpd #x66 #x0F #x54)
+         (divpd #x66 #x0F #x5E)
+         (maxpd #x66 #x0F #x5F)
+         (minpd #x66 #x0F #x5D)
+         (mulpd #x66 #x0F #x59)
+         (orps #x66 #x0F #x56)
+         (rcppd #x66 #x0F #x53)
+         (rsqrtpd #x66 #x0F #x52)
+         (sqrtpd #x66 #x0F #x51)
+         (subpd #x66 #x0F #x5C)
+         (xorpd #x66 #x0F #x57)
+         )
+       do
+       (format stream "~S~%~%"
+               `(define-instruction ,(intern (symbol-name inst)) (segment dst src)
+                 (:emitter
+                  ,@(emit-ops ops)
+                  (emit-ea segment src (reg-tn-encoding dst))))))
+
+  ;; MOVUPS
+  (loop for (inst ops-m2r ops-r2m) in
+       '(
+         (movups (#x0F #x10) (#x0F #x11))
+         (movupd (#x66 #x0F #x10) (#x66 #x0F #x11)))
+       do
+       (format stream "~S~%~%"
+               `(define-instruction ,(intern (symbol-name inst)) (segment dst src)
+                 (:emitter
+                  (cond ((sse-register-p dst)
+                         ,@(emit-ops ops-m2r)
+                         (emit-ea segment src (reg-tn-encoding dst)))
+                        (t ,@(emit-ops ops-r2m)
+                           (emit-ea segment dst (reg-tn-encoding src)))))))))
+
+(defun gen-ops-to-file (filename)
+  (with-open-file (stream filename :direction :output :if-exists :supersede)
+    (gen-ops stream)))
\ No newline at end of file
diff --git a/sbcl-src/makepatch.sh b/sbcl-src/makepatch.sh
new file mode 100755 (executable)
index 0000000..641b804
--- /dev/null
@@ -0,0 +1,4 @@
+#!/bin/sh
+find . -name '.emacs*' |xargs rm  2>/dev/null
+find . -name '*~' |xargs rm 2>/dev/null
+diff -Naur src-093 src > patch_against_sbcl_0_9_3
diff --git a/sbcl-src/patch_against_sbcl_0_9_3 b/sbcl-src/patch_against_sbcl_0_9_3
new file mode 100644 (file)
index 0000000..234ef9d
--- /dev/null
@@ -0,0 +1,229 @@
+diff -Naur src-093/compiler/x86/insts.lisp src/compiler/x86/insts.lisp
+--- src-093/compiler/x86/insts.lisp    2005-08-05 15:31:17.723664255 +0300
++++ src/compiler/x86/insts.lisp        2005-08-05 15:42:36.536109257 +0300
+@@ -192,6 +192,7 @@
+     (:byte 8)
+     (:word 16)
+     (:dword 32)
++    (:dqword 128)
+     (:float 32)
+     (:double 64)))
+@@ -671,7 +672,7 @@
+ (defun reg-tn-encoding (tn)
+   (declare (type tn tn))
+-  (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
++;  (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+   (let ((offset (tn-offset tn)))
+     (logior (ash (logand offset 1) 2)
+             (ash offset -1))))
+@@ -718,6 +719,8 @@
+      (ecase (sb-name (sc-sb (tn-sc thing)))
+        (registers
+         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
++       (sse-registers
++        (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+        (stack
+         ;; Convert stack tns into an index off of EBP.
+         (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+@@ -830,6 +833,10 @@
+   (and (tn-p thing)
+        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
++(defun sse-register-p (thing)
++  (and (tn-p thing)
++       (eq (sb-name (sc-sb (tn-sc thing))) 'sse-registers)))
++
+ (defun accumulator-p (thing)
+   (and (register-p thing)
+        (= (tn-offset thing) 0)))
+@@ -2042,6 +2049,123 @@
+   (:emitter
+    (emit-header-data segment return-pc-header-widetag)))
\f
++
++;;;; SSE instructions
++;;;; 
++;;;; Automatically generated
++
++
++(DEFINE-INSTRUCTION ADDPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 88)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION ADDSUBPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 242)
++                              (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 208)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION ANDNPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 85)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION ANDPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 84)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION DIVPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 94)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION MAXPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 95)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION MINPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 93)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION MULPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 89)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION ORPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 86)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION RCPPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 83)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION RSQRTPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 82)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION SQRTPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 81)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION SUBPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 92)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++(DEFINE-INSTRUCTION XORPS
++                    (SEGMENT DST SRC)
++                    (:EMITTER (EMIT-BYTE SEGMENT 15)
++                              (EMIT-BYTE SEGMENT 87)
++                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
++
++;;; SSE MOVE
++
++(DEFINE-INSTRUCTION MOVUPS (SEGMENT DST SRC)
++  (:EMITTER
++   (COND
++     ((SSE-REGISTER-P DST) 
++      (EMIT-BYTE SEGMENT 15)
++      (EMIT-BYTE SEGMENT 16)
++      (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST)))
++     (T (EMIT-BYTE SEGMENT 15)
++      (EMIT-BYTE SEGMENT 17)
++      (EMIT-EA SEGMENT DST (REG-TN-ENCODING SRC))))))
++
++
++;;; CPUID
++
++
++(define-instruction cpuid (segment)
++  (:emitter
++   (emit-byte segment #x0F)
++   (emit-byte segment #xA2)))
++
++    
++
++
++
+ ;;;; fp instructions
+ ;;;;
+ ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
+diff -Naur src-093/compiler/x86/vm.lisp src/compiler/x86/vm.lisp
+--- src-093/compiler/x86/vm.lisp       2005-08-05 15:32:19.810183044 +0300
++++ src/compiler/x86/vm.lisp   2005-08-05 15:38:26.784310770 +0300
+@@ -21,7 +21,8 @@
+   (defvar *byte-register-names* (make-array 8 :initial-element nil))
+   (defvar *word-register-names* (make-array 16 :initial-element nil))
+   (defvar *dword-register-names* (make-array 16 :initial-element nil))
+-  (defvar *float-register-names* (make-array 8 :initial-element nil)))
++  (defvar *float-register-names* (make-array 8 :initial-element nil))
++  (defvar *dqword-register-names* (make-array 8 :initial-element nil)))
+ (macrolet ((defreg (name offset size)
+              (let ((offset-sym (symbolicate name "-OFFSET"))
+@@ -91,6 +92,17 @@
+   (defreg fr7 7 :float)
+   (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
++  ;; sse registers
++  (defreg xmm0 0 :dqword)
++  (defreg xmm1 1 :dqword)
++  (defreg xmm2 2 :dqword)
++  (defreg xmm3 3 :dqword)
++  (defreg xmm4 4 :dqword)
++  (defreg xmm5 5 :dqword)
++  (defreg xmm6 6 :dqword)
++  (defreg xmm7 7 :dqword)
++  (defregset *sse-regs* xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7)
++  
+   ;; registers used to pass arguments
+   ;;
+   ;; the number of arguments/return values passed in registers
+@@ -118,6 +130,8 @@
+ ;;; the new way:
+ (define-storage-base float-registers :finite :size 8)
++(define-storage-base sse-registers :finite :size 8)
++
+ (define-storage-base stack :unbounded :size 8)
+ (define-storage-base constant :non-packed)
+ (define-storage-base immediate-constant :non-packed)
+@@ -320,6 +334,8 @@
+                     :save-p t
+                     :alternate-scs (complex-long-stack))
++  (sse-reg sse-registers
++         :locations #.*sse-regs*)
+   ;; a catch or unwind block
+   (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
+@@ -337,6 +353,7 @@
+ ;;; These are used to (at least) determine operand size.
+ (defparameter *float-sc-names* '(single-reg))
+ (defparameter *double-sc-names* '(double-reg double-stack))
++(defparameter *dqword-sc-names* '(sse-reg))
+ ) ; EVAL-WHEN
\f
+ ;;;; miscellaneous TNs for the various registers
+@@ -444,6 +461,7 @@
+              ;; FIXME: Shouldn't this be an ERROR?
+              (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
+       (float-registers (format nil "FR~D" offset))
++      (sse-registers (format nil "XMM~D" offset))
+       (stack (format nil "S~D" offset))
+       (constant (format nil "Const~D" offset))
+       (immediate-constant "Immed")
diff --git a/sbcl-src/src-093/compiler/x86/insts.lisp b/sbcl-src/src-093/compiler/x86/insts.lisp
new file mode 100644 (file)
index 0000000..9eed6f8
--- /dev/null
@@ -0,0 +1,2670 @@
+;;;; that part of the description of the x86 instruction set (for
+;;;; 80386 and above) which can live on the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
+;;; I wonder whether the separation of the disassembler from the
+;;; virtual machine is valid or adds value.
+
+;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
+(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
+
+(deftype reg () '(unsigned-byte 3))
+
+(def!constant +default-operand-size+ :dword)
+\f
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+
+(defun offset-next (value dstate)
+  (declare (type integer value)
+           (type sb!disassem:disassem-state dstate))
+  (+ (sb!disassem:dstate-next-addr dstate) value))
+
+(defparameter *default-address-size*
+  ;; Actually, :DWORD is the only one really supported.
+  :dword)
+
+(defparameter *byte-reg-names*
+  #(al cl dl bl ah ch dh bh))
+(defparameter *word-reg-names*
+  #(ax cx dx bx sp bp si di))
+(defparameter *dword-reg-names*
+  #(eax ecx edx ebx esp ebp esi edi))
+
+(defun print-reg-with-width (value width stream dstate)
+  (declare (ignore dstate))
+  (princ (aref (ecase width
+                 (:byte *byte-reg-names*)
+                 (:word *word-reg-names*)
+                 (:dword *dword-reg-names*))
+               value)
+         stream)
+  ;; XXX plus should do some source-var notes
+  )
+
+(defun print-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value
+                        (sb!disassem:dstate-get-prop dstate 'width)
+                        stream
+                        dstate))
+
+(defun print-word-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value
+                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                            +default-operand-size+)
+                        stream
+                        dstate))
+
+(defun print-byte-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value :byte stream dstate))
+
+(defun print-addr-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value *default-address-size* stream dstate))
+
+(defun print-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream nil dstate)))
+
+;; Same as print-reg/mem, but prints an explicit size indicator for
+;; memory references.
+(defun print-sized-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-byte-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-byte-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-word-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-word-reg value stream dstate)
+      (print-mem-access value stream nil dstate)))
+
+(defun print-label (value stream dstate)
+  (declare (ignore dstate))
+  (sb!disassem:princ16 value stream))
+
+;;; Returns either an integer, meaning a register, or a list of
+;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
+;;; may be missing or nil to indicate that it's not used or has the
+;;; obvious default value (e.g., 1 for the index-scale).
+(defun prefilter-reg/mem (value dstate)
+  (declare (type list value)
+           (type sb!disassem:disassem-state dstate))
+  (let ((mod (car value))
+        (r/m (cadr value)))
+    (declare (type (unsigned-byte 2) mod)
+             (type (unsigned-byte 3) r/m))
+    (cond ((= mod #b11)
+           ;; registers
+           r/m)
+          ((= r/m #b100)
+           ;; sib byte
+           (let ((sib (sb!disassem:read-suffix 8 dstate)))
+             (declare (type (unsigned-byte 8) sib))
+             (let ((base-reg (ldb (byte 3 0) sib))
+                   (index-reg (ldb (byte 3 3) sib))
+                   (index-scale (ldb (byte 2 6) sib)))
+               (declare (type (unsigned-byte 3) base-reg index-reg)
+                        (type (unsigned-byte 2) index-scale))
+               (let* ((offset
+                       (case mod
+                         (#b00
+                          (if (= base-reg #b101)
+                              (sb!disassem:read-signed-suffix 32 dstate)
+                              nil))
+                         (#b01
+                          (sb!disassem:read-signed-suffix 8 dstate))
+                         (#b10
+                          (sb!disassem:read-signed-suffix 32 dstate)))))
+                 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+                       offset
+                       (if (= index-reg #b100) nil index-reg)
+                       (ash 1 index-scale))))))
+          ((and (= mod #b00) (= r/m #b101))
+           (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
+          ((= mod #b00)
+           (list r/m))
+          ((= mod #b01)
+           (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
+          (t                            ; (= mod #b10)
+           (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
+
+
+;;; This is a sort of bogus prefilter that just stores the info globally for
+;;; other people to use; it probably never gets printed.
+(defun prefilter-width (value dstate)
+  (setf (sb!disassem:dstate-get-prop dstate 'width)
+        (if (zerop value)
+            :byte
+            (let ((word-width
+                   ;; set by a prefix instruction
+                   (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                       +default-operand-size+)))
+              (when (not (eql word-width +default-operand-size+))
+                ;; Reset it.
+                (setf (sb!disassem:dstate-get-prop dstate 'word-width)
+                      +default-operand-size+))
+              word-width))))
+
+(defun read-address (value dstate)
+  (declare (ignore value))              ; always nil anyway
+  (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
+
+(defun width-bits (width)
+  (ecase width
+    (:byte 8)
+    (:word 16)
+    (:dword 32)
+    (:float 32)
+    (:double 64)))
+
+) ; EVAL-WHEN
+\f
+;;;; disassembler argument types
+
+(sb!disassem:define-arg-type displacement
+  :sign-extend t
+  :use-label #'offset-next
+  :printer (lambda (value stream dstate)
+             (sb!disassem:maybe-note-assembler-routine value nil dstate)
+             (print-label value stream dstate)))
+
+(sb!disassem:define-arg-type accum
+  :printer (lambda (value stream dstate)
+             (declare (ignore value)
+                      (type stream stream)
+                      (type sb!disassem:disassem-state dstate))
+             (print-reg 0 stream dstate)))
+
+(sb!disassem:define-arg-type word-accum
+  :printer (lambda (value stream dstate)
+             (declare (ignore value)
+                      (type stream stream)
+                      (type sb!disassem:disassem-state dstate))
+             (print-word-reg 0 stream dstate)))
+
+(sb!disassem:define-arg-type reg
+  :printer #'print-reg)
+
+(sb!disassem:define-arg-type addr-reg
+  :printer #'print-addr-reg)
+
+(sb!disassem:define-arg-type word-reg
+  :printer #'print-word-reg)
+
+(sb!disassem:define-arg-type imm-addr
+  :prefilter #'read-address
+  :printer #'print-label)
+
+(sb!disassem:define-arg-type imm-data
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-suffix
+                (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+                dstate)))
+
+(sb!disassem:define-arg-type signed-imm-data
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+
+(sb!disassem:define-arg-type signed-imm-byte
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-signed-suffix 8 dstate)))
+
+(sb!disassem:define-arg-type signed-imm-dword
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-signed-suffix 32 dstate)))
+
+(sb!disassem:define-arg-type imm-word
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width
+                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                          +default-operand-size+)))
+                 (sb!disassem:read-suffix (width-bits width) dstate))))
+
+(sb!disassem:define-arg-type signed-imm-word
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width
+                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                          +default-operand-size+)))
+                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+
+;;; needed for the ret imm16 instruction
+(sb!disassem:define-arg-type imm-word-16
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-suffix 16 dstate)))
+
+(sb!disassem:define-arg-type reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-reg/mem)
+(sb!disassem:define-arg-type sized-reg/mem
+  ;; Same as reg/mem, but prints an explicit size indicator for
+  ;; memory references.
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-sized-reg/mem)
+(sb!disassem:define-arg-type byte-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-byte-reg/mem)
+(sb!disassem:define-arg-type word-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-word-reg/mem)
+
+;;; added by jrd
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+(defun print-fp-reg (value stream dstate)
+  (declare (ignore dstate))
+  (format stream "FR~D" value))
+(defun prefilter-fp-reg (value dstate)
+  ;; just return it
+  (declare (ignore dstate))
+  value)
+) ; EVAL-WHEN
+(sb!disassem:define-arg-type fp-reg
+                             :prefilter #'prefilter-fp-reg
+                             :printer #'print-fp-reg)
+
+(sb!disassem:define-arg-type width
+  :prefilter #'prefilter-width
+  :printer (lambda (value stream dstate)
+             (if;; (zerop value)
+                 (or (null value)
+                     (and (numberp value) (zerop value))) ; zzz jrd
+                 (princ 'b stream)
+                 (let ((word-width
+                        ;; set by a prefix instruction
+                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                            +default-operand-size+)))
+                   (princ (schar (symbol-name word-width) 0) stream)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *conditions*
+  '((:o . 0)
+    (:no . 1)
+    (:b . 2) (:nae . 2) (:c . 2)
+    (:nb . 3) (:ae . 3) (:nc . 3)
+    (:eq . 4) (:e . 4) (:z . 4)
+    (:ne . 5) (:nz . 5)
+    (:be . 6) (:na . 6)
+    (:nbe . 7) (:a . 7)
+    (:s . 8)
+    (:ns . 9)
+    (:p . 10) (:pe . 10)
+    (:np . 11) (:po . 11)
+    (:l . 12) (:nge . 12)
+    (:nl . 13) (:ge . 13)
+    (:le . 14) (:ng . 14)
+    (:nle . 15) (:g . 15)))
+(defparameter *condition-name-vec*
+  (let ((vec (make-array 16 :initial-element nil)))
+    (dolist (cond *conditions*)
+      (when (null (aref vec (cdr cond)))
+        (setf (aref vec (cdr cond)) (car cond))))
+    vec))
+) ; EVAL-WHEN
+
+;;; Set assembler parameters. (In CMU CL, this was done with
+;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf sb!assem:*assem-scheduler-p* nil))
+
+(sb!disassem:define-arg-type condition-code
+  :printer *condition-name-vec*)
+
+(defun conditional-opcode (condition)
+  (cdr (assoc condition *conditions* :test #'eq)))
+\f
+;;;; disassembler instruction formats
+
+(eval-when (:compile-toplevel :execute)
+  (defun swap-if (direction field1 separator field2)
+    `(:if (,direction :constant 0)
+          (,field1 ,separator ,field2)
+          (,field2 ,separator ,field1))))
+
+(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
+  (op    :field (byte 8 0))
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+(sb!disassem:define-instruction-format (simple 8)
+  (op    :field (byte 7 1))
+  (width :field (byte 1 0) :type 'width)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+;;; Same as simple, but with direction bit
+(sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
+  (op :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as simple, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (accum-imm 8
+                                     :include 'simple
+                                     :default-printer '(:name
+                                                        :tab accum ", " imm))
+  (imm :type 'imm-data))
+
+(sb!disassem:define-instruction-format (reg-no-width 8
+                                     :default-printer '(:name :tab reg))
+  (op    :field (byte 5 3))
+  (reg   :field (byte 3 0) :type 'word-reg)
+  ;; optional fields
+  (accum :type 'word-accum)
+  (imm))
+
+;;; adds a width field to reg-no-width
+(sb!disassem:define-instruction-format (reg 8
+                                        :default-printer '(:name :tab reg))
+  (op    :field (byte 4 4))
+  (width :field (byte 1 3) :type 'width)
+  (reg   :field (byte 3 0) :type 'reg)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm)
+  )
+
+;;; Same as reg, but with direction bit
+(sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
+  (op  :field (byte 3 5))
+  (dir :field (byte 1 4)))
+
+(sb!disassem:define-instruction-format (two-bytes 16
+                                        :default-printer '(:name))
+  (op :fields (list (byte 8 0) (byte 8 8))))
+
+(sb!disassem:define-instruction-format (reg-reg/mem 16
+                                        :default-printer
+                                        `(:name :tab reg ", " reg/mem))
+  (op      :field (byte 7 1))
+  (width   :field (byte 1 0)    :type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 11)   :type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; same as reg-reg/mem, but with direction bit
+(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
+                                        :include 'reg-reg/mem
+                                        :default-printer
+                                        `(:name
+                                          :tab
+                                          ,(swap-if 'dir 'reg/mem ", " 'reg)))
+  (op  :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as reg-rem/mem, but uses the reg field as a second op code.
+(sb!disassem:define-instruction-format (reg/mem 16
+                                        :default-printer '(:name :tab reg/mem))
+  (op      :fields (list (byte 7 1) (byte 3 11)))
+  (width   :field (byte 1 0)    :type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+                                :type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (reg/mem-imm 16
+                                        :include 'reg/mem
+                                        :default-printer
+                                        '(:name :tab reg/mem ", " imm))
+  (reg/mem :type 'sized-reg/mem)
+  (imm     :type 'imm-data))
+
+;;; Same as reg/mem, but with using the accumulator in the default printer
+(sb!disassem:define-instruction-format
+    (accum-reg/mem 16
+     :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
+  (reg/mem :type 'reg/mem)              ; don't need a size
+  (accum :type 'accum))
+
+;;; Same as reg-reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
+                                        :default-printer
+                                        `(:name :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :field (byte 7 9))
+  (width   :field (byte 1 8)    :type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 19)   :type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg/mem 24
+                                        :default-printer '(:name :tab reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :fields (list (byte 7 9) (byte 3 19)))
+  (width   :field (byte 1 8)    :type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+(sb!disassem:define-instruction-format (ext-reg/mem-imm 24
+                                        :include 'ext-reg/mem
+                                        :default-printer
+                                        '(:name :tab reg/mem ", " imm))
+  (imm :type 'imm-data))
+\f
+;;;; This section was added by jrd, for fp instructions.
+
+;;; regular fp inst to/from registers/memory
+(sb!disassem:define-instruction-format (floating-point 16
+                                        :default-printer
+                                        `(:name :tab reg/mem))
+  (prefix :field (byte 5 3) :value #b11011)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
+
+;;; fp insn to/from fp reg
+(sb!disassem:define-instruction-format (floating-point-fp 16
+                                        :default-printer `(:name :tab fp-reg))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+;;; fp insn to/from fp reg, with the reversed source/destination flag.
+(sb!disassem:define-instruction-format
+ (floating-point-fp-d 16
+   :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 2 0) (byte 3 11)))
+  (d      :field (byte 1 2))
+  (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+
+;;; (added by (?) pfw)
+;;; fp no operand isns
+(sb!disassem:define-instruction-format (floating-point-no 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011001)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (floating-point-3 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 3 0) (byte 6 8))))
+
+(sb!disassem:define-instruction-format (floating-point-5 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011011)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (floating-point-st 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011111)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (string-op 8
+                                     :include 'simple
+                                     :default-printer '(:name width)))
+
+(sb!disassem:define-instruction-format (short-cond-jump 16)
+  (op    :field (byte 4 4))
+  (cc    :field (byte 4 0) :type 'condition-code)
+  (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (short-jump 16
+                                     :default-printer '(:name :tab label))
+  (const :field (byte 4 4) :value #b1110)
+  (op    :field (byte 4 0))
+  (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (near-cond-jump 16)
+  (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
+  (cc    :field (byte 4 8) :type 'condition-code)
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the offset.
+  (label :type 'displacement
+         :prefilter (lambda (value dstate)
+                      (declare (ignore value)) ; always nil anyway
+                      (sb!disassem:read-signed-suffix 32 dstate))))
+
+(sb!disassem:define-instruction-format (near-jump 8
+                                     :default-printer '(:name :tab label))
+  (op    :field (byte 8 0))
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the address.
+  (label :type 'displacement
+         :prefilter (lambda (value dstate)
+                      (declare (ignore value)) ; always nil anyway
+                      (sb!disassem:read-signed-suffix 32 dstate))))
+
+
+(sb!disassem:define-instruction-format (cond-set 24
+                                     :default-printer '('set cc :tab reg/mem))
+  (prefix :field (byte 8 0) :value #b00001111)
+  (op    :field (byte 4 12) :value #b1001)
+  (cc    :field (byte 4 8) :type 'condition-code)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+           :type 'byte-reg/mem)
+  (reg     :field (byte 3 19)   :value #b000))
+
+(sb!disassem:define-instruction-format (cond-move 24
+                                     :default-printer
+                                        '('cmov cc :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :field (byte 4 12)   :value #b0100)
+  (cc      :field (byte 4 8)    :type 'condition-code)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 19)   :type 'reg))
+
+(sb!disassem:define-instruction-format (enter-format 32
+                                     :default-printer '(:name
+                                                        :tab disp
+                                                        (:unless (:constant 0)
+                                                          ", " level)))
+  (op :field (byte 8 0))
+  (disp :field (byte 16 8))
+  (level :field (byte 8 24)))
+
+(sb!disassem:define-instruction-format (prefetch 24
+                                                 :default-printer
+                                                 '(:name ", " reg/mem))
+  (prefix :field (byte 8 0) :value #b00001111)
+  (op :field (byte 8 8) :value #b00011000)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
+  (reg :field (byte 3 19) :type 'reg))
+
+;;; Single byte instruction with an immediate byte argument.
+(sb!disassem:define-instruction-format (byte-imm 16
+                                     :default-printer '(:name :tab code))
+ (op :field (byte 8 0))
+ (code :field (byte 8 8)))
+\f
+;;;; primitive emitters
+
+(define-bitfield-emitter emit-word 16
+  (byte 16 0))
+
+(define-bitfield-emitter emit-dword 32
+  (byte 32 0))
+
+(define-bitfield-emitter emit-byte-with-reg 8
+  (byte 5 3) (byte 3 0))
+
+(define-bitfield-emitter emit-mod-reg-r/m-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+(define-bitfield-emitter emit-sib-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+\f
+;;;; fixup emitters
+
+(defun emit-absolute-fixup (segment fixup)
+  (note-fixup segment :absolute fixup)
+  (let ((offset (fixup-offset fixup)))
+    (if (label-p offset)
+        (emit-back-patch segment
+                         4 ; FIXME: n-word-bytes
+                         (lambda (segment posn)
+                           (declare (ignore posn))
+                           (emit-dword segment
+                                       (- (+ (component-header-length)
+                                             (or (label-position offset)
+                                                 0))
+                                          other-pointer-lowtag))))
+        (emit-dword segment (or offset 0)))))
+
+(defun emit-relative-fixup (segment fixup)
+  (note-fixup segment :relative fixup)
+  (emit-dword segment (or (fixup-offset fixup) 0)))
+\f
+;;;; the effective-address (ea) structure
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+  (let ((offset (tn-offset tn)))
+    (logior (ash (logand offset 1) 2)
+            (ash offset -1))))
+
+(defstruct (ea (:constructor make-ea (size &key base index scale disp))
+               (:copier nil))
+  (size nil :type (member :byte :word :dword))
+  (base nil :type (or tn null))
+  (index nil :type (or tn null))
+  (scale 1 :type (member 1 2 4 8))
+  (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
+(def!method print-object ((ea ea) stream)
+  (cond ((or *print-escape* *print-readably*)
+         (print-unreadable-object (ea stream :type t)
+           (format stream
+                   "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+                   (ea-size ea)
+                   (ea-base ea)
+                   (ea-index ea)
+                   (let ((scale (ea-scale ea)))
+                     (if (= scale 1) nil scale))
+                   (ea-disp ea))))
+        (t
+         (format stream "~A PTR [" (symbol-name (ea-size ea)))
+         (when (ea-base ea)
+           (write-string (sb!c::location-print-name (ea-base ea)) stream)
+           (when (ea-index ea)
+             (write-string "+" stream)))
+         (when (ea-index ea)
+           (write-string (sb!c::location-print-name (ea-index ea)) stream))
+         (unless (= (ea-scale ea) 1)
+           (format stream "*~A" (ea-scale ea)))
+         (typecase (ea-disp ea)
+           (null)
+           (integer
+            (format stream "~@D" (ea-disp ea)))
+           (t
+            (format stream "+~A" (ea-disp ea))))
+         (write-char #\] stream))))
+
+(defun emit-ea (segment thing reg &optional allow-constants)
+  (etypecase thing
+    (tn
+     (ecase (sb-name (sc-sb (tn-sc thing)))
+       (registers
+        (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+       (stack
+        ;; Convert stack tns into an index off of EBP.
+        (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+          (cond ((< -128 disp 127)
+                 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+                 (emit-byte segment disp))
+                (t
+                 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+                 (emit-dword segment disp)))))
+       (constant
+        (unless allow-constants
+          (error
+           "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+        (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+        (emit-absolute-fixup segment
+                             (make-fixup nil
+                                         :code-object
+                                         (- (* (tn-offset thing) n-word-bytes)
+                                            other-pointer-lowtag))))))
+    (ea
+     (let* ((base (ea-base thing))
+            (index (ea-index thing))
+            (scale (ea-scale thing))
+            (disp (ea-disp thing))
+            (mod (cond ((or (null base)
+                            (and (eql disp 0)
+                                 (not (= (reg-tn-encoding base) #b101))))
+                        #b00)
+                       ((and (fixnump disp) (<= -128 disp 127))
+                        #b01)
+                       (t
+                        #b10)))
+            (r/m (cond (index #b100)
+                       ((null base) #b101)
+                       (t (reg-tn-encoding base)))))
+       (emit-mod-reg-r/m-byte segment mod reg r/m)
+       (when (= r/m #b100)
+         (let ((ss (1- (integer-length scale)))
+               (index (if (null index)
+                          #b100
+                          (let ((index (reg-tn-encoding index)))
+                            (if (= index #b100)
+                                (error "can't index off of ESP")
+                                index))))
+               (base (if (null base)
+                         #b101
+                         (reg-tn-encoding base))))
+           (emit-sib-byte segment ss index base)))
+       (cond ((= mod #b01)
+              (emit-byte segment disp))
+             ((or (= mod #b10) (null base))
+              (if (fixup-p disp)
+                  (emit-absolute-fixup segment disp)
+                  (emit-dword segment disp))))))
+    (fixup
+     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+     (emit-absolute-fixup segment thing))))
+
+(defun fp-reg-tn-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
+;;; like the above, but for fp-instructions--jrd
+(defun emit-fp-op (segment thing op)
+  (if (fp-reg-tn-p thing)
+      (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
+                                                 (byte 3 0)
+                                                 #b11000000)))
+    (emit-ea segment thing op)))
+
+(defun byte-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *byte-sc-names*)
+       t))
+
+(defun byte-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :byte))
+    (tn
+     (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
+    (t nil)))
+
+(defun word-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *word-sc-names*)
+       t))
+
+(defun word-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :word))
+    (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
+    (t nil)))
+
+(defun dword-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *dword-sc-names*)
+       t))
+
+(defun dword-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :dword))
+    (tn
+     (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
+    (t nil)))
+
+(defun register-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
+
+(defun accumulator-p (thing)
+  (and (register-p thing)
+       (= (tn-offset thing) 0)))
+\f
+;;;; utilities
+
+(def!constant +operand-size-prefix-byte+ #b01100110)
+
+(defun maybe-emit-operand-size-prefix (segment size)
+  (unless (or (eq size :byte) (eq size +default-operand-size+))
+    (emit-byte segment +operand-size-prefix-byte+)))
+
+(defun operand-size (thing)
+  (typecase thing
+    (tn
+     ;; FIXME: might as well be COND instead of having to use #. readmacro
+     ;; to hack up the code
+     (case (sc-name (tn-sc thing))
+       (#.*dword-sc-names*
+        :dword)
+       (#.*word-sc-names*
+        :word)
+       (#.*byte-sc-names*
+        :byte)
+       ;; added by jrd: float-registers is a separate size (?)
+       (#.*float-sc-names*
+        :float)
+       (#.*double-sc-names*
+        :double)
+       (t
+        (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+    (ea
+     (ea-size thing))
+    (t
+     nil)))
+
+(defun matching-operand-size (dst src)
+  (let ((dst-size (operand-size dst))
+        (src-size (operand-size src)))
+    (if dst-size
+        (if src-size
+            (if (eq dst-size src-size)
+                dst-size
+                (error "size mismatch: ~S is a ~S and ~S is a ~S."
+                       dst dst-size src src-size))
+            dst-size)
+        (if src-size
+            src-size
+            (error "can't tell the size of either ~S or ~S" dst src)))))
+
+(defun emit-sized-immediate (segment size value)
+  (ecase size
+    (:byte
+     (emit-byte segment value))
+    (:word
+     (emit-word segment value))
+    (:dword
+     (emit-dword segment value))))
+\f
+;;;; general data transfer
+
+(define-instruction mov (segment dst src)
+  ;; immediate to register
+  (:printer reg ((op #b1011) (imm nil :type 'imm-data))
+            '(:name :tab reg ", " imm))
+  ;; absolute mem to/from accumulator
+  (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
+            `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+  ;; register to/from register/memory
+  (:printer reg-reg/mem-dir ((op #b100010)))
+  ;; immediate to register/memory
+  (:printer reg/mem-imm ((op '(#b1100011 #b000))))
+
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+            (cond ((integerp src)
+                   (emit-byte-with-reg segment
+                                       (if (eq size :byte)
+                                           #b10110
+                                           #b10111)
+                                       (reg-tn-encoding dst))
+                   (emit-sized-immediate segment size src))
+                  ((and (fixup-p src) (accumulator-p dst))
+                   (emit-byte segment
+                              (if (eq size :byte)
+                                  #b10100000
+                                  #b10100001))
+                   (emit-absolute-fixup segment src))
+                  (t
+                   (emit-byte segment
+                              (if (eq size :byte)
+                                  #b10001010
+                                  #b10001011))
+                   (emit-ea segment src (reg-tn-encoding dst) t))))
+           ((and (fixup-p dst) (accumulator-p src))
+            (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
+            (emit-absolute-fixup segment dst))
+           ((integerp src)
+            (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+            (emit-ea segment dst #b000)
+            (emit-sized-immediate segment size src))
+           ((register-p src)
+            (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+            (emit-ea segment dst (reg-tn-encoding src)))
+           ((fixup-p src)
+            (aver (eq size :dword))
+            (emit-byte segment #b11000111)
+            (emit-ea segment dst #b000)
+            (emit-absolute-fixup segment src))
+           (t
+            (error "bogus arguments to MOV: ~S ~S" dst src))))))
+
+(defun emit-move-with-extension (segment dst src opcode)
+  (aver (register-p dst))
+  (let ((dst-size (operand-size dst))
+        (src-size (operand-size src)))
+    (ecase dst-size
+      (:word
+       (aver (eq src-size :byte))
+       (maybe-emit-operand-size-prefix segment :word)
+       (emit-byte segment #b00001111)
+       (emit-byte segment opcode)
+       (emit-ea segment src (reg-tn-encoding dst)))
+      (:dword
+       (ecase src-size
+         (:byte
+          (maybe-emit-operand-size-prefix segment :dword)
+          (emit-byte segment #b00001111)
+          (emit-byte segment opcode)
+          (emit-ea segment src (reg-tn-encoding dst)))
+         (:word
+          (emit-byte segment #b00001111)
+          (emit-byte segment (logior opcode 1))
+          (emit-ea segment src (reg-tn-encoding dst))))))))
+
+(define-instruction movsx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
+  (:emitter (emit-move-with-extension segment dst src #b10111110)))
+
+(define-instruction movzx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
+  (:emitter (emit-move-with-extension segment dst src #b10110110)))
+
+(define-instruction push (segment src)
+  ;; register
+  (:printer reg-no-width ((op #b01010)))
+  ;; register/memory
+  (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
+  ;; immediate
+  (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
+            '(:name :tab imm))
+  (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
+            '(:name :tab imm))
+  ;; ### segment registers?
+
+  (:emitter
+   (cond ((integerp src)
+          (cond ((<= -128 src 127)
+                 (emit-byte segment #b01101010)
+                 (emit-byte segment src))
+                (t
+                 (emit-byte segment #b01101000)
+                 (emit-dword segment src))))
+         ((fixup-p src)
+          ;; Interpret the fixup as an immediate dword to push.
+          (emit-byte segment #b01101000)
+          (emit-absolute-fixup segment src))
+         (t
+          (let ((size (operand-size src)))
+            (aver (not (eq size :byte)))
+            (maybe-emit-operand-size-prefix segment size)
+            (cond ((register-p src)
+                   (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+                  (t
+                   (emit-byte segment #b11111111)
+                   (emit-ea segment src #b110 t))))))))
+
+(define-instruction pusha (segment)
+  (:printer byte ((op #b01100000)))
+  (:emitter
+   (emit-byte segment #b01100000)))
+
+(define-instruction pop (segment dst)
+  (:printer reg-no-width ((op #b01011)))
+  (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (aver (not (eq size :byte)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+            (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment #b10001111)
+            (emit-ea segment dst #b000))))))
+
+(define-instruction popa (segment)
+  (:printer byte ((op #b01100001)))
+  (:emitter
+   (emit-byte segment #b01100001)))
+
+(define-instruction xchg (segment operand1 operand2)
+  ;; Register with accumulator.
+  (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
+  ;; Register/Memory with Register.
+  (:printer reg-reg/mem ((op #b1000011)))
+  (:emitter
+   (let ((size (matching-operand-size operand1 operand2)))
+     (maybe-emit-operand-size-prefix segment size)
+     (labels ((xchg-acc-with-something (acc something)
+                (if (and (not (eq size :byte)) (register-p something))
+                    (emit-byte-with-reg segment
+                                        #b10010
+                                        (reg-tn-encoding something))
+                    (xchg-reg-with-something acc something)))
+              (xchg-reg-with-something (reg something)
+                (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+                (emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((accumulator-p operand1)
+              (xchg-acc-with-something operand1 operand2))
+             ((accumulator-p operand2)
+              (xchg-acc-with-something operand2 operand1))
+             ((register-p operand1)
+              (xchg-reg-with-something operand1 operand2))
+             ((register-p operand2)
+              (xchg-reg-with-something operand2 operand1))
+             (t
+              (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+
+(define-instruction lea (segment dst src)
+  (:printer reg-reg/mem ((op #b1000110) (width 1)))
+  (:emitter
+   (aver (dword-reg-p dst))
+   (emit-byte segment #b10001101)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cmpxchg (segment dst src)
+  ;; Register/Memory with Register.
+  (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
+  (:emitter
+   (aver (register-p src))
+   (let ((size (matching-operand-size src dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
+     (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+
+(define-instruction fs-segment-prefix (segment)
+  (:emitter
+   (emit-byte segment #x64)))
+
+;;;; flag control instructions
+
+;;; CLC -- Clear Carry Flag.
+(define-instruction clc (segment)
+  (:printer byte ((op #b11111000)))
+  (:emitter
+   (emit-byte segment #b11111000)))
+
+;;; CLD -- Clear Direction Flag.
+(define-instruction cld (segment)
+  (:printer byte ((op #b11111100)))
+  (:emitter
+   (emit-byte segment #b11111100)))
+
+;;; CLI -- Clear Iterrupt Enable Flag.
+(define-instruction cli (segment)
+  (:printer byte ((op #b11111010)))
+  (:emitter
+   (emit-byte segment #b11111010)))
+
+;;; CMC -- Complement Carry Flag.
+(define-instruction cmc (segment)
+  (:printer byte ((op #b11110101)))
+  (:emitter
+   (emit-byte segment #b11110101)))
+
+;;; LAHF -- Load AH into flags.
+(define-instruction lahf (segment)
+  (:printer byte ((op #b10011111)))
+  (:emitter
+   (emit-byte segment #b10011111)))
+
+;;; POPF -- Pop flags.
+(define-instruction popf (segment)
+  (:printer byte ((op #b10011101)))
+  (:emitter
+   (emit-byte segment #b10011101)))
+
+;;; PUSHF -- push flags.
+(define-instruction pushf (segment)
+  (:printer byte ((op #b10011100)))
+  (:emitter
+   (emit-byte segment #b10011100)))
+
+;;; SAHF -- Store AH into flags.
+(define-instruction sahf (segment)
+  (:printer byte ((op #b10011110)))
+  (:emitter
+   (emit-byte segment #b10011110)))
+
+;;; STC -- Set Carry Flag.
+(define-instruction stc (segment)
+  (:printer byte ((op #b11111001)))
+  (:emitter
+   (emit-byte segment #b11111001)))
+
+;;; STD -- Set Direction Flag.
+(define-instruction std (segment)
+  (:printer byte ((op #b11111101)))
+  (:emitter
+   (emit-byte segment #b11111101)))
+
+;;; STI -- Set Interrupt Enable Flag.
+(define-instruction sti (segment)
+  (:printer byte ((op #b11111011)))
+  (:emitter
+   (emit-byte segment #b11111011)))
+\f
+;;;; arithmetic
+
+(defun emit-random-arith-inst (name segment dst src opcode
+                                    &optional allow-constants)
+  (let ((size (matching-operand-size dst src)))
+    (maybe-emit-operand-size-prefix segment size)
+    (cond
+     ((integerp src)
+      (cond ((and (not (eq size :byte)) (<= -128 src 127))
+             (emit-byte segment #b10000011)
+             (emit-ea segment dst opcode allow-constants)
+             (emit-byte segment src))
+            ((accumulator-p dst)
+             (emit-byte segment
+                        (dpb opcode
+                             (byte 3 3)
+                             (if (eq size :byte)
+                                 #b00000100
+                                 #b00000101)))
+             (emit-sized-immediate segment size src))
+            (t
+             (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+             (emit-ea segment dst opcode allow-constants)
+             (emit-sized-immediate segment size src))))
+     ((register-p src)
+      (emit-byte segment
+                 (dpb opcode
+                      (byte 3 3)
+                      (if (eq size :byte) #b00000000 #b00000001)))
+      (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+     ((register-p dst)
+      (emit-byte segment
+                 (dpb opcode
+                      (byte 3 3)
+                      (if (eq size :byte) #b00000010 #b00000011)))
+      (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+     (t
+      (error "bogus operands to ~A" name)))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun arith-inst-printer-list (subop)
+    `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
+      (reg/mem-imm ((op (#b1000000 ,subop))))
+      (reg/mem-imm ((op (#b1000001 ,subop))
+                    (imm nil :type signed-imm-byte)))
+      (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
+  )
+
+(define-instruction add (segment dst src)
+  (:printer-list (arith-inst-printer-list #b000))
+  (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+
+(define-instruction adc (segment dst src)
+  (:printer-list (arith-inst-printer-list #b010))
+  (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
+
+(define-instruction sub (segment dst src)
+  (:printer-list (arith-inst-printer-list #b101))
+  (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
+
+(define-instruction sbb (segment dst src)
+  (:printer-list (arith-inst-printer-list #b011))
+  (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
+
+(define-instruction cmp (segment dst src)
+  (:printer-list (arith-inst-printer-list #b111))
+  (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+
+(define-instruction inc (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01000)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b000))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+            (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+            (emit-ea segment dst #b000))))))
+
+(define-instruction dec (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01001)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b001))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+            (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+            (emit-ea segment dst #b001))))))
+
+(define-instruction neg (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b011))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b011))))
+
+(define-instruction aaa (segment)
+  (:printer byte ((op #b00110111)))
+  (:emitter
+   (emit-byte segment #b00110111)))
+
+(define-instruction aas (segment)
+  (:printer byte ((op #b00111111)))
+  (:emitter
+   (emit-byte segment #b00111111)))
+
+(define-instruction daa (segment)
+  (:printer byte ((op #b00100111)))
+  (:emitter
+   (emit-byte segment #b00100111)))
+
+(define-instruction das (segment)
+  (:printer byte ((op #b00101111)))
+  (:emitter
+   (emit-byte segment #b00101111)))
+
+(define-instruction mul (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b100))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b100))))
+
+(define-instruction imul (segment dst &optional src1 src2)
+  (:printer accum-reg/mem ((op '(#b1111011 #b101))))
+  (:printer ext-reg-reg/mem ((op #b1010111)))
+  (:printer reg-reg/mem ((op #b0110100) (width 1)
+                         (imm nil :type 'signed-imm-word))
+            '(:name :tab reg ", " reg/mem ", " imm))
+  (:printer reg-reg/mem ((op #b0110101) (width 1)
+                         (imm nil :type 'signed-imm-byte))
+            '(:name :tab reg ", " reg/mem ", " imm))
+  (:emitter
+   (flet ((r/m-with-immed-to-reg (reg r/m immed)
+            (let* ((size (matching-operand-size reg r/m))
+                   (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+              (maybe-emit-operand-size-prefix segment size)
+              (emit-byte segment (if sx #b01101011 #b01101001))
+              (emit-ea segment r/m (reg-tn-encoding reg))
+              (if sx
+                  (emit-byte segment immed)
+                  (emit-sized-immediate segment size immed)))))
+     (cond (src2
+            (r/m-with-immed-to-reg dst src1 src2))
+           (src1
+            (if (integerp src1)
+                (r/m-with-immed-to-reg dst dst src1)
+                (let ((size (matching-operand-size dst src1)))
+                  (maybe-emit-operand-size-prefix segment size)
+                  (emit-byte segment #b00001111)
+                  (emit-byte segment #b10101111)
+                  (emit-ea segment src1 (reg-tn-encoding dst)))))
+           (t
+            (let ((size (operand-size dst)))
+              (maybe-emit-operand-size-prefix segment size)
+              (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+              (emit-ea segment dst #b101)))))))
+
+(define-instruction div (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b110))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b110))))
+
+(define-instruction idiv (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b111))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b111))))
+
+(define-instruction aad (segment)
+  (:printer two-bytes ((op '(#b11010101 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010101)
+   (emit-byte segment #b00001010)))
+
+(define-instruction aam (segment)
+  (:printer two-bytes ((op '(#b11010100 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010100)
+   (emit-byte segment #b00001010)))
+
+;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
+(define-instruction cbw (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011000)))
+
+;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
+(define-instruction cwde (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011000)))
+
+;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
+(define-instruction cwd (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011001)))
+
+;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
+(define-instruction cdq (segment)
+  (:printer byte ((op #b10011001)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011001)))
+
+(define-instruction xadd (segment dst src)
+  ;; Register/Memory with Register.
+  (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
+  (:emitter
+   (aver (register-p src))
+   (let ((size (matching-operand-size src dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
+     (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+;;;; logic
+
+(defun emit-shift-inst (segment dst amount opcode)
+  (let ((size (operand-size dst)))
+    (maybe-emit-operand-size-prefix segment size)
+    (multiple-value-bind (major-opcode immed)
+        (case amount
+          (:cl (values #b11010010 nil))
+          (1 (values #b11010000 nil))
+          (t (values #b11000000 t)))
+      (emit-byte segment
+                 (if (eq size :byte) major-opcode (logior major-opcode 1)))
+      (emit-ea segment dst opcode)
+      (when immed
+        (emit-byte segment amount)))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun shift-inst-printer-list (subop)
+    `((reg/mem ((op (#b1101000 ,subop)))
+               (:name :tab reg/mem ", 1"))
+      (reg/mem ((op (#b1101001 ,subop)))
+               (:name :tab reg/mem ", " 'cl))
+      (reg/mem-imm ((op (#b1100000 ,subop))
+                    (imm nil :type signed-imm-byte))))))
+
+(define-instruction rol (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b000))
+  (:emitter
+   (emit-shift-inst segment dst amount #b000)))
+
+(define-instruction ror (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b001))
+  (:emitter
+   (emit-shift-inst segment dst amount #b001)))
+
+(define-instruction rcl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b010))
+  (:emitter
+   (emit-shift-inst segment dst amount #b010)))
+
+(define-instruction rcr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b011))
+  (:emitter
+   (emit-shift-inst segment dst amount #b011)))
+
+(define-instruction shl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b100))
+  (:emitter
+   (emit-shift-inst segment dst amount #b100)))
+
+(define-instruction shr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b101))
+  (:emitter
+   (emit-shift-inst segment dst amount #b101)))
+
+(define-instruction sar (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b111))
+  (:emitter
+   (emit-shift-inst segment dst amount #b111)))
+
+(defun emit-double-shift (segment opcode dst src amt)
+  (let ((size (matching-operand-size dst src)))
+    (when (eq size :byte)
+      (error "Double shifts can only be used with words."))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (emit-byte segment (dpb opcode (byte 1 3)
+                            (if (eq amt :cl) #b10100101 #b10100100)))
+    #+nil
+    (emit-ea segment dst src)
+    (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
+    (unless (eq amt :cl)
+      (emit-byte segment amt))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun double-shift-inst-printer-list (op)
+    `(#+nil
+      (ext-reg-reg/mem-imm ((op ,(logior op #b10))
+                            (imm nil :type signed-imm-byte)))
+      (ext-reg-reg/mem ((op ,(logior op #b10)))
+         (:name :tab reg/mem ", " reg ", " 'cl)))))
+
+(define-instruction shld (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b1010000))
+  (:emitter
+   (emit-double-shift segment #b0 dst src amt)))
+
+(define-instruction shrd (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b1010100))
+  (:emitter
+   (emit-double-shift segment #b1 dst src amt)))
+
+(define-instruction and (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b100))
+  (:emitter
+   (emit-random-arith-inst "AND" segment dst src #b100)))
+
+(define-instruction test (segment this that)
+  (:printer accum-imm ((op #b1010100)))
+  (:printer reg/mem-imm ((op '(#b1111011 #b000))))
+  (:printer reg-reg/mem ((op #b1000010)))
+  (:emitter
+   (let ((size (matching-operand-size this that)))
+     (maybe-emit-operand-size-prefix segment size)
+     (flet ((test-immed-and-something (immed something)
+              (cond ((accumulator-p something)
+                     (emit-byte segment
+                                (if (eq size :byte) #b10101000 #b10101001))
+                     (emit-sized-immediate segment size immed))
+                    (t
+                     (emit-byte segment
+                                (if (eq size :byte) #b11110110 #b11110111))
+                     (emit-ea segment something #b000)
+                     (emit-sized-immediate segment size immed))))
+            (test-reg-and-something (reg something)
+              (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+              (emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((integerp that)
+              (test-immed-and-something that this))
+             ((integerp this)
+              (test-immed-and-something this that))
+             ((register-p this)
+              (test-reg-and-something this that))
+             ((register-p that)
+              (test-reg-and-something that this))
+             (t
+              (error "bogus operands for TEST: ~S and ~S" this that)))))))
+
+(define-instruction or (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b001))
+  (:emitter
+   (emit-random-arith-inst "OR" segment dst src #b001)))
+
+(define-instruction xor (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b110))
+  (:emitter
+   (emit-random-arith-inst "XOR" segment dst src #b110)))
+
+(define-instruction not (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b010))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b010))))
+\f
+;;;; string manipulation
+
+(define-instruction cmps (segment size)
+  (:printer string-op ((op #b1010011)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
+
+(define-instruction ins (segment acc)
+  (:printer string-op ((op #b0110110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
+
+(define-instruction lods (segment acc)
+  (:printer string-op ((op #b1010110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
+
+(define-instruction movs (segment size)
+  (:printer string-op ((op #b1010010)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
+
+(define-instruction outs (segment acc)
+  (:printer string-op ((op #b0110111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
+
+(define-instruction scas (segment acc)
+  (:printer string-op ((op #b1010111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
+
+(define-instruction stos (segment acc)
+  (:printer string-op ((op #b1010101)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
+
+(define-instruction xlat (segment)
+  (:printer byte ((op #b11010111)))
+  (:emitter
+   (emit-byte segment #b11010111)))
+
+(define-instruction rep (segment)
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+(define-instruction repe (segment)
+  (:printer byte ((op #b11110011)))
+  (:emitter
+   (emit-byte segment #b11110011)))
+
+(define-instruction repne (segment)
+  (:printer byte ((op #b11110010)))
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+\f
+;;;; bit manipulation
+
+(define-instruction bsf (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111100)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(define-instruction bsr (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111101)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(defun emit-bit-test-and-mumble (segment src index opcode)
+  (let ((size (operand-size src)))
+    (when (eq size :byte)
+      (error "can't scan bytes: ~S" src))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (cond ((integerp index)
+           (emit-byte segment #b10111010)
+           (emit-ea segment src opcode)
+           (emit-byte segment index))
+          (t
+           (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+           (emit-ea segment src (reg-tn-encoding index))))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun bit-test-inst-printer-list (subop)
+    `((ext-reg/mem-imm ((op (#b1011101 ,subop))
+                        (reg/mem nil :type word-reg/mem)
+                        (imm nil :type imm-data)
+                        (width 0)))
+      (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
+                        (width 1))
+                       (:name :tab reg/mem ", " reg)))))
+
+(define-instruction bt (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b100))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b100)))
+
+(define-instruction btc (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b111))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b111)))
+
+(define-instruction btr (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b110))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b110)))
+
+(define-instruction bts (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b101))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b101)))
+
+\f
+;;;; control transfer
+
+(define-instruction call (segment where)
+  (:printer near-jump ((op #b11101000)))
+  (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
+  (:emitter
+   (typecase where
+     (label
+      (emit-byte segment #b11101000)
+      (emit-back-patch segment
+                       4
+                       (lambda (segment posn)
+                         (emit-dword segment
+                                     (- (label-position where)
+                                        (+ posn 4))))))
+     (fixup
+      (emit-byte segment #b11101000)
+      (emit-relative-fixup segment where))
+     (t
+      (emit-byte segment #b11111111)
+      (emit-ea segment where #b010)))))
+
+(defun emit-byte-displacement-backpatch (segment target)
+  (emit-back-patch segment
+                   1
+                   (lambda (segment posn)
+                     (let ((disp (- (label-position target) (1+ posn))))
+                       (aver (<= -128 disp 127))
+                       (emit-byte segment disp)))))
+
+(define-instruction jmp (segment cond &optional where)
+  ;; conditional jumps
+  (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
+  (:printer near-cond-jump () '('j cc :tab label))
+  ;; unconditional jumps
+  (:printer short-jump ((op #b1011)))
+  (:printer near-jump ((op #b11101001)) )
+  (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
+  (:emitter
+   (cond (where
+          (emit-chooser
+           segment 6 2
+           (lambda (segment posn delta-if-after)
+             (let ((disp (- (label-position where posn delta-if-after)
+                            (+ posn 2))))
+               (when (<= -128 disp 127)
+                 (emit-byte segment
+                            (dpb (conditional-opcode cond)
+                                 (byte 4 0)
+                                 #b01110000))
+                 (emit-byte-displacement-backpatch segment where)
+                 t)))
+           (lambda (segment posn)
+             (let ((disp (- (label-position where) (+ posn 6))))
+               (emit-byte segment #b00001111)
+               (emit-byte segment
+                          (dpb (conditional-opcode cond)
+                               (byte 4 0)
+                               #b10000000))
+               (emit-dword segment disp)))))
+         ((label-p (setq where cond))
+          (emit-chooser
+           segment 5 0
+           (lambda (segment posn delta-if-after)
+             (let ((disp (- (label-position where posn delta-if-after)
+                            (+ posn 2))))
+               (when (<= -128 disp 127)
+                 (emit-byte segment #b11101011)
+                 (emit-byte-displacement-backpatch segment where)
+                 t)))
+           (lambda (segment posn)
+             (let ((disp (- (label-position where) (+ posn 5))))
+               (emit-byte segment #b11101001)
+               (emit-dword segment disp)))))
+         ((fixup-p where)
+          (emit-byte segment #b11101001)
+          (emit-relative-fixup segment where))
+         (t
+          (unless (or (ea-p where) (tn-p where))
+                  (error "don't know what to do with ~A" where))
+          (emit-byte segment #b11111111)
+          (emit-ea segment where #b100)))))
+
+(define-instruction jmp-short (segment label)
+  (:emitter
+   (emit-byte segment #b11101011)
+   (emit-byte-displacement-backpatch segment label)))
+
+(define-instruction ret (segment &optional stack-delta)
+  (:printer byte ((op #b11000011)))
+  (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
+            '(:name :tab imm))
+  (:emitter
+   (cond (stack-delta
+          (emit-byte segment #b11000010)
+          (emit-word segment stack-delta))
+         (t
+          (emit-byte segment #b11000011)))))
+
+(define-instruction jecxz (segment target)
+  (:printer short-jump ((op #b0011)))
+  (:emitter
+   (emit-byte segment #b11100011)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loop (segment target)
+  (:printer short-jump ((op #b0010)))
+  (:emitter
+   (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopz (segment target)
+  (:printer short-jump ((op #b0001)))
+  (:emitter
+   (emit-byte segment #b11100001)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopnz (segment target)
+  (:printer short-jump ((op #b0000)))
+  (:emitter
+   (emit-byte segment #b11100000)
+   (emit-byte-displacement-backpatch segment target)))
+\f
+;;;; conditional move
+(define-instruction cmov (segment cond dst src)
+  (:printer cond-move ())
+  (:emitter
+   (aver (register-p dst))
+   (let ((size (matching-operand-size dst src)))
+     (aver (or (eq size :word) (eq size :dword)))
+     (maybe-emit-operand-size-prefix segment size))
+   (emit-byte segment #b00001111)
+   (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+;;;; conditional byte set
+
+(define-instruction set (segment dst cond)
+  (:printer cond-set ())
+  (:emitter
+   (emit-byte segment #b00001111)
+   (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
+   (emit-ea segment dst #b000)))
+\f
+;;;; enter/leave
+
+(define-instruction enter (segment disp &optional (level 0))
+  (:declare (type (unsigned-byte 16) disp)
+            (type (unsigned-byte 8) level))
+  (:printer enter-format ((op #b11001000)))
+  (:emitter
+   (emit-byte segment #b11001000)
+   (emit-word segment disp)
+   (emit-byte segment level)))
+
+(define-instruction leave (segment)
+  (:printer byte ((op #b11001001)))
+  (:emitter
+   (emit-byte segment #b11001001)))
+\f
+;;;; prefetch
+(define-instruction prefetchnta (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b000)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b000)))
+
+(define-instruction prefetcht0 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b001)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b001)))
+
+(define-instruction prefetcht1 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b010)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b010)))
+
+(define-instruction prefetcht2 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b011)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b011)))
+\f
+;;;; interrupt instructions
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (sb!sys:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type sb!sys: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
+           (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+                                                vector 0 length)
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (sb!c:read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (sb!c:read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+#|
+(defmacro break-cases (breaknum &body cases)
+  (let ((bn-temp (gensym)))
+    (collect ((clauses))
+      (dolist (case cases)
+        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+      `(let ((,bn-temp ,breaknum))
+         (cond ,@(clauses))))))
+|#
+
+(defun break-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
+    ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
+    ;; map has it undefined; and it should be easier to look in the target
+    ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
+    ;; from first principles whether it's defined in some way that genesis
+    ;; can't grok.
+    (case (byte-imm-code chunk dstate)
+      (#.error-trap
+       (nt "error trap")
+       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.cerror-trap
+       (nt "cerror trap")
+       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.breakpoint-trap
+       (nt "breakpoint trap"))
+      (#.pending-interrupt-trap
+       (nt "pending interrupt trap"))
+      (#.halt-trap
+       (nt "halt trap"))
+      (#.fun-end-breakpoint-trap
+       (nt "function end breakpoint trap")))))
+
+(define-instruction break (segment code)
+  (:declare (type (unsigned-byte 8) code))
+  (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+            :control #'break-control)
+  (:emitter
+   (emit-byte segment #b11001100)
+   (emit-byte segment code)))
+
+(define-instruction int (segment number)
+  (:declare (type (unsigned-byte 8) number))
+  (:printer byte-imm ((op #b11001101)))
+  (:emitter
+   (etypecase number
+     ((member 3)
+      (emit-byte segment #b11001100))
+     ((unsigned-byte 8)
+      (emit-byte segment #b11001101)
+      (emit-byte segment number)))))
+
+(define-instruction into (segment)
+  (:printer byte ((op #b11001110)))
+  (:emitter
+   (emit-byte segment #b11001110)))
+
+(define-instruction bound (segment reg bounds)
+  (:emitter
+   (let ((size (matching-operand-size reg bounds)))
+     (when (eq size :byte)
+       (error "can't bounds-test bytes: ~S" reg))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b01100010)
+     (emit-ea segment bounds (reg-tn-encoding reg)))))
+
+(define-instruction iret (segment)
+  (:printer byte ((op #b11001111)))
+  (:emitter
+   (emit-byte segment #b11001111)))
+\f
+;;;; processor control
+
+(define-instruction hlt (segment)
+  (:printer byte ((op #b11110100)))
+  (:emitter
+   (emit-byte segment #b11110100)))
+
+(define-instruction nop (segment)
+  (:printer byte ((op #b10010000)))
+  (:emitter
+   (emit-byte segment #b10010000)))
+
+(define-instruction wait (segment)
+  (:printer byte ((op #b10011011)))
+  (:emitter
+   (emit-byte segment #b10011011)))
+
+(define-instruction lock (segment)
+  (:printer byte ((op #b11110000)))
+  (:emitter
+   (emit-byte segment #b11110000)))
+\f
+;;;; miscellaneous hackery
+
+(define-instruction byte (segment byte)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-instruction word (segment word)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction dword (segment dword)
+  (:emitter
+   (emit-dword segment dword)))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch segment
+                   4
+                   (lambda (segment posn)
+                     (emit-dword segment
+                                 (logior type
+                                         (ash (+ posn
+                                                 (component-header-length))
+                                              (- n-widetag-bits
+                                                 word-shift)))))))
+
+(define-instruction simple-fun-header-word (segment)
+  (:emitter
+   (emit-header-data segment simple-fun-header-widetag)))
+
+(define-instruction lra-header-word (segment)
+  (:emitter
+   (emit-header-data segment return-pc-header-widetag)))
+\f
+;;;; fp instructions
+;;;;
+;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
+;;;;
+;;;; Note: We treat the single-precision and double-precision variants
+;;;; as separate instructions.
+
+;;; Load single to st(0).
+(define-instruction fld (segment source)
+  (:printer floating-point ((op '(#b001 #b000))))
+  (:emitter
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b000)))
+
+;;; Load double to st(0).
+(define-instruction fldd (segment source)
+  (:printer floating-point ((op '(#b101 #b000))))
+  (:printer floating-point-fp ((op '(#b001 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011001)
+     (emit-byte segment #b11011101))
+    (emit-fp-op segment source #b000)))
+
+;;; Load long to st(0).
+(define-instruction fldl (segment source)
+  (:printer floating-point ((op '(#b011 #b101))))
+  (:emitter
+    (emit-byte segment #b11011011)
+    (emit-fp-op segment source #b101)))
+
+;;; Store single from st(0).
+(define-instruction fst (segment dest)
+  (:printer floating-point ((op '(#b001 #b010))))
+  (:emitter
+    (cond ((fp-reg-tn-p dest)
+           (emit-byte segment #b11011101)
+           (emit-fp-op segment dest #b010))
+          (t
+           (emit-byte segment #b11011001)
+           (emit-fp-op segment dest #b010)))))
+
+;;; Store double from st(0).
+(define-instruction fstd (segment dest)
+  (:printer floating-point ((op '(#b101 #b010))))
+  (:printer floating-point-fp ((op '(#b101 #b010))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b010))
+         (t
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b010)))))
+
+;;; Arithmetic ops are all done with at least one operand at top of
+;;; stack. The other operand is is another register or a 32/64 bit
+;;; memory loc.
+
+;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
+;;; that these conflict with the Gdb conventions for binops. To reduce
+;;; the confusion I've added comments showing the mathamatical
+;;; operation and the two syntaxes. By the ASM386 convention the
+;;; instruction syntax is:
+;;;
+;;;      Fop Source
+;;; or   Fop Destination, Source
+;;;
+;;; If only one operand is given then it is the source and the
+;;; destination is ST(0). There are reversed forms of the fsub and
+;;; fdiv instructions inducated by an 'R' suffix.
+;;;
+;;; The mathematical operation for the non-reverse form is always:
+;;;     destination = destination op source
+;;;
+;;; For the reversed form it is:
+;;;     destination = source op destination
+;;;
+;;; The instructions below only accept one operand at present which is
+;;; usually the source. I've hack in extra instructions to implement
+;;; the fops with a ST(i) destination, these have a -sti suffix and
+;;; the operand is the destination with the source being ST(0).
+
+;;; Add single:
+;;;   st(0) = st(0) + memory or st(i).
+(define-instruction fadd (segment source)
+  (:printer floating-point ((op '(#b000 #b000))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b000)))
+
+;;; Add double:
+;;;   st(0) = st(0) + memory or st(i).
+(define-instruction faddd (segment source)
+  (:printer floating-point ((op '(#b100 #b000))))
+  (:printer floating-point-fp ((op '(#b000 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b000)))
+
+;;; Add double destination st(i):
+;;;   st(i) = st(0) + st(i).
+(define-instruction fadd-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b000))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b000)))
+;;; with pop
+(define-instruction faddp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b000))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b000)))
+
+;;; Subtract single:
+;;;   st(0) = st(0) - memory or st(i).
+(define-instruction fsub (segment source)
+  (:printer floating-point ((op '(#b000 #b100))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b100)))
+
+;;; Subtract single, reverse:
+;;;   st(0) = memory or st(i) - st(0).
+(define-instruction fsubr (segment source)
+  (:printer floating-point ((op '(#b000 #b101))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b101)))
+
+;;; Subtract double:
+;;;   st(0) = st(0) - memory or st(i).
+(define-instruction fsubd (segment source)
+  (:printer floating-point ((op '(#b100 #b100))))
+  (:printer floating-point-fp ((op '(#b000 #b100))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b100)))
+
+;;; Subtract double, reverse:
+;;;   st(0) = memory or st(i) - st(0).
+(define-instruction fsubrd (segment source)
+  (:printer floating-point ((op '(#b100 #b101))))
+  (:printer floating-point-fp ((op '(#b000 #b101))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b101)))
+
+;;; Subtract double, destination st(i):
+;;;   st(i) = st(i) - st(0).
+;;;
+;;; ASM386 syntax: FSUB ST(i), ST
+;;; Gdb    syntax: fsubr %st,%st(i)
+(define-instruction fsub-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b101))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b101)))
+;;; with a pop
+(define-instruction fsubp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b101))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b101)))
+
+;;; Subtract double, reverse, destination st(i):
+;;;   st(i) = st(0) - st(i).
+;;;
+;;; ASM386 syntax: FSUBR ST(i), ST
+;;; Gdb    syntax: fsub %st,%st(i)
+(define-instruction fsubr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b100)))
+;;; with a pop
+(define-instruction fsubrp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b100)))
+
+;;; Multiply single:
+;;;   st(0) = st(0) * memory or st(i).
+(define-instruction fmul (segment source)
+  (:printer floating-point ((op '(#b000 #b001))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b001)))
+
+;;; Multiply double:
+;;;   st(0) = st(0) * memory or st(i).
+(define-instruction fmuld (segment source)
+  (:printer floating-point ((op '(#b100 #b001))))
+  (:printer floating-point-fp ((op '(#b000 #b001))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b001)))
+
+;;; Multiply double, destination st(i):
+;;;   st(i) = st(i) * st(0).
+(define-instruction fmul-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b001))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b001)))
+
+;;; Divide single:
+;;;   st(0) = st(0) / memory or st(i).
+(define-instruction fdiv (segment source)
+  (:printer floating-point ((op '(#b000 #b110))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b110)))
+
+;;; Divide single, reverse:
+;;;   st(0) = memory or st(i) / st(0).
+(define-instruction fdivr (segment source)
+  (:printer floating-point ((op '(#b000 #b111))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b111)))
+
+;;; Divide double:
+;;;   st(0) = st(0) / memory or st(i).
+(define-instruction fdivd (segment source)
+  (:printer floating-point ((op '(#b100 #b110))))
+  (:printer floating-point-fp ((op '(#b000 #b110))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b110)))
+
+;;; Divide double, reverse:
+;;;   st(0) = memory or st(i) / st(0).
+(define-instruction fdivrd (segment source)
+  (:printer floating-point ((op '(#b100 #b111))))
+  (:printer floating-point-fp ((op '(#b000 #b111))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b111)))
+
+;;; Divide double, destination st(i):
+;;;   st(i) = st(i) / st(0).
+;;;
+;;; ASM386 syntax: FDIV ST(i), ST
+;;; Gdb    syntax: fdivr %st,%st(i)
+(define-instruction fdiv-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b111))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b111)))
+
+;;; Divide double, reverse, destination st(i):
+;;;   st(i) = st(0) / st(i).
+;;;
+;;; ASM386 syntax: FDIVR ST(i), ST
+;;; Gdb    syntax: fdiv %st,%st(i)
+(define-instruction fdivr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b110))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b110)))
+
+;;; Exchange fr0 with fr(n). (There is no double precision variant.)
+(define-instruction fxch (segment source)
+  (:printer floating-point-fp ((op '(#b001 #b001))))
+  (:emitter
+    (unless (and (tn-p source)
+                 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+      (cl:break))
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b001)))
+
+;;; Push 32-bit integer to st0.
+(define-instruction fild (segment source)
+  (:printer floating-point ((op '(#b011 #b000))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment source #b000)))
+
+;;; Push 64-bit integer to st0.
+(define-instruction fildl (segment source)
+  (:printer floating-point ((op '(#b111 #b101))))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-fp-op segment source #b101)))
+
+;;; Store 32-bit integer.
+(define-instruction fist (segment dest)
+  (:printer floating-point ((op '(#b011 #b010))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b010)))
+
+;;; Store and pop 32-bit integer.
+(define-instruction fistp (segment dest)
+  (:printer floating-point ((op '(#b011 #b011))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b011)))
+
+;;; Store and pop 64-bit integer.
+(define-instruction fistpl (segment dest)
+  (:printer floating-point ((op '(#b111 #b111))))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-fp-op segment dest #b111)))
+
+;;; Store single from st(0) and pop.
+(define-instruction fstp (segment dest)
+  (:printer floating-point ((op '(#b001 #b011))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011))
+         (t
+          (emit-byte segment #b11011001)
+          (emit-fp-op segment dest #b011)))))
+
+;;; Store double from st(0) and pop.
+(define-instruction fstpd (segment dest)
+  (:printer floating-point ((op '(#b101 #b011))))
+  (:printer floating-point-fp ((op '(#b101 #b011))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011))
+         (t
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011)))))
+
+;;; Store long from st(0) and pop.
+(define-instruction fstpl (segment dest)
+  (:printer floating-point ((op '(#b011 #b111))))
+  (:emitter
+    (emit-byte segment #b11011011)
+    (emit-fp-op segment dest #b111)))
+
+;;; Decrement stack-top pointer.
+(define-instruction fdecstp (segment)
+  (:printer floating-point-no ((op #b10110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110110)))
+
+;;; Increment stack-top pointer.
+(define-instruction fincstp (segment)
+  (:printer floating-point-no ((op #b10111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110111)))
+
+;;; Free fp register.
+(define-instruction ffree (segment dest)
+  (:printer floating-point-fp ((op '(#b101 #b000))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dest #b000)))
+
+(define-instruction fabs (segment)
+  (:printer floating-point-no ((op #b00001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100001)))
+
+(define-instruction fchs (segment)
+  (:printer floating-point-no ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100000)))
+
+(define-instruction frndint(segment)
+  (:printer floating-point-no ((op #b11100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111100)))
+
+;;; Initialize NPX.
+(define-instruction fninit(segment)
+  (:printer floating-point-5 ((op #b00011)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100011)))
+
+;;; Store Status Word to AX.
+(define-instruction fnstsw(segment)
+  (:printer floating-point-st ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-byte segment #b11100000)))
+
+;;; Load Control Word.
+;;;
+;;; src must be a memory location
+(define-instruction fldcw(segment src)
+  (:printer floating-point ((op '(#b001 #b101))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b101)))
+
+;;; Store Control Word.
+(define-instruction fnstcw(segment dst)
+  (:printer floating-point ((op '(#b001 #b111))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b111)))
+
+;;; Store FP Environment.
+(define-instruction fstenv(segment dst)
+  (:printer floating-point ((op '(#b001 #b110))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b110)))
+
+;;; Restore FP Environment.
+(define-instruction fldenv(segment src)
+  (:printer floating-point ((op '(#b001 #b100))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b100)))
+
+;;; Save FP State.
+(define-instruction fsave(segment dst)
+  (:printer floating-point ((op '(#b101 #b110))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dst #b110)))
+
+;;; Restore FP State.
+(define-instruction frstor(segment src)
+  (:printer floating-point ((op '(#b101 #b100))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+
+;;; Clear exceptions.
+(define-instruction fnclex(segment)
+  (:printer floating-point-5 ((op #b00010)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100010)))
+
+;;; comparison
+(define-instruction fcom (segment src)
+  (:printer floating-point ((op '(#b000 #b010))))
+  (:emitter
+   (emit-byte segment #b11011000)
+   (emit-fp-op segment src #b010)))
+
+(define-instruction fcomd (segment src)
+  (:printer floating-point ((op '(#b100 #b010))))
+  (:printer floating-point-fp ((op '(#b000 #b010))))
+  (:emitter
+   (if (fp-reg-tn-p src)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment src #b010)))
+
+;;; Compare ST1 to ST0, popping the stack twice.
+(define-instruction fcompp (segment)
+  (:printer floating-point-3 ((op '(#b110 #b011001))))
+  (:emitter
+   (emit-byte segment #b11011110)
+   (emit-byte segment #b11011001)))
+
+;;; unordered comparison
+(define-instruction fucom (segment src)
+  (:printer floating-point-fp ((op '(#b101 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p src))
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+
+(define-instruction ftst (segment)
+  (:printer floating-point-no ((op #b00100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100100)))
+
+;;;; 80387 specials
+
+(define-instruction fsqrt(segment)
+  (:printer floating-point-no ((op #b11010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111010)))
+
+(define-instruction fscale(segment)
+  (:printer floating-point-no ((op #b11101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111101)))
+
+(define-instruction fxtract(segment)
+  (:printer floating-point-no ((op #b10100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110100)))
+
+(define-instruction fsin(segment)
+  (:printer floating-point-no ((op #b11110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111110)))
+
+(define-instruction fcos(segment)
+  (:printer floating-point-no ((op #b11111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111111)))
+
+(define-instruction fprem1(segment)
+  (:printer floating-point-no ((op #b10101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110101)))
+
+(define-instruction fprem(segment)
+  (:printer floating-point-no ((op #b11000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111000)))
+
+(define-instruction fxam (segment)
+  (:printer floating-point-no ((op #b00101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100101)))
+
+;;; These do push/pop to stack and need special handling
+;;; in any VOPs that use them. See the book.
+
+;;; st0 <- st1*log2(st0)
+(define-instruction fyl2x(segment)      ; pops stack
+  (:printer floating-point-no ((op #b10001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110001)))
+
+(define-instruction fyl2xp1(segment)
+  (:printer floating-point-no ((op #b11001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111001)))
+
+(define-instruction f2xm1(segment)
+  (:printer floating-point-no ((op #b10000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110000)))
+
+(define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
+  (:printer floating-point-no ((op #b10010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110010)))
+
+(define-instruction fpatan(segment)     ; POPS STACK
+  (:printer floating-point-no ((op #b10011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110011)))
+
+;;;; loading constants
+
+(define-instruction fldz(segment)
+  (:printer floating-point-no ((op #b01110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101110)))
+
+(define-instruction fld1(segment)
+  (:printer floating-point-no ((op #b01000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101000)))
+
+(define-instruction fldpi(segment)
+  (:printer floating-point-no ((op #b01011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101011)))
+
+(define-instruction fldl2t(segment)
+  (:printer floating-point-no ((op #b01001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101001)))
+
+(define-instruction fldl2e(segment)
+  (:printer floating-point-no ((op #b01010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101010)))
+
+(define-instruction fldlg2(segment)
+  (:printer floating-point-no ((op #b01100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101100)))
+
+(define-instruction fldln2(segment)
+  (:printer floating-point-no ((op #b01101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101101)))
diff --git a/sbcl-src/src-093/compiler/x86/vm.lisp b/sbcl-src/src-093/compiler/x86/vm.lisp
new file mode 100644 (file)
index 0000000..833dd73
--- /dev/null
@@ -0,0 +1,451 @@
+;;;; miscellaneous VM definition noise for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;; the size of an INTEGER representation of a SYSTEM-AREA-POINTER, i.e.
+;;; size of a native memory address
+(deftype sap-int () '(unsigned-byte 32))
+\f
+;;;; register specs
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *byte-register-names* (make-array 8 :initial-element nil))
+  (defvar *word-register-names* (make-array 16 :initial-element nil))
+  (defvar *dword-register-names* (make-array 16 :initial-element nil))
+  (defvar *float-register-names* (make-array 8 :initial-element nil)))
+
+(macrolet ((defreg (name offset size)
+             (let ((offset-sym (symbolicate name "-OFFSET"))
+                   (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+               `(progn
+                  (eval-when (:compile-toplevel :load-toplevel :execute)
+                    ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
+                    ;; (in the same file) depends on compile-time evaluation
+                    ;; of the DEFCONSTANT. -- AL 20010224
+                    (def!constant ,offset-sym ,offset))
+                  (setf (svref ,names-vector ,offset-sym)
+                        ,(symbol-name name)))))
+           ;; FIXME: It looks to me as though DEFREGSET should also
+           ;; define the related *FOO-REGISTER-NAMES* variable.
+           (defregset (name &rest regs)
+             `(eval-when (:compile-toplevel :load-toplevel :execute)
+                (defparameter ,name
+                  (list ,@(mapcar (lambda (name)
+                                    (symbolicate name "-OFFSET"))
+                                  regs))))))
+
+  ;; byte registers
+  ;;
+  ;; Note: the encoding here is different than that used by the chip.
+  ;; We use this encoding so that the compiler thinks that AX (and
+  ;; EAX) overlap AL and AH instead of AL and CL.
+  (defreg al 0 :byte)
+  (defreg ah 1 :byte)
+  (defreg cl 2 :byte)
+  (defreg ch 3 :byte)
+  (defreg dl 4 :byte)
+  (defreg dh 5 :byte)
+  (defreg bl 6 :byte)
+  (defreg bh 7 :byte)
+  (defregset *byte-regs* al ah cl ch dl dh bl bh)
+
+  ;; word registers
+  (defreg ax 0 :word)
+  (defreg cx 2 :word)
+  (defreg dx 4 :word)
+  (defreg bx 6 :word)
+  (defreg sp 8 :word)
+  (defreg bp 10 :word)
+  (defreg si 12 :word)
+  (defreg di 14 :word)
+  (defregset *word-regs* ax cx dx bx si di)
+
+  ;; double word registers
+  (defreg eax 0 :dword)
+  (defreg ecx 2 :dword)
+  (defreg edx 4 :dword)
+  (defreg ebx 6 :dword)
+  (defreg esp 8 :dword)
+  (defreg ebp 10 :dword)
+  (defreg esi 12 :dword)
+  (defreg edi 14 :dword)
+  (defregset *dword-regs* eax ecx edx ebx esi edi)
+
+  ;; floating point registers
+  (defreg fr0 0 :float)
+  (defreg fr1 1 :float)
+  (defreg fr2 2 :float)
+  (defreg fr3 3 :float)
+  (defreg fr4 4 :float)
+  (defreg fr5 5 :float)
+  (defreg fr6 6 :float)
+  (defreg fr7 7 :float)
+  (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+  ;; registers used to pass arguments
+  ;;
+  ;; the number of arguments/return values passed in registers
+  (def!constant  register-arg-count 3)
+  ;; names and offsets for registers used to pass arguments
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (defparameter *register-arg-names* '(edx edi esi)))
+  (defregset    *register-arg-offsets* edx edi esi))
+\f
+;;;; SB definitions
+
+;;; Despite the fact that there are only 8 different registers, we consider
+;;; them 16 in order to describe the overlap of byte registers. The only
+;;; thing we need to represent is what registers overlap. Therefore, we
+;;; consider bytes to take one unit, and words or dwords to take two. We
+;;; don't need to tell the difference between words and dwords, because
+;;; you can't put two words in a dword register.
+(define-storage-base registers :finite :size 16)
+
+;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
+;;; sense to use the 387's idea of a stack; 8 separate registers is easier
+;;; to deal with.
+;;; the old way:
+;;;   (define-storage-base float-registers :finite :size 1)
+;;; the new way:
+(define-storage-base float-registers :finite :size 8)
+
+(define-storage-base stack :unbounded :size 8)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+(define-storage-base noise :unbounded :size 2)
+\f
+;;;; SC definitions
+
+;;; a handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class
+;;;
+(defmacro !define-storage-classes (&rest classes)
+  (collect ((forms))
+    (let ((index 0))
+      (dolist (class classes)
+        (let* ((sc-name (car class))
+               (constant-name (symbolicate sc-name "-SC-NUMBER")))
+          (forms `(define-storage-class ,sc-name ,index
+                    ,@(cdr class)))
+          (forms `(def!constant ,constant-name ,index))
+          (incf index))))
+    `(progn
+       ,@(forms))))
+
+;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size
+;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until
+;;; later in the build process, and the calculation is entangled with
+;;; code which has lots of predependencies, including dependencies on
+;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to
+;;; unscramble this would be to untangle the code, so that the code
+;;; which calculates the size of CATCH-BLOCK can be separated from the
+;;; other lots-of-dependencies code, so that the code which calculates
+;;; the size of CATCH-BLOCK can be executed early, so that this value
+;;; is known properly at this point in compilation. However, that
+;;; would be a lot of editing of code that I (WHN 19990131) can't test
+;;; until the project is complete. So instead, I set the correct value
+;;; by hand here (a sort of nondeterministic guess of the right
+;;; answer:-) and add an assertion later, after the value is
+;;; calculated, that the original guess was correct.
+;;;
+;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess
+;;; has my gratitude.) (FIXME: Maybe this should be me..)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def!constant kludge-nondeterministic-catch-block-size 6))
+
+(!define-storage-classes
+
+  ;; non-immediate constants in the constant pool
+  (constant constant)
+
+  ;; some FP constants can be generated in the i387 silicon
+  (fp-constant immediate-constant)
+
+  (immediate immediate-constant)
+
+  ;;
+  ;; the stacks
+  ;;
+
+  ;; the control stack
+  (control-stack stack)                 ; may be pointers, scanned by GC
+
+  ;; the non-descriptor stacks
+  (signed-stack stack)                  ; (signed-byte 32)
+  (unsigned-stack stack)                ; (unsigned-byte 32)
+  (character-stack stack)               ; non-descriptor characters.
+  (sap-stack stack)                     ; System area pointers.
+  (single-stack stack)                  ; single-floats
+  (double-stack stack :element-size 2)  ; double-floats.
+  #!+long-float
+  (long-stack stack :element-size 3)    ; long-floats.
+  (complex-single-stack stack :element-size 2)  ; complex-single-floats
+  (complex-double-stack stack :element-size 4)  ; complex-double-floats
+  #!+long-float
+  (complex-long-stack stack :element-size 6)    ; complex-long-floats
+
+  ;;
+  ;; magic SCs
+  ;;
+
+  (ignore-me noise)
+
+  ;;
+  ;; things that can go in the integer registers
+  ;;
+
+  ;; On the X86, we don't have to distinguish between descriptor and
+  ;; non-descriptor registers, because of the conservative GC.
+  ;; Therefore, we use different scs only to distinguish between
+  ;; descriptor and non-descriptor values and to specify size.
+
+  ;; immediate descriptor objects. Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are. (fixnums, characters, header values, etc).
+  (any-reg registers
+           :locations #.*dword-regs*
+           :element-size 2
+;          :reserve-locations (#.eax-offset)
+           :constant-scs (immediate)
+           :save-p t
+           :alternate-scs (control-stack))
+
+  ;; pointer descriptor objects -- must be seen by GC
+  (descriptor-reg registers
+                  :locations #.*dword-regs*
+                  :element-size 2
+;                 :reserve-locations (#.eax-offset)
+                  :constant-scs (constant immediate)
+                  :save-p t
+                  :alternate-scs (control-stack))
+
+  ;; non-descriptor characters
+  (character-reg registers
+                 :locations #!-sb-unicode #.*byte-regs*
+                            #!+sb-unicode #.*dword-regs*
+                 #!-sb-unicode #!-sb-unicode
+                 :reserve-locations (#.ah-offset #.al-offset)
+                 :constant-scs (immediate)
+                 :save-p t
+                 :alternate-scs (character-stack))
+
+  ;; non-descriptor SAPs (arbitrary pointers into address space)
+  (sap-reg registers
+           :locations #.*dword-regs*
+           :element-size 2
+;          :reserve-locations (#.eax-offset)
+           :constant-scs (immediate)
+           :save-p t
+           :alternate-scs (sap-stack))
+
+  ;; non-descriptor (signed or unsigned) numbers
+  (signed-reg registers
+              :locations #.*dword-regs*
+              :element-size 2
+;             :reserve-locations (#.eax-offset)
+              :constant-scs (immediate)
+              :save-p t
+              :alternate-scs (signed-stack))
+  (unsigned-reg registers
+                :locations #.*dword-regs*
+                :element-size 2
+;               :reserve-locations (#.eax-offset)
+                :constant-scs (immediate)
+                :save-p t
+                :alternate-scs (unsigned-stack))
+
+  ;; miscellaneous objects that must not be seen by GC. Used only as
+  ;; temporaries.
+  (word-reg registers
+            :locations #.*word-regs*
+            :element-size 2
+;           :reserve-locations (#.ax-offset)
+            )
+  (byte-reg registers
+            :locations #.*byte-regs*
+;           :reserve-locations (#.al-offset #.ah-offset)
+            )
+
+  ;; that can go in the floating point registers
+
+  ;; non-descriptor SINGLE-FLOATs
+  (single-reg float-registers
+              :locations (0 1 2 3 4 5 6 7)
+              :constant-scs (fp-constant)
+              :save-p t
+              :alternate-scs (single-stack))
+
+  ;; non-descriptor DOUBLE-FLOATs
+  (double-reg float-registers
+              :locations (0 1 2 3 4 5 6 7)
+              :constant-scs (fp-constant)
+              :save-p t
+              :alternate-scs (double-stack))
+
+  ;; non-descriptor LONG-FLOATs
+  #!+long-float
+  (long-reg float-registers
+            :locations (0 1 2 3 4 5 6 7)
+            :constant-scs (fp-constant)
+            :save-p t
+            :alternate-scs (long-stack))
+
+  (complex-single-reg float-registers
+                      :locations (0 2 4 6)
+                      :element-size 2
+                      :constant-scs ()
+                      :save-p t
+                      :alternate-scs (complex-single-stack))
+
+  (complex-double-reg float-registers
+                      :locations (0 2 4 6)
+                      :element-size 2
+                      :constant-scs ()
+                      :save-p t
+                      :alternate-scs (complex-double-stack))
+
+  #!+long-float
+  (complex-long-reg float-registers
+                    :locations (0 2 4 6)
+                    :element-size 2
+                    :constant-scs ()
+                    :save-p t
+                    :alternate-scs (complex-long-stack))
+
+  ;; a catch or unwind block
+  (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *byte-sc-names*
+  '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
+(defparameter *word-sc-names* '(word-reg))
+(defparameter *dword-sc-names*
+  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
+    signed-stack unsigned-stack sap-stack single-stack
+    #!+sb-unicode character-reg #!+sb-unicode character-stack constant))
+;;; added by jrd. I guess the right thing to do is to treat floats
+;;; as a separate size...
+;;;
+;;; These are used to (at least) determine operand size.
+(defparameter *float-sc-names* '(single-reg))
+(defparameter *double-sc-names* '(double-reg double-stack))
+) ; EVAL-WHEN
+\f
+;;;; miscellaneous TNs for the various registers
+
+(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
+             (collect ((forms))
+                      (dolist (reg-name reg-names)
+                        (let ((tn-name (symbolicate reg-name "-TN"))
+                              (offset-name (symbolicate reg-name "-OFFSET")))
+                          ;; FIXME: It'd be good to have the special
+                          ;; variables here be named with the *FOO*
+                          ;; convention.
+                          (forms `(defparameter ,tn-name
+                                    (make-random-tn :kind :normal
+                                                    :sc (sc-or-lose ',sc-name)
+                                                    :offset
+                                                    ,offset-name)))))
+                      `(progn ,@(forms)))))
+
+  (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
+  (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
+  (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
+  (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7))
+
+;;; TNs for registers used to pass arguments
+(defparameter *register-arg-tns*
+  (mapcar (lambda (register-arg-name)
+            (symbol-value (symbolicate register-arg-name "-TN")))
+          *register-arg-names*))
+
+;;; FIXME: doesn't seem to be used in SBCL
+#|
+;;; added by pw
+(defparameter fp-constant-tn
+  (make-random-tn :kind :normal
+                  :sc (sc-or-lose 'fp-constant)
+                  :offset 31))          ; Offset doesn't get used.
+|#
+\f
+;;; If value can be represented as an immediate constant, then return
+;;; the appropriate SC number, otherwise return NIL.
+(!def-vm-support-routine immediate-constant-sc (value)
+  (typecase value
+    ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
+         #-sb-xc-host system-area-pointer character)
+     (sc-number-or-lose 'immediate))
+    (symbol
+     (when (static-symbol-p value)
+       (sc-number-or-lose 'immediate)))
+    (single-float
+     (when (or (eql value 0f0) (eql value 1f0))
+       (sc-number-or-lose 'fp-constant)))
+    (double-float
+     (when (or (eql value 0d0) (eql value 1d0))
+       (sc-number-or-lose 'fp-constant)))
+    #!+long-float
+    (long-float
+     (when (or (eql value 0l0) (eql value 1l0)
+               (eql value pi)
+               (eql value (log 10l0 2l0))
+               (eql value (log 2.718281828459045235360287471352662L0 2l0))
+               (eql value (log 2l0 10l0))
+               (eql value (log 2l0 2.718281828459045235360287471352662L0)))
+       (sc-number-or-lose 'fp-constant)))))
+\f
+;;;; miscellaneous function call parameters
+
+;;; offsets of special stack frame locations
+(def!constant ocfp-save-offset 0)
+(def!constant return-pc-save-offset 1)
+(def!constant code-save-offset 2)
+
+;;; FIXME: This is a bad comment (changed since when?) and there are others
+;;; like it in this file. It'd be nice to clarify them. Failing that deleting
+;;; them or flagging them with KLUDGE might be better than nothing.
+;;;
+;;; names of these things seem to have changed. these aliases by jrd
+(def!constant lra-save-offset return-pc-save-offset)
+
+(def!constant cfp-offset ebp-offset)    ; pfw - needed by stuff in /code
+                                        ; related to signal context stuff
+
+;;; This is used by the debugger.
+(def!constant single-value-return-byte-offset 2)
+\f
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location. It returns a thing that can be printed with PRINC.
+(!def-vm-support-routine location-print-name (tn)
+  (declare (type tn tn))
+  (let* ((sc (tn-sc tn))
+         (sb (sb-name (sc-sb sc)))
+         (offset (tn-offset tn)))
+    (ecase sb
+      (registers
+       (let* ((sc-name (sc-name sc))
+              (name-vec (cond ((member sc-name *byte-sc-names*)
+                               *byte-register-names*)
+                              ((member sc-name *word-sc-names*)
+                               *word-register-names*)
+                              ((member sc-name *dword-sc-names*)
+                               *dword-register-names*))))
+         (or (and name-vec
+                  (< -1 offset (length name-vec))
+                  (svref name-vec offset))
+             ;; FIXME: Shouldn't this be an ERROR?
+             (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
+      (float-registers (format nil "FR~D" offset))
+      (stack (format nil "S~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed")
+      (noise (symbol-name (sc-name sc))))))
+;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
diff --git a/sbcl-src/src/compiler/x86/insts.lisp b/sbcl-src/src/compiler/x86/insts.lisp
new file mode 100644 (file)
index 0000000..da683b8
--- /dev/null
@@ -0,0 +1,2794 @@
+;;;; that part of the description of the x86 instruction set (for
+;;;; 80386 and above) which can live on the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
+;;; I wonder whether the separation of the disassembler from the
+;;; virtual machine is valid or adds value.
+
+;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
+(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
+
+(deftype reg () '(unsigned-byte 3))
+
+(def!constant +default-operand-size+ :dword)
+\f
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+
+(defun offset-next (value dstate)
+  (declare (type integer value)
+           (type sb!disassem:disassem-state dstate))
+  (+ (sb!disassem:dstate-next-addr dstate) value))
+
+(defparameter *default-address-size*
+  ;; Actually, :DWORD is the only one really supported.
+  :dword)
+
+(defparameter *byte-reg-names*
+  #(al cl dl bl ah ch dh bh))
+(defparameter *word-reg-names*
+  #(ax cx dx bx sp bp si di))
+(defparameter *dword-reg-names*
+  #(eax ecx edx ebx esp ebp esi edi))
+
+(defun print-reg-with-width (value width stream dstate)
+  (declare (ignore dstate))
+  (princ (aref (ecase width
+                 (:byte *byte-reg-names*)
+                 (:word *word-reg-names*)
+                 (:dword *dword-reg-names*))
+               value)
+         stream)
+  ;; XXX plus should do some source-var notes
+  )
+
+(defun print-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value
+                        (sb!disassem:dstate-get-prop dstate 'width)
+                        stream
+                        dstate))
+
+(defun print-word-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value
+                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                            +default-operand-size+)
+                        stream
+                        dstate))
+
+(defun print-byte-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value :byte stream dstate))
+
+(defun print-addr-reg (value stream dstate)
+  (declare (type reg value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value *default-address-size* stream dstate))
+
+(defun print-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream nil dstate)))
+
+;; Same as print-reg/mem, but prints an explicit size indicator for
+;; memory references.
+(defun print-sized-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-byte-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-byte-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-word-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+           (type stream stream)
+           (type sb!disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-word-reg value stream dstate)
+      (print-mem-access value stream nil dstate)))
+
+(defun print-label (value stream dstate)
+  (declare (ignore dstate))
+  (sb!disassem:princ16 value stream))
+
+;;; Returns either an integer, meaning a register, or a list of
+;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
+;;; may be missing or nil to indicate that it's not used or has the
+;;; obvious default value (e.g., 1 for the index-scale).
+(defun prefilter-reg/mem (value dstate)
+  (declare (type list value)
+           (type sb!disassem:disassem-state dstate))
+  (let ((mod (car value))
+        (r/m (cadr value)))
+    (declare (type (unsigned-byte 2) mod)
+             (type (unsigned-byte 3) r/m))
+    (cond ((= mod #b11)
+           ;; registers
+           r/m)
+          ((= r/m #b100)
+           ;; sib byte
+           (let ((sib (sb!disassem:read-suffix 8 dstate)))
+             (declare (type (unsigned-byte 8) sib))
+             (let ((base-reg (ldb (byte 3 0) sib))
+                   (index-reg (ldb (byte 3 3) sib))
+                   (index-scale (ldb (byte 2 6) sib)))
+               (declare (type (unsigned-byte 3) base-reg index-reg)
+                        (type (unsigned-byte 2) index-scale))
+               (let* ((offset
+                       (case mod
+                         (#b00
+                          (if (= base-reg #b101)
+                              (sb!disassem:read-signed-suffix 32 dstate)
+                              nil))
+                         (#b01
+                          (sb!disassem:read-signed-suffix 8 dstate))
+                         (#b10
+                          (sb!disassem:read-signed-suffix 32 dstate)))))
+                 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+                       offset
+                       (if (= index-reg #b100) nil index-reg)
+                       (ash 1 index-scale))))))
+          ((and (= mod #b00) (= r/m #b101))
+           (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
+          ((= mod #b00)
+           (list r/m))
+          ((= mod #b01)
+           (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
+          (t                            ; (= mod #b10)
+           (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
+
+
+;;; This is a sort of bogus prefilter that just stores the info globally for
+;;; other people to use; it probably never gets printed.
+(defun prefilter-width (value dstate)
+  (setf (sb!disassem:dstate-get-prop dstate 'width)
+        (if (zerop value)
+            :byte
+            (let ((word-width
+                   ;; set by a prefix instruction
+                   (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                       +default-operand-size+)))
+              (when (not (eql word-width +default-operand-size+))
+                ;; Reset it.
+                (setf (sb!disassem:dstate-get-prop dstate 'word-width)
+                      +default-operand-size+))
+              word-width))))
+
+(defun read-address (value dstate)
+  (declare (ignore value))              ; always nil anyway
+  (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
+
+(defun width-bits (width)
+  (ecase width
+    (:byte 8)
+    (:word 16)
+    (:dword 32)
+    (:dqword 128)
+    (:float 32)
+    (:double 64)))
+
+) ; EVAL-WHEN
+\f
+;;;; disassembler argument types
+
+(sb!disassem:define-arg-type displacement
+  :sign-extend t
+  :use-label #'offset-next
+  :printer (lambda (value stream dstate)
+             (sb!disassem:maybe-note-assembler-routine value nil dstate)
+             (print-label value stream dstate)))
+
+(sb!disassem:define-arg-type accum
+  :printer (lambda (value stream dstate)
+             (declare (ignore value)
+                      (type stream stream)
+                      (type sb!disassem:disassem-state dstate))
+             (print-reg 0 stream dstate)))
+
+(sb!disassem:define-arg-type word-accum
+  :printer (lambda (value stream dstate)
+             (declare (ignore value)
+                      (type stream stream)
+                      (type sb!disassem:disassem-state dstate))
+             (print-word-reg 0 stream dstate)))
+
+(sb!disassem:define-arg-type reg
+  :printer #'print-reg)
+
+(sb!disassem:define-arg-type addr-reg
+  :printer #'print-addr-reg)
+
+(sb!disassem:define-arg-type word-reg
+  :printer #'print-word-reg)
+
+(sb!disassem:define-arg-type imm-addr
+  :prefilter #'read-address
+  :printer #'print-label)
+
+(sb!disassem:define-arg-type imm-data
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-suffix
+                (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+                dstate)))
+
+(sb!disassem:define-arg-type signed-imm-data
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+
+(sb!disassem:define-arg-type signed-imm-byte
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-signed-suffix 8 dstate)))
+
+(sb!disassem:define-arg-type signed-imm-dword
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-signed-suffix 32 dstate)))
+
+(sb!disassem:define-arg-type imm-word
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width
+                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                          +default-operand-size+)))
+                 (sb!disassem:read-suffix (width-bits width) dstate))))
+
+(sb!disassem:define-arg-type signed-imm-word
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (let ((width
+                      (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                          +default-operand-size+)))
+                 (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+
+;;; needed for the ret imm16 instruction
+(sb!disassem:define-arg-type imm-word-16
+  :prefilter (lambda (value dstate)
+               (declare (ignore value)) ; always nil anyway
+               (sb!disassem:read-suffix 16 dstate)))
+
+(sb!disassem:define-arg-type reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-reg/mem)
+(sb!disassem:define-arg-type sized-reg/mem
+  ;; Same as reg/mem, but prints an explicit size indicator for
+  ;; memory references.
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-sized-reg/mem)
+(sb!disassem:define-arg-type byte-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-byte-reg/mem)
+(sb!disassem:define-arg-type word-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-word-reg/mem)
+
+;;; added by jrd
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+(defun print-fp-reg (value stream dstate)
+  (declare (ignore dstate))
+  (format stream "FR~D" value))
+(defun prefilter-fp-reg (value dstate)
+  ;; just return it
+  (declare (ignore dstate))
+  value)
+) ; EVAL-WHEN
+(sb!disassem:define-arg-type fp-reg
+                             :prefilter #'prefilter-fp-reg
+                             :printer #'print-fp-reg)
+
+(sb!disassem:define-arg-type width
+  :prefilter #'prefilter-width
+  :printer (lambda (value stream dstate)
+             (if;; (zerop value)
+                 (or (null value)
+                     (and (numberp value) (zerop value))) ; zzz jrd
+                 (princ 'b stream)
+                 (let ((word-width
+                        ;; set by a prefix instruction
+                        (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                            +default-operand-size+)))
+                   (princ (schar (symbol-name word-width) 0) stream)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *conditions*
+  '((:o . 0)
+    (:no . 1)
+    (:b . 2) (:nae . 2) (:c . 2)
+    (:nb . 3) (:ae . 3) (:nc . 3)
+    (:eq . 4) (:e . 4) (:z . 4)
+    (:ne . 5) (:nz . 5)
+    (:be . 6) (:na . 6)
+    (:nbe . 7) (:a . 7)
+    (:s . 8)
+    (:ns . 9)
+    (:p . 10) (:pe . 10)
+    (:np . 11) (:po . 11)
+    (:l . 12) (:nge . 12)
+    (:nl . 13) (:ge . 13)
+    (:le . 14) (:ng . 14)
+    (:nle . 15) (:g . 15)))
+(defparameter *condition-name-vec*
+  (let ((vec (make-array 16 :initial-element nil)))
+    (dolist (cond *conditions*)
+      (when (null (aref vec (cdr cond)))
+        (setf (aref vec (cdr cond)) (car cond))))
+    vec))
+) ; EVAL-WHEN
+
+;;; Set assembler parameters. (In CMU CL, this was done with
+;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf sb!assem:*assem-scheduler-p* nil))
+
+(sb!disassem:define-arg-type condition-code
+  :printer *condition-name-vec*)
+
+(defun conditional-opcode (condition)
+  (cdr (assoc condition *conditions* :test #'eq)))
+\f
+;;;; disassembler instruction formats
+
+(eval-when (:compile-toplevel :execute)
+  (defun swap-if (direction field1 separator field2)
+    `(:if (,direction :constant 0)
+          (,field1 ,separator ,field2)
+          (,field2 ,separator ,field1))))
+
+(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
+  (op    :field (byte 8 0))
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+(sb!disassem:define-instruction-format (simple 8)
+  (op    :field (byte 7 1))
+  (width :field (byte 1 0) :type 'width)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+;;; Same as simple, but with direction bit
+(sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
+  (op :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as simple, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (accum-imm 8
+                                     :include 'simple
+                                     :default-printer '(:name
+                                                        :tab accum ", " imm))
+  (imm :type 'imm-data))
+
+(sb!disassem:define-instruction-format (reg-no-width 8
+                                     :default-printer '(:name :tab reg))
+  (op    :field (byte 5 3))
+  (reg   :field (byte 3 0) :type 'word-reg)
+  ;; optional fields
+  (accum :type 'word-accum)
+  (imm))
+
+;;; adds a width field to reg-no-width
+(sb!disassem:define-instruction-format (reg 8
+                                        :default-printer '(:name :tab reg))
+  (op    :field (byte 4 4))
+  (width :field (byte 1 3) :type 'width)
+  (reg   :field (byte 3 0) :type 'reg)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm)
+  )
+
+;;; Same as reg, but with direction bit
+(sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
+  (op  :field (byte 3 5))
+  (dir :field (byte 1 4)))
+
+(sb!disassem:define-instruction-format (two-bytes 16
+                                        :default-printer '(:name))
+  (op :fields (list (byte 8 0) (byte 8 8))))
+
+(sb!disassem:define-instruction-format (reg-reg/mem 16
+                                        :default-printer
+                                        `(:name :tab reg ", " reg/mem))
+  (op      :field (byte 7 1))
+  (width   :field (byte 1 0)    :type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 11)   :type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; same as reg-reg/mem, but with direction bit
+(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
+                                        :include 'reg-reg/mem
+                                        :default-printer
+                                        `(:name
+                                          :tab
+                                          ,(swap-if 'dir 'reg/mem ", " 'reg)))
+  (op  :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as reg-rem/mem, but uses the reg field as a second op code.
+(sb!disassem:define-instruction-format (reg/mem 16
+                                        :default-printer '(:name :tab reg/mem))
+  (op      :fields (list (byte 7 1) (byte 3 11)))
+  (width   :field (byte 1 0)    :type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+                                :type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (reg/mem-imm 16
+                                        :include 'reg/mem
+                                        :default-printer
+                                        '(:name :tab reg/mem ", " imm))
+  (reg/mem :type 'sized-reg/mem)
+  (imm     :type 'imm-data))
+
+;;; Same as reg/mem, but with using the accumulator in the default printer
+(sb!disassem:define-instruction-format
+    (accum-reg/mem 16
+     :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
+  (reg/mem :type 'reg/mem)              ; don't need a size
+  (accum :type 'accum))
+
+;;; Same as reg-reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
+                                        :default-printer
+                                        `(:name :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :field (byte 7 9))
+  (width   :field (byte 1 8)    :type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 19)   :type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg/mem 24
+                                        :default-printer '(:name :tab reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :fields (list (byte 7 9) (byte 3 19)))
+  (width   :field (byte 1 8)    :type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+(sb!disassem:define-instruction-format (ext-reg/mem-imm 24
+                                        :include 'ext-reg/mem
+                                        :default-printer
+                                        '(:name :tab reg/mem ", " imm))
+  (imm :type 'imm-data))
+\f
+;;;; This section was added by jrd, for fp instructions.
+
+;;; regular fp inst to/from registers/memory
+(sb!disassem:define-instruction-format (floating-point 16
+                                        :default-printer
+                                        `(:name :tab reg/mem))
+  (prefix :field (byte 5 3) :value #b11011)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
+
+;;; fp insn to/from fp reg
+(sb!disassem:define-instruction-format (floating-point-fp 16
+                                        :default-printer `(:name :tab fp-reg))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+;;; fp insn to/from fp reg, with the reversed source/destination flag.
+(sb!disassem:define-instruction-format
+ (floating-point-fp-d 16
+   :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 2 0) (byte 3 11)))
+  (d      :field (byte 1 2))
+  (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+
+;;; (added by (?) pfw)
+;;; fp no operand isns
+(sb!disassem:define-instruction-format (floating-point-no 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011001)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (floating-point-3 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 3 0) (byte 6 8))))
+
+(sb!disassem:define-instruction-format (floating-point-5 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011011)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (floating-point-st 16
+                                      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011111)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(sb!disassem:define-instruction-format (string-op 8
+                                     :include 'simple
+                                     :default-printer '(:name width)))
+
+(sb!disassem:define-instruction-format (short-cond-jump 16)
+  (op    :field (byte 4 4))
+  (cc    :field (byte 4 0) :type 'condition-code)
+  (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (short-jump 16
+                                     :default-printer '(:name :tab label))
+  (const :field (byte 4 4) :value #b1110)
+  (op    :field (byte 4 0))
+  (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (near-cond-jump 16)
+  (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
+  (cc    :field (byte 4 8) :type 'condition-code)
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the offset.
+  (label :type 'displacement
+         :prefilter (lambda (value dstate)
+                      (declare (ignore value)) ; always nil anyway
+                      (sb!disassem:read-signed-suffix 32 dstate))))
+
+(sb!disassem:define-instruction-format (near-jump 8
+                                     :default-printer '(:name :tab label))
+  (op    :field (byte 8 0))
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the address.
+  (label :type 'displacement
+         :prefilter (lambda (value dstate)
+                      (declare (ignore value)) ; always nil anyway
+                      (sb!disassem:read-signed-suffix 32 dstate))))
+
+
+(sb!disassem:define-instruction-format (cond-set 24
+                                     :default-printer '('set cc :tab reg/mem))
+  (prefix :field (byte 8 0) :value #b00001111)
+  (op    :field (byte 4 12) :value #b1001)
+  (cc    :field (byte 4 8) :type 'condition-code)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+           :type 'byte-reg/mem)
+  (reg     :field (byte 3 19)   :value #b000))
+
+(sb!disassem:define-instruction-format (cond-move 24
+                                     :default-printer
+                                        '('cmov cc :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)    :value #b00001111)
+  (op      :field (byte 4 12)   :value #b0100)
+  (cc      :field (byte 4 8)    :type 'condition-code)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+                                :type 'reg/mem)
+  (reg     :field (byte 3 19)   :type 'reg))
+
+(sb!disassem:define-instruction-format (enter-format 32
+                                     :default-printer '(:name
+                                                        :tab disp
+                                                        (:unless (:constant 0)
+                                                          ", " level)))
+  (op :field (byte 8 0))
+  (disp :field (byte 16 8))
+  (level :field (byte 8 24)))
+
+(sb!disassem:define-instruction-format (prefetch 24
+                                                 :default-printer
+                                                 '(:name ", " reg/mem))
+  (prefix :field (byte 8 0) :value #b00001111)
+  (op :field (byte 8 8) :value #b00011000)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
+  (reg :field (byte 3 19) :type 'reg))
+
+;;; Single byte instruction with an immediate byte argument.
+(sb!disassem:define-instruction-format (byte-imm 16
+                                     :default-printer '(:name :tab code))
+ (op :field (byte 8 0))
+ (code :field (byte 8 8)))
+\f
+;;;; primitive emitters
+
+(define-bitfield-emitter emit-word 16
+  (byte 16 0))
+
+(define-bitfield-emitter emit-dword 32
+  (byte 32 0))
+
+(define-bitfield-emitter emit-byte-with-reg 8
+  (byte 5 3) (byte 3 0))
+
+(define-bitfield-emitter emit-mod-reg-r/m-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+(define-bitfield-emitter emit-sib-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+\f
+;;;; fixup emitters
+
+(defun emit-absolute-fixup (segment fixup)
+  (note-fixup segment :absolute fixup)
+  (let ((offset (fixup-offset fixup)))
+    (if (label-p offset)
+        (emit-back-patch segment
+                         4 ; FIXME: n-word-bytes
+                         (lambda (segment posn)
+                           (declare (ignore posn))
+                           (emit-dword segment
+                                       (- (+ (component-header-length)
+                                             (or (label-position offset)
+                                                 0))
+                                          other-pointer-lowtag))))
+        (emit-dword segment (or offset 0)))))
+
+(defun emit-relative-fixup (segment fixup)
+  (note-fixup segment :relative fixup)
+  (emit-dword segment (or (fixup-offset fixup) 0)))
+\f
+;;;; the effective-address (ea) structure
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+;  (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+  (let ((offset (tn-offset tn)))
+    (logior (ash (logand offset 1) 2)
+            (ash offset -1))))
+
+(defstruct (ea (:constructor make-ea (size &key base index scale disp))
+               (:copier nil))
+  (size nil :type (member :byte :word :dword))
+  (base nil :type (or tn null))
+  (index nil :type (or tn null))
+  (scale 1 :type (member 1 2 4 8))
+  (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
+(def!method print-object ((ea ea) stream)
+  (cond ((or *print-escape* *print-readably*)
+         (print-unreadable-object (ea stream :type t)
+           (format stream
+                   "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+                   (ea-size ea)
+                   (ea-base ea)
+                   (ea-index ea)
+                   (let ((scale (ea-scale ea)))
+                     (if (= scale 1) nil scale))
+                   (ea-disp ea))))
+        (t
+         (format stream "~A PTR [" (symbol-name (ea-size ea)))
+         (when (ea-base ea)
+           (write-string (sb!c::location-print-name (ea-base ea)) stream)
+           (when (ea-index ea)
+             (write-string "+" stream)))
+         (when (ea-index ea)
+           (write-string (sb!c::location-print-name (ea-index ea)) stream))
+         (unless (= (ea-scale ea) 1)
+           (format stream "*~A" (ea-scale ea)))
+         (typecase (ea-disp ea)
+           (null)
+           (integer
+            (format stream "~@D" (ea-disp ea)))
+           (t
+            (format stream "+~A" (ea-disp ea))))
+         (write-char #\] stream))))
+
+(defun emit-ea (segment thing reg &optional allow-constants)
+  (etypecase thing
+    (tn
+     (ecase (sb-name (sc-sb (tn-sc thing)))
+       (registers
+        (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+       (sse-registers
+        (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+       (stack
+        ;; Convert stack tns into an index off of EBP.
+        (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+          (cond ((< -128 disp 127)
+                 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+                 (emit-byte segment disp))
+                (t
+                 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+                 (emit-dword segment disp)))))
+       (constant
+        (unless allow-constants
+          (error
+           "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+        (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+        (emit-absolute-fixup segment
+                             (make-fixup nil
+                                         :code-object
+                                         (- (* (tn-offset thing) n-word-bytes)
+                                            other-pointer-lowtag))))))
+    (ea
+     (let* ((base (ea-base thing))
+            (index (ea-index thing))
+            (scale (ea-scale thing))
+            (disp (ea-disp thing))
+            (mod (cond ((or (null base)
+                            (and (eql disp 0)
+                                 (not (= (reg-tn-encoding base) #b101))))
+                        #b00)
+                       ((and (fixnump disp) (<= -128 disp 127))
+                        #b01)
+                       (t
+                        #b10)))
+            (r/m (cond (index #b100)
+                       ((null base) #b101)
+                       (t (reg-tn-encoding base)))))
+       (emit-mod-reg-r/m-byte segment mod reg r/m)
+       (when (= r/m #b100)
+         (let ((ss (1- (integer-length scale)))
+               (index (if (null index)
+                          #b100
+                          (let ((index (reg-tn-encoding index)))
+                            (if (= index #b100)
+                                (error "can't index off of ESP")
+                                index))))
+               (base (if (null base)
+                         #b101
+                         (reg-tn-encoding base))))
+           (emit-sib-byte segment ss index base)))
+       (cond ((= mod #b01)
+              (emit-byte segment disp))
+             ((or (= mod #b10) (null base))
+              (if (fixup-p disp)
+                  (emit-absolute-fixup segment disp)
+                  (emit-dword segment disp))))))
+    (fixup
+     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+     (emit-absolute-fixup segment thing))))
+
+(defun fp-reg-tn-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
+;;; like the above, but for fp-instructions--jrd
+(defun emit-fp-op (segment thing op)
+  (if (fp-reg-tn-p thing)
+      (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
+                                                 (byte 3 0)
+                                                 #b11000000)))
+    (emit-ea segment thing op)))
+
+(defun byte-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *byte-sc-names*)
+       t))
+
+(defun byte-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :byte))
+    (tn
+     (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
+    (t nil)))
+
+(defun word-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *word-sc-names*)
+       t))
+
+(defun word-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :word))
+    (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
+    (t nil)))
+
+(defun dword-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) *dword-sc-names*)
+       t))
+
+(defun dword-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :dword))
+    (tn
+     (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
+    (t nil)))
+
+(defun register-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
+
+(defun sse-register-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'sse-registers)))
+
+(defun accumulator-p (thing)
+  (and (register-p thing)
+       (= (tn-offset thing) 0)))
+\f
+;;;; utilities
+
+(def!constant +operand-size-prefix-byte+ #b01100110)
+
+(defun maybe-emit-operand-size-prefix (segment size)
+  (unless (or (eq size :byte) (eq size +default-operand-size+))
+    (emit-byte segment +operand-size-prefix-byte+)))
+
+(defun operand-size (thing)
+  (typecase thing
+    (tn
+     ;; FIXME: might as well be COND instead of having to use #. readmacro
+     ;; to hack up the code
+     (case (sc-name (tn-sc thing))
+       (#.*dword-sc-names*
+        :dword)
+       (#.*word-sc-names*
+        :word)
+       (#.*byte-sc-names*
+        :byte)
+       ;; added by jrd: float-registers is a separate size (?)
+       (#.*float-sc-names*
+        :float)
+       (#.*double-sc-names*
+        :double)
+       (t
+        (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+    (ea
+     (ea-size thing))
+    (t
+     nil)))
+
+(defun matching-operand-size (dst src)
+  (let ((dst-size (operand-size dst))
+        (src-size (operand-size src)))
+    (if dst-size
+        (if src-size
+            (if (eq dst-size src-size)
+                dst-size
+                (error "size mismatch: ~S is a ~S and ~S is a ~S."
+                       dst dst-size src src-size))
+            dst-size)
+        (if src-size
+            src-size
+            (error "can't tell the size of either ~S or ~S" dst src)))))
+
+(defun emit-sized-immediate (segment size value)
+  (ecase size
+    (:byte
+     (emit-byte segment value))
+    (:word
+     (emit-word segment value))
+    (:dword
+     (emit-dword segment value))))
+\f
+;;;; general data transfer
+
+(define-instruction mov (segment dst src)
+  ;; immediate to register
+  (:printer reg ((op #b1011) (imm nil :type 'imm-data))
+            '(:name :tab reg ", " imm))
+  ;; absolute mem to/from accumulator
+  (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
+            `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+  ;; register to/from register/memory
+  (:printer reg-reg/mem-dir ((op #b100010)))
+  ;; immediate to register/memory
+  (:printer reg/mem-imm ((op '(#b1100011 #b000))))
+
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+            (cond ((integerp src)
+                   (emit-byte-with-reg segment
+                                       (if (eq size :byte)
+                                           #b10110
+                                           #b10111)
+                                       (reg-tn-encoding dst))
+                   (emit-sized-immediate segment size src))
+                  ((and (fixup-p src) (accumulator-p dst))
+                   (emit-byte segment
+                              (if (eq size :byte)
+                                  #b10100000
+                                  #b10100001))
+                   (emit-absolute-fixup segment src))
+                  (t
+                   (emit-byte segment
+                              (if (eq size :byte)
+                                  #b10001010
+                                  #b10001011))
+                   (emit-ea segment src (reg-tn-encoding dst) t))))
+           ((and (fixup-p dst) (accumulator-p src))
+            (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
+            (emit-absolute-fixup segment dst))
+           ((integerp src)
+            (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+            (emit-ea segment dst #b000)
+            (emit-sized-immediate segment size src))
+           ((register-p src)
+            (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+            (emit-ea segment dst (reg-tn-encoding src)))
+           ((fixup-p src)
+            (aver (eq size :dword))
+            (emit-byte segment #b11000111)
+            (emit-ea segment dst #b000)
+            (emit-absolute-fixup segment src))
+           (t
+            (error "bogus arguments to MOV: ~S ~S" dst src))))))
+
+(defun emit-move-with-extension (segment dst src opcode)
+  (aver (register-p dst))
+  (let ((dst-size (operand-size dst))
+        (src-size (operand-size src)))
+    (ecase dst-size
+      (:word
+       (aver (eq src-size :byte))
+       (maybe-emit-operand-size-prefix segment :word)
+       (emit-byte segment #b00001111)
+       (emit-byte segment opcode)
+       (emit-ea segment src (reg-tn-encoding dst)))
+      (:dword
+       (ecase src-size
+         (:byte
+          (maybe-emit-operand-size-prefix segment :dword)
+          (emit-byte segment #b00001111)
+          (emit-byte segment opcode)
+          (emit-ea segment src (reg-tn-encoding dst)))
+         (:word
+          (emit-byte segment #b00001111)
+          (emit-byte segment (logior opcode 1))
+          (emit-ea segment src (reg-tn-encoding dst))))))))
+
+(define-instruction movsx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
+  (:emitter (emit-move-with-extension segment dst src #b10111110)))
+
+(define-instruction movzx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
+  (:emitter (emit-move-with-extension segment dst src #b10110110)))
+
+(define-instruction push (segment src)
+  ;; register
+  (:printer reg-no-width ((op #b01010)))
+  ;; register/memory
+  (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
+  ;; immediate
+  (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
+            '(:name :tab imm))
+  (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
+            '(:name :tab imm))
+  ;; ### segment registers?
+
+  (:emitter
+   (cond ((integerp src)
+          (cond ((<= -128 src 127)
+                 (emit-byte segment #b01101010)
+                 (emit-byte segment src))
+                (t
+                 (emit-byte segment #b01101000)
+                 (emit-dword segment src))))
+         ((fixup-p src)
+          ;; Interpret the fixup as an immediate dword to push.
+          (emit-byte segment #b01101000)
+          (emit-absolute-fixup segment src))
+         (t
+          (let ((size (operand-size src)))
+            (aver (not (eq size :byte)))
+            (maybe-emit-operand-size-prefix segment size)
+            (cond ((register-p src)
+                   (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+                  (t
+                   (emit-byte segment #b11111111)
+                   (emit-ea segment src #b110 t))))))))
+
+(define-instruction pusha (segment)
+  (:printer byte ((op #b01100000)))
+  (:emitter
+   (emit-byte segment #b01100000)))
+
+(define-instruction pop (segment dst)
+  (:printer reg-no-width ((op #b01011)))
+  (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (aver (not (eq size :byte)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+            (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment #b10001111)
+            (emit-ea segment dst #b000))))))
+
+(define-instruction popa (segment)
+  (:printer byte ((op #b01100001)))
+  (:emitter
+   (emit-byte segment #b01100001)))
+
+(define-instruction xchg (segment operand1 operand2)
+  ;; Register with accumulator.
+  (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
+  ;; Register/Memory with Register.
+  (:printer reg-reg/mem ((op #b1000011)))
+  (:emitter
+   (let ((size (matching-operand-size operand1 operand2)))
+     (maybe-emit-operand-size-prefix segment size)
+     (labels ((xchg-acc-with-something (acc something)
+                (if (and (not (eq size :byte)) (register-p something))
+                    (emit-byte-with-reg segment
+                                        #b10010
+                                        (reg-tn-encoding something))
+                    (xchg-reg-with-something acc something)))
+              (xchg-reg-with-something (reg something)
+                (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+                (emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((accumulator-p operand1)
+              (xchg-acc-with-something operand1 operand2))
+             ((accumulator-p operand2)
+              (xchg-acc-with-something operand2 operand1))
+             ((register-p operand1)
+              (xchg-reg-with-something operand1 operand2))
+             ((register-p operand2)
+              (xchg-reg-with-something operand2 operand1))
+             (t
+              (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+
+(define-instruction lea (segment dst src)
+  (:printer reg-reg/mem ((op #b1000110) (width 1)))
+  (:emitter
+   (aver (dword-reg-p dst))
+   (emit-byte segment #b10001101)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cmpxchg (segment dst src)
+  ;; Register/Memory with Register.
+  (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
+  (:emitter
+   (aver (register-p src))
+   (let ((size (matching-operand-size src dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
+     (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+
+(define-instruction fs-segment-prefix (segment)
+  (:emitter
+   (emit-byte segment #x64)))
+
+;;;; flag control instructions
+
+;;; CLC -- Clear Carry Flag.
+(define-instruction clc (segment)
+  (:printer byte ((op #b11111000)))
+  (:emitter
+   (emit-byte segment #b11111000)))
+
+;;; CLD -- Clear Direction Flag.
+(define-instruction cld (segment)
+  (:printer byte ((op #b11111100)))
+  (:emitter
+   (emit-byte segment #b11111100)))
+
+;;; CLI -- Clear Iterrupt Enable Flag.
+(define-instruction cli (segment)
+  (:printer byte ((op #b11111010)))
+  (:emitter
+   (emit-byte segment #b11111010)))
+
+;;; CMC -- Complement Carry Flag.
+(define-instruction cmc (segment)
+  (:printer byte ((op #b11110101)))
+  (:emitter
+   (emit-byte segment #b11110101)))
+
+;;; LAHF -- Load AH into flags.
+(define-instruction lahf (segment)
+  (:printer byte ((op #b10011111)))
+  (:emitter
+   (emit-byte segment #b10011111)))
+
+;;; POPF -- Pop flags.
+(define-instruction popf (segment)
+  (:printer byte ((op #b10011101)))
+  (:emitter
+   (emit-byte segment #b10011101)))
+
+;;; PUSHF -- push flags.
+(define-instruction pushf (segment)
+  (:printer byte ((op #b10011100)))
+  (:emitter
+   (emit-byte segment #b10011100)))
+
+;;; SAHF -- Store AH into flags.
+(define-instruction sahf (segment)
+  (:printer byte ((op #b10011110)))
+  (:emitter
+   (emit-byte segment #b10011110)))
+
+;;; STC -- Set Carry Flag.
+(define-instruction stc (segment)
+  (:printer byte ((op #b11111001)))
+  (:emitter
+   (emit-byte segment #b11111001)))
+
+;;; STD -- Set Direction Flag.
+(define-instruction std (segment)
+  (:printer byte ((op #b11111101)))
+  (:emitter
+   (emit-byte segment #b11111101)))
+
+;;; STI -- Set Interrupt Enable Flag.
+(define-instruction sti (segment)
+  (:printer byte ((op #b11111011)))
+  (:emitter
+   (emit-byte segment #b11111011)))
+\f
+;;;; arithmetic
+
+(defun emit-random-arith-inst (name segment dst src opcode
+                                    &optional allow-constants)
+  (let ((size (matching-operand-size dst src)))
+    (maybe-emit-operand-size-prefix segment size)
+    (cond
+     ((integerp src)
+      (cond ((and (not (eq size :byte)) (<= -128 src 127))
+             (emit-byte segment #b10000011)
+             (emit-ea segment dst opcode allow-constants)
+             (emit-byte segment src))
+            ((accumulator-p dst)
+             (emit-byte segment
+                        (dpb opcode
+                             (byte 3 3)
+                             (if (eq size :byte)
+                                 #b00000100
+                                 #b00000101)))
+             (emit-sized-immediate segment size src))
+            (t
+             (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+             (emit-ea segment dst opcode allow-constants)
+             (emit-sized-immediate segment size src))))
+     ((register-p src)
+      (emit-byte segment
+                 (dpb opcode
+                      (byte 3 3)
+                      (if (eq size :byte) #b00000000 #b00000001)))
+      (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+     ((register-p dst)
+      (emit-byte segment
+                 (dpb opcode
+                      (byte 3 3)
+                      (if (eq size :byte) #b00000010 #b00000011)))
+      (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+     (t
+      (error "bogus operands to ~A" name)))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun arith-inst-printer-list (subop)
+    `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
+      (reg/mem-imm ((op (#b1000000 ,subop))))
+      (reg/mem-imm ((op (#b1000001 ,subop))
+                    (imm nil :type signed-imm-byte)))
+      (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
+  )
+
+(define-instruction add (segment dst src)
+  (:printer-list (arith-inst-printer-list #b000))
+  (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+
+(define-instruction adc (segment dst src)
+  (:printer-list (arith-inst-printer-list #b010))
+  (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
+
+(define-instruction sub (segment dst src)
+  (:printer-list (arith-inst-printer-list #b101))
+  (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
+
+(define-instruction sbb (segment dst src)
+  (:printer-list (arith-inst-printer-list #b011))
+  (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
+
+(define-instruction cmp (segment dst src)
+  (:printer-list (arith-inst-printer-list #b111))
+  (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+
+(define-instruction inc (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01000)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b000))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+            (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+            (emit-ea segment dst #b000))))))
+
+(define-instruction dec (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01001)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b001))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+            (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+           (t
+            (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+            (emit-ea segment dst #b001))))))
+
+(define-instruction neg (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b011))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b011))))
+
+(define-instruction aaa (segment)
+  (:printer byte ((op #b00110111)))
+  (:emitter
+   (emit-byte segment #b00110111)))
+
+(define-instruction aas (segment)
+  (:printer byte ((op #b00111111)))
+  (:emitter
+   (emit-byte segment #b00111111)))
+
+(define-instruction daa (segment)
+  (:printer byte ((op #b00100111)))
+  (:emitter
+   (emit-byte segment #b00100111)))
+
+(define-instruction das (segment)
+  (:printer byte ((op #b00101111)))
+  (:emitter
+   (emit-byte segment #b00101111)))
+
+(define-instruction mul (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b100))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b100))))
+
+(define-instruction imul (segment dst &optional src1 src2)
+  (:printer accum-reg/mem ((op '(#b1111011 #b101))))
+  (:printer ext-reg-reg/mem ((op #b1010111)))
+  (:printer reg-reg/mem ((op #b0110100) (width 1)
+                         (imm nil :type 'signed-imm-word))
+            '(:name :tab reg ", " reg/mem ", " imm))
+  (:printer reg-reg/mem ((op #b0110101) (width 1)
+                         (imm nil :type 'signed-imm-byte))
+            '(:name :tab reg ", " reg/mem ", " imm))
+  (:emitter
+   (flet ((r/m-with-immed-to-reg (reg r/m immed)
+            (let* ((size (matching-operand-size reg r/m))
+                   (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+              (maybe-emit-operand-size-prefix segment size)
+              (emit-byte segment (if sx #b01101011 #b01101001))
+              (emit-ea segment r/m (reg-tn-encoding reg))
+              (if sx
+                  (emit-byte segment immed)
+                  (emit-sized-immediate segment size immed)))))
+     (cond (src2
+            (r/m-with-immed-to-reg dst src1 src2))
+           (src1
+            (if (integerp src1)
+                (r/m-with-immed-to-reg dst dst src1)
+                (let ((size (matching-operand-size dst src1)))
+                  (maybe-emit-operand-size-prefix segment size)
+                  (emit-byte segment #b00001111)
+                  (emit-byte segment #b10101111)
+                  (emit-ea segment src1 (reg-tn-encoding dst)))))
+           (t
+            (let ((size (operand-size dst)))
+              (maybe-emit-operand-size-prefix segment size)
+              (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+              (emit-ea segment dst #b101)))))))
+
+(define-instruction div (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b110))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b110))))
+
+(define-instruction idiv (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b111))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (aver (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b111))))
+
+(define-instruction aad (segment)
+  (:printer two-bytes ((op '(#b11010101 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010101)
+   (emit-byte segment #b00001010)))
+
+(define-instruction aam (segment)
+  (:printer two-bytes ((op '(#b11010100 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010100)
+   (emit-byte segment #b00001010)))
+
+;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
+(define-instruction cbw (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011000)))
+
+;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
+(define-instruction cwde (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011000)))
+
+;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
+(define-instruction cwd (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011001)))
+
+;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
+(define-instruction cdq (segment)
+  (:printer byte ((op #b10011001)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011001)))
+
+(define-instruction xadd (segment dst src)
+  ;; Register/Memory with Register.
+  (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
+  (:emitter
+   (aver (register-p src))
+   (let ((size (matching-operand-size src dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
+     (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+;;;; logic
+
+(defun emit-shift-inst (segment dst amount opcode)
+  (let ((size (operand-size dst)))
+    (maybe-emit-operand-size-prefix segment size)
+    (multiple-value-bind (major-opcode immed)
+        (case amount
+          (:cl (values #b11010010 nil))
+          (1 (values #b11010000 nil))
+          (t (values #b11000000 t)))
+      (emit-byte segment
+                 (if (eq size :byte) major-opcode (logior major-opcode 1)))
+      (emit-ea segment dst opcode)
+      (when immed
+        (emit-byte segment amount)))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun shift-inst-printer-list (subop)
+    `((reg/mem ((op (#b1101000 ,subop)))
+               (:name :tab reg/mem ", 1"))
+      (reg/mem ((op (#b1101001 ,subop)))
+               (:name :tab reg/mem ", " 'cl))
+      (reg/mem-imm ((op (#b1100000 ,subop))
+                    (imm nil :type signed-imm-byte))))))
+
+(define-instruction rol (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b000))
+  (:emitter
+   (emit-shift-inst segment dst amount #b000)))
+
+(define-instruction ror (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b001))
+  (:emitter
+   (emit-shift-inst segment dst amount #b001)))
+
+(define-instruction rcl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b010))
+  (:emitter
+   (emit-shift-inst segment dst amount #b010)))
+
+(define-instruction rcr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b011))
+  (:emitter
+   (emit-shift-inst segment dst amount #b011)))
+
+(define-instruction shl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b100))
+  (:emitter
+   (emit-shift-inst segment dst amount #b100)))
+
+(define-instruction shr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b101))
+  (:emitter
+   (emit-shift-inst segment dst amount #b101)))
+
+(define-instruction sar (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b111))
+  (:emitter
+   (emit-shift-inst segment dst amount #b111)))
+
+(defun emit-double-shift (segment opcode dst src amt)
+  (let ((size (matching-operand-size dst src)))
+    (when (eq size :byte)
+      (error "Double shifts can only be used with words."))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (emit-byte segment (dpb opcode (byte 1 3)
+                            (if (eq amt :cl) #b10100101 #b10100100)))
+    #+nil
+    (emit-ea segment dst src)
+    (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
+    (unless (eq amt :cl)
+      (emit-byte segment amt))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun double-shift-inst-printer-list (op)
+    `(#+nil
+      (ext-reg-reg/mem-imm ((op ,(logior op #b10))
+                            (imm nil :type signed-imm-byte)))
+      (ext-reg-reg/mem ((op ,(logior op #b10)))
+         (:name :tab reg/mem ", " reg ", " 'cl)))))
+
+(define-instruction shld (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b1010000))
+  (:emitter
+   (emit-double-shift segment #b0 dst src amt)))
+
+(define-instruction shrd (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b1010100))
+  (:emitter
+   (emit-double-shift segment #b1 dst src amt)))
+
+(define-instruction and (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b100))
+  (:emitter
+   (emit-random-arith-inst "AND" segment dst src #b100)))
+
+(define-instruction test (segment this that)
+  (:printer accum-imm ((op #b1010100)))
+  (:printer reg/mem-imm ((op '(#b1111011 #b000))))
+  (:printer reg-reg/mem ((op #b1000010)))
+  (:emitter
+   (let ((size (matching-operand-size this that)))
+     (maybe-emit-operand-size-prefix segment size)
+     (flet ((test-immed-and-something (immed something)
+              (cond ((accumulator-p something)
+                     (emit-byte segment
+                                (if (eq size :byte) #b10101000 #b10101001))
+                     (emit-sized-immediate segment size immed))
+                    (t
+                     (emit-byte segment
+                                (if (eq size :byte) #b11110110 #b11110111))
+                     (emit-ea segment something #b000)
+                     (emit-sized-immediate segment size immed))))
+            (test-reg-and-something (reg something)
+              (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+              (emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((integerp that)
+              (test-immed-and-something that this))
+             ((integerp this)
+              (test-immed-and-something this that))
+             ((register-p this)
+              (test-reg-and-something this that))
+             ((register-p that)
+              (test-reg-and-something that this))
+             (t
+              (error "bogus operands for TEST: ~S and ~S" this that)))))))
+
+(define-instruction or (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b001))
+  (:emitter
+   (emit-random-arith-inst "OR" segment dst src #b001)))
+
+(define-instruction xor (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b110))
+  (:emitter
+   (emit-random-arith-inst "XOR" segment dst src #b110)))
+
+(define-instruction not (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b010))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b010))))
+\f
+;;;; string manipulation
+
+(define-instruction cmps (segment size)
+  (:printer string-op ((op #b1010011)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
+
+(define-instruction ins (segment acc)
+  (:printer string-op ((op #b0110110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
+
+(define-instruction lods (segment acc)
+  (:printer string-op ((op #b1010110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
+
+(define-instruction movs (segment size)
+  (:printer string-op ((op #b1010010)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
+
+(define-instruction outs (segment acc)
+  (:printer string-op ((op #b0110111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
+
+(define-instruction scas (segment acc)
+  (:printer string-op ((op #b1010111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
+
+(define-instruction stos (segment acc)
+  (:printer string-op ((op #b1010101)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (aver (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
+
+(define-instruction xlat (segment)
+  (:printer byte ((op #b11010111)))
+  (:emitter
+   (emit-byte segment #b11010111)))
+
+(define-instruction rep (segment)
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+(define-instruction repe (segment)
+  (:printer byte ((op #b11110011)))
+  (:emitter
+   (emit-byte segment #b11110011)))
+
+(define-instruction repne (segment)
+  (:printer byte ((op #b11110010)))
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+\f
+;;;; bit manipulation
+
+(define-instruction bsf (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111100)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(define-instruction bsr (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111101)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(defun emit-bit-test-and-mumble (segment src index opcode)
+  (let ((size (operand-size src)))
+    (when (eq size :byte)
+      (error "can't scan bytes: ~S" src))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (cond ((integerp index)
+           (emit-byte segment #b10111010)
+           (emit-ea segment src opcode)
+           (emit-byte segment index))
+          (t
+           (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+           (emit-ea segment src (reg-tn-encoding index))))))
+
+(eval-when (:compile-toplevel :execute)
+  (defun bit-test-inst-printer-list (subop)
+    `((ext-reg/mem-imm ((op (#b1011101 ,subop))
+                        (reg/mem nil :type word-reg/mem)
+                        (imm nil :type imm-data)
+                        (width 0)))
+      (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
+                        (width 1))
+                       (:name :tab reg/mem ", " reg)))))
+
+(define-instruction bt (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b100))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b100)))
+
+(define-instruction btc (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b111))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b111)))
+
+(define-instruction btr (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b110))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b110)))
+
+(define-instruction bts (segment src index)
+  (:printer-list (bit-test-inst-printer-list #b101))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b101)))
+
+\f
+;;;; control transfer
+
+(define-instruction call (segment where)
+  (:printer near-jump ((op #b11101000)))
+  (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
+  (:emitter
+   (typecase where
+     (label
+      (emit-byte segment #b11101000)
+      (emit-back-patch segment
+                       4
+                       (lambda (segment posn)
+                         (emit-dword segment
+                                     (- (label-position where)
+                                        (+ posn 4))))))
+     (fixup
+      (emit-byte segment #b11101000)
+      (emit-relative-fixup segment where))
+     (t
+      (emit-byte segment #b11111111)
+      (emit-ea segment where #b010)))))
+
+(defun emit-byte-displacement-backpatch (segment target)
+  (emit-back-patch segment
+                   1
+                   (lambda (segment posn)
+                     (let ((disp (- (label-position target) (1+ posn))))
+                       (aver (<= -128 disp 127))
+                       (emit-byte segment disp)))))
+
+(define-instruction jmp (segment cond &optional where)
+  ;; conditional jumps
+  (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
+  (:printer near-cond-jump () '('j cc :tab label))
+  ;; unconditional jumps
+  (:printer short-jump ((op #b1011)))
+  (:printer near-jump ((op #b11101001)) )
+  (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
+  (:emitter
+   (cond (where
+          (emit-chooser
+           segment 6 2
+           (lambda (segment posn delta-if-after)
+             (let ((disp (- (label-position where posn delta-if-after)
+                            (+ posn 2))))
+               (when (<= -128 disp 127)
+                 (emit-byte segment
+                            (dpb (conditional-opcode cond)
+                                 (byte 4 0)
+                                 #b01110000))
+                 (emit-byte-displacement-backpatch segment where)
+                 t)))
+           (lambda (segment posn)
+             (let ((disp (- (label-position where) (+ posn 6))))
+               (emit-byte segment #b00001111)
+               (emit-byte segment
+                          (dpb (conditional-opcode cond)
+                               (byte 4 0)
+                               #b10000000))
+               (emit-dword segment disp)))))
+         ((label-p (setq where cond))
+          (emit-chooser
+           segment 5 0
+           (lambda (segment posn delta-if-after)
+             (let ((disp (- (label-position where posn delta-if-after)
+                            (+ posn 2))))
+               (when (<= -128 disp 127)
+                 (emit-byte segment #b11101011)
+                 (emit-byte-displacement-backpatch segment where)
+                 t)))
+           (lambda (segment posn)
+             (let ((disp (- (label-position where) (+ posn 5))))
+               (emit-byte segment #b11101001)
+               (emit-dword segment disp)))))
+         ((fixup-p where)
+          (emit-byte segment #b11101001)
+          (emit-relative-fixup segment where))
+         (t
+          (unless (or (ea-p where) (tn-p where))
+                  (error "don't know what to do with ~A" where))
+          (emit-byte segment #b11111111)
+          (emit-ea segment where #b100)))))
+
+(define-instruction jmp-short (segment label)
+  (:emitter
+   (emit-byte segment #b11101011)
+   (emit-byte-displacement-backpatch segment label)))
+
+(define-instruction ret (segment &optional stack-delta)
+  (:printer byte ((op #b11000011)))
+  (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
+            '(:name :tab imm))
+  (:emitter
+   (cond (stack-delta
+          (emit-byte segment #b11000010)
+          (emit-word segment stack-delta))
+         (t
+          (emit-byte segment #b11000011)))))
+
+(define-instruction jecxz (segment target)
+  (:printer short-jump ((op #b0011)))
+  (:emitter
+   (emit-byte segment #b11100011)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loop (segment target)
+  (:printer short-jump ((op #b0010)))
+  (:emitter
+   (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopz (segment target)
+  (:printer short-jump ((op #b0001)))
+  (:emitter
+   (emit-byte segment #b11100001)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopnz (segment target)
+  (:printer short-jump ((op #b0000)))
+  (:emitter
+   (emit-byte segment #b11100000)
+   (emit-byte-displacement-backpatch segment target)))
+\f
+;;;; conditional move
+(define-instruction cmov (segment cond dst src)
+  (:printer cond-move ())
+  (:emitter
+   (aver (register-p dst))
+   (let ((size (matching-operand-size dst src)))
+     (aver (or (eq size :word) (eq size :dword)))
+     (maybe-emit-operand-size-prefix segment size))
+   (emit-byte segment #b00001111)
+   (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+;;;; conditional byte set
+
+(define-instruction set (segment dst cond)
+  (:printer cond-set ())
+  (:emitter
+   (emit-byte segment #b00001111)
+   (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
+   (emit-ea segment dst #b000)))
+\f
+;;;; enter/leave
+
+(define-instruction enter (segment disp &optional (level 0))
+  (:declare (type (unsigned-byte 16) disp)
+            (type (unsigned-byte 8) level))
+  (:printer enter-format ((op #b11001000)))
+  (:emitter
+   (emit-byte segment #b11001000)
+   (emit-word segment disp)
+   (emit-byte segment level)))
+
+(define-instruction leave (segment)
+  (:printer byte ((op #b11001001)))
+  (:emitter
+   (emit-byte segment #b11001001)))
+\f
+;;;; prefetch
+(define-instruction prefetchnta (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b000)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b000)))
+
+(define-instruction prefetcht0 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b001)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b001)))
+
+(define-instruction prefetcht1 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b010)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b010)))
+
+(define-instruction prefetcht2 (segment ea)
+  (:printer prefetch ((op #b00011000) (reg #b011)))
+  (:emitter
+   (aver (typep ea 'ea))
+   (aver (eq :byte (ea-size ea)))
+   (emit-byte segment #b00001111)
+   (emit-byte segment #b00011000)
+   (emit-ea segment ea #b011)))
+\f
+;;;; interrupt instructions
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (sb!sys:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type sb!sys: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
+           (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+                                                vector 0 length)
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (sb!c:read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (sb!c:read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+#|
+(defmacro break-cases (breaknum &body cases)
+  (let ((bn-temp (gensym)))
+    (collect ((clauses))
+      (dolist (case cases)
+        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+      `(let ((,bn-temp ,breaknum))
+         (cond ,@(clauses))))))
+|#
+
+(defun break-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
+    ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
+    ;; map has it undefined; and it should be easier to look in the target
+    ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
+    ;; from first principles whether it's defined in some way that genesis
+    ;; can't grok.
+    (case (byte-imm-code chunk dstate)
+      (#.error-trap
+       (nt "error trap")
+       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.cerror-trap
+       (nt "cerror trap")
+       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.breakpoint-trap
+       (nt "breakpoint trap"))
+      (#.pending-interrupt-trap
+       (nt "pending interrupt trap"))
+      (#.halt-trap
+       (nt "halt trap"))
+      (#.fun-end-breakpoint-trap
+       (nt "function end breakpoint trap")))))
+
+(define-instruction break (segment code)
+  (:declare (type (unsigned-byte 8) code))
+  (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+            :control #'break-control)
+  (:emitter
+   (emit-byte segment #b11001100)
+   (emit-byte segment code)))
+
+(define-instruction int (segment number)
+  (:declare (type (unsigned-byte 8) number))
+  (:printer byte-imm ((op #b11001101)))
+  (:emitter
+   (etypecase number
+     ((member 3)
+      (emit-byte segment #b11001100))
+     ((unsigned-byte 8)
+      (emit-byte segment #b11001101)
+      (emit-byte segment number)))))
+
+(define-instruction into (segment)
+  (:printer byte ((op #b11001110)))
+  (:emitter
+   (emit-byte segment #b11001110)))
+
+(define-instruction bound (segment reg bounds)
+  (:emitter
+   (let ((size (matching-operand-size reg bounds)))
+     (when (eq size :byte)
+       (error "can't bounds-test bytes: ~S" reg))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b01100010)
+     (emit-ea segment bounds (reg-tn-encoding reg)))))
+
+(define-instruction iret (segment)
+  (:printer byte ((op #b11001111)))
+  (:emitter
+   (emit-byte segment #b11001111)))
+\f
+;;;; processor control
+
+(define-instruction hlt (segment)
+  (:printer byte ((op #b11110100)))
+  (:emitter
+   (emit-byte segment #b11110100)))
+
+(define-instruction nop (segment)
+  (:printer byte ((op #b10010000)))
+  (:emitter
+   (emit-byte segment #b10010000)))
+
+(define-instruction wait (segment)
+  (:printer byte ((op #b10011011)))
+  (:emitter
+   (emit-byte segment #b10011011)))
+
+(define-instruction lock (segment)
+  (:printer byte ((op #b11110000)))
+  (:emitter
+   (emit-byte segment #b11110000)))
+\f
+;;;; miscellaneous hackery
+
+(define-instruction byte (segment byte)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-instruction word (segment word)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction dword (segment dword)
+  (:emitter
+   (emit-dword segment dword)))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch segment
+                   4
+                   (lambda (segment posn)
+                     (emit-dword segment
+                                 (logior type
+                                         (ash (+ posn
+                                                 (component-header-length))
+                                              (- n-widetag-bits
+                                                 word-shift)))))))
+
+(define-instruction simple-fun-header-word (segment)
+  (:emitter
+   (emit-header-data segment simple-fun-header-widetag)))
+
+(define-instruction lra-header-word (segment)
+  (:emitter
+   (emit-header-data segment return-pc-header-widetag)))
+\f
+
+;;;; SSE instructions
+;;;; 
+;;;; Automatically generated
+
+
+(DEFINE-INSTRUCTION ADDPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 88)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION ADDSUBPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 242)
+                              (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 208)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION ANDNPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 85)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION ANDPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 84)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION DIVPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 94)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION MAXPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 95)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION MINPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 93)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION MULPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 89)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION ORPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 86)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION RCPPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 83)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION RSQRTPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 82)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION SQRTPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 81)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION SUBPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 92)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+(DEFINE-INSTRUCTION XORPS
+                    (SEGMENT DST SRC)
+                    (:EMITTER (EMIT-BYTE SEGMENT 15)
+                              (EMIT-BYTE SEGMENT 87)
+                              (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST))))
+
+;;; SSE MOVE
+
+(DEFINE-INSTRUCTION MOVUPS (SEGMENT DST SRC)
+  (:EMITTER
+   (COND
+     ((SSE-REGISTER-P DST) 
+      (EMIT-BYTE SEGMENT 15)
+      (EMIT-BYTE SEGMENT 16)
+      (EMIT-EA SEGMENT SRC (REG-TN-ENCODING DST)))
+     (T (EMIT-BYTE SEGMENT 15)
+       (EMIT-BYTE SEGMENT 17)
+       (EMIT-EA SEGMENT DST (REG-TN-ENCODING SRC))))))
+
+
+;;; CPUID
+
+
+(define-instruction cpuid (segment)
+  (:emitter
+   (emit-byte segment #x0F)
+   (emit-byte segment #xA2)))
+
+    
+
+
+
+;;;; fp instructions
+;;;;
+;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
+;;;;
+;;;; Note: We treat the single-precision and double-precision variants
+;;;; as separate instructions.
+
+;;; Load single to st(0).
+(define-instruction fld (segment source)
+  (:printer floating-point ((op '(#b001 #b000))))
+  (:emitter
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b000)))
+
+;;; Load double to st(0).
+(define-instruction fldd (segment source)
+  (:printer floating-point ((op '(#b101 #b000))))
+  (:printer floating-point-fp ((op '(#b001 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011001)
+     (emit-byte segment #b11011101))
+    (emit-fp-op segment source #b000)))
+
+;;; Load long to st(0).
+(define-instruction fldl (segment source)
+  (:printer floating-point ((op '(#b011 #b101))))
+  (:emitter
+    (emit-byte segment #b11011011)
+    (emit-fp-op segment source #b101)))
+
+;;; Store single from st(0).
+(define-instruction fst (segment dest)
+  (:printer floating-point ((op '(#b001 #b010))))
+  (:emitter
+    (cond ((fp-reg-tn-p dest)
+           (emit-byte segment #b11011101)
+           (emit-fp-op segment dest #b010))
+          (t
+           (emit-byte segment #b11011001)
+           (emit-fp-op segment dest #b010)))))
+
+;;; Store double from st(0).
+(define-instruction fstd (segment dest)
+  (:printer floating-point ((op '(#b101 #b010))))
+  (:printer floating-point-fp ((op '(#b101 #b010))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b010))
+         (t
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b010)))))
+
+;;; Arithmetic ops are all done with at least one operand at top of
+;;; stack. The other operand is is another register or a 32/64 bit
+;;; memory loc.
+
+;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
+;;; that these conflict with the Gdb conventions for binops. To reduce
+;;; the confusion I've added comments showing the mathamatical
+;;; operation and the two syntaxes. By the ASM386 convention the
+;;; instruction syntax is:
+;;;
+;;;      Fop Source
+;;; or   Fop Destination, Source
+;;;
+;;; If only one operand is given then it is the source and the
+;;; destination is ST(0). There are reversed forms of the fsub and
+;;; fdiv instructions inducated by an 'R' suffix.
+;;;
+;;; The mathematical operation for the non-reverse form is always:
+;;;     destination = destination op source
+;;;
+;;; For the reversed form it is:
+;;;     destination = source op destination
+;;;
+;;; The instructions below only accept one operand at present which is
+;;; usually the source. I've hack in extra instructions to implement
+;;; the fops with a ST(i) destination, these have a -sti suffix and
+;;; the operand is the destination with the source being ST(0).
+
+;;; Add single:
+;;;   st(0) = st(0) + memory or st(i).
+(define-instruction fadd (segment source)
+  (:printer floating-point ((op '(#b000 #b000))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b000)))
+
+;;; Add double:
+;;;   st(0) = st(0) + memory or st(i).
+(define-instruction faddd (segment source)
+  (:printer floating-point ((op '(#b100 #b000))))
+  (:printer floating-point-fp ((op '(#b000 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b000)))
+
+;;; Add double destination st(i):
+;;;   st(i) = st(0) + st(i).
+(define-instruction fadd-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b000))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b000)))
+;;; with pop
+(define-instruction faddp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b000))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b000)))
+
+;;; Subtract single:
+;;;   st(0) = st(0) - memory or st(i).
+(define-instruction fsub (segment source)
+  (:printer floating-point ((op '(#b000 #b100))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b100)))
+
+;;; Subtract single, reverse:
+;;;   st(0) = memory or st(i) - st(0).
+(define-instruction fsubr (segment source)
+  (:printer floating-point ((op '(#b000 #b101))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b101)))
+
+;;; Subtract double:
+;;;   st(0) = st(0) - memory or st(i).
+(define-instruction fsubd (segment source)
+  (:printer floating-point ((op '(#b100 #b100))))
+  (:printer floating-point-fp ((op '(#b000 #b100))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b100)))
+
+;;; Subtract double, reverse:
+;;;   st(0) = memory or st(i) - st(0).
+(define-instruction fsubrd (segment source)
+  (:printer floating-point ((op '(#b100 #b101))))
+  (:printer floating-point-fp ((op '(#b000 #b101))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b101)))
+
+;;; Subtract double, destination st(i):
+;;;   st(i) = st(i) - st(0).
+;;;
+;;; ASM386 syntax: FSUB ST(i), ST
+;;; Gdb    syntax: fsubr %st,%st(i)
+(define-instruction fsub-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b101))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b101)))
+;;; with a pop
+(define-instruction fsubp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b101))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b101)))
+
+;;; Subtract double, reverse, destination st(i):
+;;;   st(i) = st(0) - st(i).
+;;;
+;;; ASM386 syntax: FSUBR ST(i), ST
+;;; Gdb    syntax: fsub %st,%st(i)
+(define-instruction fsubr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b100)))
+;;; with a pop
+(define-instruction fsubrp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b100)))
+
+;;; Multiply single:
+;;;   st(0) = st(0) * memory or st(i).
+(define-instruction fmul (segment source)
+  (:printer floating-point ((op '(#b000 #b001))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b001)))
+
+;;; Multiply double:
+;;;   st(0) = st(0) * memory or st(i).
+(define-instruction fmuld (segment source)
+  (:printer floating-point ((op '(#b100 #b001))))
+  (:printer floating-point-fp ((op '(#b000 #b001))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b001)))
+
+;;; Multiply double, destination st(i):
+;;;   st(i) = st(i) * st(0).
+(define-instruction fmul-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b001))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b001)))
+
+;;; Divide single:
+;;;   st(0) = st(0) / memory or st(i).
+(define-instruction fdiv (segment source)
+  (:printer floating-point ((op '(#b000 #b110))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b110)))
+
+;;; Divide single, reverse:
+;;;   st(0) = memory or st(i) / st(0).
+(define-instruction fdivr (segment source)
+  (:printer floating-point ((op '(#b000 #b111))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b111)))
+
+;;; Divide double:
+;;;   st(0) = st(0) / memory or st(i).
+(define-instruction fdivd (segment source)
+  (:printer floating-point ((op '(#b100 #b110))))
+  (:printer floating-point-fp ((op '(#b000 #b110))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b110)))
+
+;;; Divide double, reverse:
+;;;   st(0) = memory or st(i) / st(0).
+(define-instruction fdivrd (segment source)
+  (:printer floating-point ((op '(#b100 #b111))))
+  (:printer floating-point-fp ((op '(#b000 #b111))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b111)))
+
+;;; Divide double, destination st(i):
+;;;   st(i) = st(i) / st(0).
+;;;
+;;; ASM386 syntax: FDIV ST(i), ST
+;;; Gdb    syntax: fdivr %st,%st(i)
+(define-instruction fdiv-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b111))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b111)))
+
+;;; Divide double, reverse, destination st(i):
+;;;   st(i) = st(0) / st(i).
+;;;
+;;; ASM386 syntax: FDIVR ST(i), ST
+;;; Gdb    syntax: fdiv %st,%st(i)
+(define-instruction fdivr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b110))))
+  (:emitter
+   (aver (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b110)))
+
+;;; Exchange fr0 with fr(n). (There is no double precision variant.)
+(define-instruction fxch (segment source)
+  (:printer floating-point-fp ((op '(#b001 #b001))))
+  (:emitter
+    (unless (and (tn-p source)
+                 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+      (cl:break))
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b001)))
+
+;;; Push 32-bit integer to st0.
+(define-instruction fild (segment source)
+  (:printer floating-point ((op '(#b011 #b000))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment source #b000)))
+
+;;; Push 64-bit integer to st0.
+(define-instruction fildl (segment source)
+  (:printer floating-point ((op '(#b111 #b101))))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-fp-op segment source #b101)))
+
+;;; Store 32-bit integer.
+(define-instruction fist (segment dest)
+  (:printer floating-point ((op '(#b011 #b010))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b010)))
+
+;;; Store and pop 32-bit integer.
+(define-instruction fistp (segment dest)
+  (:printer floating-point ((op '(#b011 #b011))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b011)))
+
+;;; Store and pop 64-bit integer.
+(define-instruction fistpl (segment dest)
+  (:printer floating-point ((op '(#b111 #b111))))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-fp-op segment dest #b111)))
+
+;;; Store single from st(0) and pop.
+(define-instruction fstp (segment dest)
+  (:printer floating-point ((op '(#b001 #b011))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011))
+         (t
+          (emit-byte segment #b11011001)
+          (emit-fp-op segment dest #b011)))))
+
+;;; Store double from st(0) and pop.
+(define-instruction fstpd (segment dest)
+  (:printer floating-point ((op '(#b101 #b011))))
+  (:printer floating-point-fp ((op '(#b101 #b011))))
+  (:emitter
+   (cond ((fp-reg-tn-p dest)
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011))
+         (t
+          (emit-byte segment #b11011101)
+          (emit-fp-op segment dest #b011)))))
+
+;;; Store long from st(0) and pop.
+(define-instruction fstpl (segment dest)
+  (:printer floating-point ((op '(#b011 #b111))))
+  (:emitter
+    (emit-byte segment #b11011011)
+    (emit-fp-op segment dest #b111)))
+
+;;; Decrement stack-top pointer.
+(define-instruction fdecstp (segment)
+  (:printer floating-point-no ((op #b10110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110110)))
+
+;;; Increment stack-top pointer.
+(define-instruction fincstp (segment)
+  (:printer floating-point-no ((op #b10111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110111)))
+
+;;; Free fp register.
+(define-instruction ffree (segment dest)
+  (:printer floating-point-fp ((op '(#b101 #b000))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dest #b000)))
+
+(define-instruction fabs (segment)
+  (:printer floating-point-no ((op #b00001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100001)))
+
+(define-instruction fchs (segment)
+  (:printer floating-point-no ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100000)))
+
+(define-instruction frndint(segment)
+  (:printer floating-point-no ((op #b11100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111100)))
+
+;;; Initialize NPX.
+(define-instruction fninit(segment)
+  (:printer floating-point-5 ((op #b00011)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100011)))
+
+;;; Store Status Word to AX.
+(define-instruction fnstsw(segment)
+  (:printer floating-point-st ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-byte segment #b11100000)))
+
+;;; Load Control Word.
+;;;
+;;; src must be a memory location
+(define-instruction fldcw(segment src)
+  (:printer floating-point ((op '(#b001 #b101))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b101)))
+
+;;; Store Control Word.
+(define-instruction fnstcw(segment dst)
+  (:printer floating-point ((op '(#b001 #b111))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b111)))
+
+;;; Store FP Environment.
+(define-instruction fstenv(segment dst)
+  (:printer floating-point ((op '(#b001 #b110))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b110)))
+
+;;; Restore FP Environment.
+(define-instruction fldenv(segment src)
+  (:printer floating-point ((op '(#b001 #b100))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b100)))
+
+;;; Save FP State.
+(define-instruction fsave(segment dst)
+  (:printer floating-point ((op '(#b101 #b110))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dst #b110)))
+
+;;; Restore FP State.
+(define-instruction frstor(segment src)
+  (:printer floating-point ((op '(#b101 #b100))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+
+;;; Clear exceptions.
+(define-instruction fnclex(segment)
+  (:printer floating-point-5 ((op #b00010)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100010)))
+
+;;; comparison
+(define-instruction fcom (segment src)
+  (:printer floating-point ((op '(#b000 #b010))))
+  (:emitter
+   (emit-byte segment #b11011000)
+   (emit-fp-op segment src #b010)))
+
+(define-instruction fcomd (segment src)
+  (:printer floating-point ((op '(#b100 #b010))))
+  (:printer floating-point-fp ((op '(#b000 #b010))))
+  (:emitter
+   (if (fp-reg-tn-p src)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment src #b010)))
+
+;;; Compare ST1 to ST0, popping the stack twice.
+(define-instruction fcompp (segment)
+  (:printer floating-point-3 ((op '(#b110 #b011001))))
+  (:emitter
+   (emit-byte segment #b11011110)
+   (emit-byte segment #b11011001)))
+
+;;; unordered comparison
+(define-instruction fucom (segment src)
+  (:printer floating-point-fp ((op '(#b101 #b100))))
+  (:emitter
+   (aver (fp-reg-tn-p src))
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+
+(define-instruction ftst (segment)
+  (:printer floating-point-no ((op #b00100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100100)))
+
+;;;; 80387 specials
+
+(define-instruction fsqrt(segment)
+  (:printer floating-point-no ((op #b11010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111010)))
+
+(define-instruction fscale(segment)
+  (:printer floating-point-no ((op #b11101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111101)))
+
+(define-instruction fxtract(segment)
+  (:printer floating-point-no ((op #b10100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110100)))
+
+(define-instruction fsin(segment)
+  (:printer floating-point-no ((op #b11110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111110)))
+
+(define-instruction fcos(segment)
+  (:printer floating-point-no ((op #b11111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111111)))
+
+(define-instruction fprem1(segment)
+  (:printer floating-point-no ((op #b10101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110101)))
+
+(define-instruction fprem(segment)
+  (:printer floating-point-no ((op #b11000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111000)))
+
+(define-instruction fxam (segment)
+  (:printer floating-point-no ((op #b00101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100101)))
+
+;;; These do push/pop to stack and need special handling
+;;; in any VOPs that use them. See the book.
+
+;;; st0 <- st1*log2(st0)
+(define-instruction fyl2x(segment)      ; pops stack
+  (:printer floating-point-no ((op #b10001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110001)))
+
+(define-instruction fyl2xp1(segment)
+  (:printer floating-point-no ((op #b11001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111001)))
+
+(define-instruction f2xm1(segment)
+  (:printer floating-point-no ((op #b10000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110000)))
+
+(define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
+  (:printer floating-point-no ((op #b10010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110010)))
+
+(define-instruction fpatan(segment)     ; POPS STACK
+  (:printer floating-point-no ((op #b10011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110011)))
+
+;;;; loading constants
+
+(define-instruction fldz(segment)
+  (:printer floating-point-no ((op #b01110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101110)))
+
+(define-instruction fld1(segment)
+  (:printer floating-point-no ((op #b01000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101000)))
+
+(define-instruction fldpi(segment)
+  (:printer floating-point-no ((op #b01011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101011)))
+
+(define-instruction fldl2t(segment)
+  (:printer floating-point-no ((op #b01001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101001)))
+
+(define-instruction fldl2e(segment)
+  (:printer floating-point-no ((op #b01010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101010)))
+
+(define-instruction fldlg2(segment)
+  (:printer floating-point-no ((op #b01100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101100)))
+
+(define-instruction fldln2(segment)
+  (:printer floating-point-no ((op #b01101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101101)))
diff --git a/sbcl-src/src/compiler/x86/vm.lisp b/sbcl-src/src/compiler/x86/vm.lisp
new file mode 100644 (file)
index 0000000..1bab6a3
--- /dev/null
@@ -0,0 +1,469 @@
+;;;; miscellaneous VM definition noise for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+;;; the size of an INTEGER representation of a SYSTEM-AREA-POINTER, i.e.
+;;; size of a native memory address
+(deftype sap-int () '(unsigned-byte 32))
+\f
+;;;; register specs
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *byte-register-names* (make-array 8 :initial-element nil))
+  (defvar *word-register-names* (make-array 16 :initial-element nil))
+  (defvar *dword-register-names* (make-array 16 :initial-element nil))
+  (defvar *float-register-names* (make-array 8 :initial-element nil))
+  (defvar *dqword-register-names* (make-array 8 :initial-element nil)))
+
+(macrolet ((defreg (name offset size)
+             (let ((offset-sym (symbolicate name "-OFFSET"))
+                   (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+               `(progn
+                  (eval-when (:compile-toplevel :load-toplevel :execute)
+                    ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
+                    ;; (in the same file) depends on compile-time evaluation
+                    ;; of the DEFCONSTANT. -- AL 20010224
+                    (def!constant ,offset-sym ,offset))
+                  (setf (svref ,names-vector ,offset-sym)
+                        ,(symbol-name name)))))
+           ;; FIXME: It looks to me as though DEFREGSET should also
+           ;; define the related *FOO-REGISTER-NAMES* variable.
+           (defregset (name &rest regs)
+             `(eval-when (:compile-toplevel :load-toplevel :execute)
+                (defparameter ,name
+                  (list ,@(mapcar (lambda (name)
+                                    (symbolicate name "-OFFSET"))
+                                  regs))))))
+
+  ;; byte registers
+  ;;
+  ;; Note: the encoding here is different than that used by the chip.
+  ;; We use this encoding so that the compiler thinks that AX (and
+  ;; EAX) overlap AL and AH instead of AL and CL.
+  (defreg al 0 :byte)
+  (defreg ah 1 :byte)
+  (defreg cl 2 :byte)
+  (defreg ch 3 :byte)
+  (defreg dl 4 :byte)
+  (defreg dh 5 :byte)
+  (defreg bl 6 :byte)
+  (defreg bh 7 :byte)
+  (defregset *byte-regs* al ah cl ch dl dh bl bh)
+
+  ;; word registers
+  (defreg ax 0 :word)
+  (defreg cx 2 :word)
+  (defreg dx 4 :word)
+  (defreg bx 6 :word)
+  (defreg sp 8 :word)
+  (defreg bp 10 :word)
+  (defreg si 12 :word)
+  (defreg di 14 :word)
+  (defregset *word-regs* ax cx dx bx si di)
+
+  ;; double word registers
+  (defreg eax 0 :dword)
+  (defreg ecx 2 :dword)
+  (defreg edx 4 :dword)
+  (defreg ebx 6 :dword)
+  (defreg esp 8 :dword)
+  (defreg ebp 10 :dword)
+  (defreg esi 12 :dword)
+  (defreg edi 14 :dword)
+  (defregset *dword-regs* eax ecx edx ebx esi edi)
+
+  ;; floating point registers
+  (defreg fr0 0 :float)
+  (defreg fr1 1 :float)
+  (defreg fr2 2 :float)
+  (defreg fr3 3 :float)
+  (defreg fr4 4 :float)
+  (defreg fr5 5 :float)
+  (defreg fr6 6 :float)
+  (defreg fr7 7 :float)
+  (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+  ;; sse registers
+  (defreg xmm0 0 :dqword)
+  (defreg xmm1 1 :dqword)
+  (defreg xmm2 2 :dqword)
+  (defreg xmm3 3 :dqword)
+  (defreg xmm4 4 :dqword)
+  (defreg xmm5 5 :dqword)
+  (defreg xmm6 6 :dqword)
+  (defreg xmm7 7 :dqword)
+  (defregset *sse-regs* xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7)
+  
+  ;; registers used to pass arguments
+  ;;
+  ;; the number of arguments/return values passed in registers
+  (def!constant  register-arg-count 3)
+  ;; names and offsets for registers used to pass arguments
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (defparameter *register-arg-names* '(edx edi esi)))
+  (defregset    *register-arg-offsets* edx edi esi))
+\f
+;;;; SB definitions
+
+;;; Despite the fact that there are only 8 different registers, we consider
+;;; them 16 in order to describe the overlap of byte registers. The only
+;;; thing we need to represent is what registers overlap. Therefore, we
+;;; consider bytes to take one unit, and words or dwords to take two. We
+;;; don't need to tell the difference between words and dwords, because
+;;; you can't put two words in a dword register.
+(define-storage-base registers :finite :size 16)
+
+;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
+;;; sense to use the 387's idea of a stack; 8 separate registers is easier
+;;; to deal with.
+;;; the old way:
+;;;   (define-storage-base float-registers :finite :size 1)
+;;; the new way:
+(define-storage-base float-registers :finite :size 8)
+
+(define-storage-base sse-registers :finite :size 8)
+
+(define-storage-base stack :unbounded :size 8)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+(define-storage-base noise :unbounded :size 2)
+\f
+;;;; SC definitions
+
+;;; a handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class
+;;;
+(defmacro !define-storage-classes (&rest classes)
+  (collect ((forms))
+    (let ((index 0))
+      (dolist (class classes)
+        (let* ((sc-name (car class))
+               (constant-name (symbolicate sc-name "-SC-NUMBER")))
+          (forms `(define-storage-class ,sc-name ,index
+                    ,@(cdr class)))
+          (forms `(def!constant ,constant-name ,index))
+          (incf index))))
+    `(progn
+       ,@(forms))))
+
+;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size
+;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until
+;;; later in the build process, and the calculation is entangled with
+;;; code which has lots of predependencies, including dependencies on
+;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to
+;;; unscramble this would be to untangle the code, so that the code
+;;; which calculates the size of CATCH-BLOCK can be separated from the
+;;; other lots-of-dependencies code, so that the code which calculates
+;;; the size of CATCH-BLOCK can be executed early, so that this value
+;;; is known properly at this point in compilation. However, that
+;;; would be a lot of editing of code that I (WHN 19990131) can't test
+;;; until the project is complete. So instead, I set the correct value
+;;; by hand here (a sort of nondeterministic guess of the right
+;;; answer:-) and add an assertion later, after the value is
+;;; calculated, that the original guess was correct.
+;;;
+;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess
+;;; has my gratitude.) (FIXME: Maybe this should be me..)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def!constant kludge-nondeterministic-catch-block-size 6))
+
+(!define-storage-classes
+
+  ;; non-immediate constants in the constant pool
+  (constant constant)
+
+  ;; some FP constants can be generated in the i387 silicon
+  (fp-constant immediate-constant)
+
+  (immediate immediate-constant)
+
+  ;;
+  ;; the stacks
+  ;;
+
+  ;; the control stack
+  (control-stack stack)                 ; may be pointers, scanned by GC
+
+  ;; the non-descriptor stacks
+  (signed-stack stack)                  ; (signed-byte 32)
+  (unsigned-stack stack)                ; (unsigned-byte 32)
+  (character-stack stack)               ; non-descriptor characters.
+  (sap-stack stack)                     ; System area pointers.
+  (single-stack stack)                  ; single-floats
+  (double-stack stack :element-size 2)  ; double-floats.
+  #!+long-float
+  (long-stack stack :element-size 3)    ; long-floats.
+  (complex-single-stack stack :element-size 2)  ; complex-single-floats
+  (complex-double-stack stack :element-size 4)  ; complex-double-floats
+  #!+long-float
+  (complex-long-stack stack :element-size 6)    ; complex-long-floats
+
+  ;;
+  ;; magic SCs
+  ;;
+
+  (ignore-me noise)
+
+  ;;
+  ;; things that can go in the integer registers
+  ;;
+
+  ;; On the X86, we don't have to distinguish between descriptor and
+  ;; non-descriptor registers, because of the conservative GC.
+  ;; Therefore, we use different scs only to distinguish between
+  ;; descriptor and non-descriptor values and to specify size.
+
+  ;; immediate descriptor objects. Don't have to be seen by GC, but nothing
+  ;; bad will happen if they are. (fixnums, characters, header values, etc).
+  (any-reg registers
+           :locations #.*dword-regs*
+           :element-size 2
+;          :reserve-locations (#.eax-offset)
+           :constant-scs (immediate)
+           :save-p t
+           :alternate-scs (control-stack))
+
+  ;; pointer descriptor objects -- must be seen by GC
+  (descriptor-reg registers
+                  :locations #.*dword-regs*
+                  :element-size 2
+;                 :reserve-locations (#.eax-offset)
+                  :constant-scs (constant immediate)
+                  :save-p t
+                  :alternate-scs (control-stack))
+
+  ;; non-descriptor characters
+  (character-reg registers
+                 :locations #!-sb-unicode #.*byte-regs*
+                            #!+sb-unicode #.*dword-regs*
+                 #!-sb-unicode #!-sb-unicode
+                 :reserve-locations (#.ah-offset #.al-offset)
+                 :constant-scs (immediate)
+                 :save-p t
+                 :alternate-scs (character-stack))
+
+  ;; non-descriptor SAPs (arbitrary pointers into address space)
+  (sap-reg registers
+           :locations #.*dword-regs*
+           :element-size 2
+;          :reserve-locations (#.eax-offset)
+           :constant-scs (immediate)
+           :save-p t
+           :alternate-scs (sap-stack))
+
+  ;; non-descriptor (signed or unsigned) numbers
+  (signed-reg registers
+              :locations #.*dword-regs*
+              :element-size 2
+;             :reserve-locations (#.eax-offset)
+              :constant-scs (immediate)
+              :save-p t
+              :alternate-scs (signed-stack))
+  (unsigned-reg registers
+                :locations #.*dword-regs*
+                :element-size 2
+;               :reserve-locations (#.eax-offset)
+                :constant-scs (immediate)
+                :save-p t
+                :alternate-scs (unsigned-stack))
+
+  ;; miscellaneous objects that must not be seen by GC. Used only as
+  ;; temporaries.
+  (word-reg registers
+            :locations #.*word-regs*
+            :element-size 2
+;           :reserve-locations (#.ax-offset)
+            )
+  (byte-reg registers
+            :locations #.*byte-regs*
+;           :reserve-locations (#.al-offset #.ah-offset)
+            )
+
+  ;; that can go in the floating point registers
+
+  ;; non-descriptor SINGLE-FLOATs
+  (single-reg float-registers
+              :locations (0 1 2 3 4 5 6 7)
+              :constant-scs (fp-constant)
+              :save-p t
+              :alternate-scs (single-stack))
+
+  ;; non-descriptor DOUBLE-FLOATs
+  (double-reg float-registers
+              :locations (0 1 2 3 4 5 6 7)
+              :constant-scs (fp-constant)
+              :save-p t
+              :alternate-scs (double-stack))
+
+  ;; non-descriptor LONG-FLOATs
+  #!+long-float
+  (long-reg float-registers
+            :locations (0 1 2 3 4 5 6 7)
+            :constant-scs (fp-constant)
+            :save-p t
+            :alternate-scs (long-stack))
+
+  (complex-single-reg float-registers
+                      :locations (0 2 4 6)
+                      :element-size 2
+                      :constant-scs ()
+                      :save-p t
+                      :alternate-scs (complex-single-stack))
+
+  (complex-double-reg float-registers
+                      :locations (0 2 4 6)
+                      :element-size 2
+                      :constant-scs ()
+                      :save-p t
+                      :alternate-scs (complex-double-stack))
+
+  #!+long-float
+  (complex-long-reg float-registers
+                    :locations (0 2 4 6)
+                    :element-size 2
+                    :constant-scs ()
+                    :save-p t
+                    :alternate-scs (complex-long-stack))
+
+  (sse-reg sse-registers
+          :locations #.*sse-regs*)
+  ;; a catch or unwind block
+  (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *byte-sc-names*
+  '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
+(defparameter *word-sc-names* '(word-reg))
+(defparameter *dword-sc-names*
+  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
+    signed-stack unsigned-stack sap-stack single-stack
+    #!+sb-unicode character-reg #!+sb-unicode character-stack constant))
+;;; added by jrd. I guess the right thing to do is to treat floats
+;;; as a separate size...
+;;;
+;;; These are used to (at least) determine operand size.
+(defparameter *float-sc-names* '(single-reg))
+(defparameter *double-sc-names* '(double-reg double-stack))
+(defparameter *dqword-sc-names* '(sse-reg))
+) ; EVAL-WHEN
+\f
+;;;; miscellaneous TNs for the various registers
+
+(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
+             (collect ((forms))
+                      (dolist (reg-name reg-names)
+                        (let ((tn-name (symbolicate reg-name "-TN"))
+                              (offset-name (symbolicate reg-name "-OFFSET")))
+                          ;; FIXME: It'd be good to have the special
+                          ;; variables here be named with the *FOO*
+                          ;; convention.
+                          (forms `(defparameter ,tn-name
+                                    (make-random-tn :kind :normal
+                                                    :sc (sc-or-lose ',sc-name)
+                                                    :offset
+                                                    ,offset-name)))))
+                      `(progn ,@(forms)))))
+
+  (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
+  (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
+  (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
+  (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7))
+
+;;; TNs for registers used to pass arguments
+(defparameter *register-arg-tns*
+  (mapcar (lambda (register-arg-name)
+            (symbol-value (symbolicate register-arg-name "-TN")))
+          *register-arg-names*))
+
+;;; FIXME: doesn't seem to be used in SBCL
+#|
+;;; added by pw
+(defparameter fp-constant-tn
+  (make-random-tn :kind :normal
+                  :sc (sc-or-lose 'fp-constant)
+                  :offset 31))          ; Offset doesn't get used.
+|#
+\f
+;;; If value can be represented as an immediate constant, then return
+;;; the appropriate SC number, otherwise return NIL.
+(!def-vm-support-routine immediate-constant-sc (value)
+  (typecase value
+    ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
+         #-sb-xc-host system-area-pointer character)
+     (sc-number-or-lose 'immediate))
+    (symbol
+     (when (static-symbol-p value)
+       (sc-number-or-lose 'immediate)))
+    (single-float
+     (when (or (eql value 0f0) (eql value 1f0))
+       (sc-number-or-lose 'fp-constant)))
+    (double-float
+     (when (or (eql value 0d0) (eql value 1d0))
+       (sc-number-or-lose 'fp-constant)))
+    #!+long-float
+    (long-float
+     (when (or (eql value 0l0) (eql value 1l0)
+               (eql value pi)
+               (eql value (log 10l0 2l0))
+               (eql value (log 2.718281828459045235360287471352662L0 2l0))
+               (eql value (log 2l0 10l0))
+               (eql value (log 2l0 2.718281828459045235360287471352662L0)))
+       (sc-number-or-lose 'fp-constant)))))
+\f
+;;;; miscellaneous function call parameters
+
+;;; offsets of special stack frame locations
+(def!constant ocfp-save-offset 0)
+(def!constant return-pc-save-offset 1)
+(def!constant code-save-offset 2)
+
+;;; FIXME: This is a bad comment (changed since when?) and there are others
+;;; like it in this file. It'd be nice to clarify them. Failing that deleting
+;;; them or flagging them with KLUDGE might be better than nothing.
+;;;
+;;; names of these things seem to have changed. these aliases by jrd
+(def!constant lra-save-offset return-pc-save-offset)
+
+(def!constant cfp-offset ebp-offset)    ; pfw - needed by stuff in /code
+                                        ; related to signal context stuff
+
+;;; This is used by the debugger.
+(def!constant single-value-return-byte-offset 2)
+\f
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location. It returns a thing that can be printed with PRINC.
+(!def-vm-support-routine location-print-name (tn)
+  (declare (type tn tn))
+  (let* ((sc (tn-sc tn))
+         (sb (sb-name (sc-sb sc)))
+         (offset (tn-offset tn)))
+    (ecase sb
+      (registers
+       (let* ((sc-name (sc-name sc))
+              (name-vec (cond ((member sc-name *byte-sc-names*)
+                               *byte-register-names*)
+                              ((member sc-name *word-sc-names*)
+                               *word-register-names*)
+                              ((member sc-name *dword-sc-names*)
+                               *dword-register-names*))))
+         (or (and name-vec
+                  (< -1 offset (length name-vec))
+                  (svref name-vec offset))
+             ;; FIXME: Shouldn't this be an ERROR?
+             (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
+      (float-registers (format nil "FR~D" offset))
+      (sse-registers (format nil "XMM~D" offset))
+      (stack (format nil "S~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed")
+      (noise (symbol-name (sc-name sc))))))
+;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
diff --git a/scratch/.emacs.desktop b/scratch/.emacs.desktop
new file mode 100644 (file)
index 0000000..4fe6149
--- /dev/null
@@ -0,0 +1,82 @@
+;; -*- coding: emacs-mule; -*-
+;; --------------------------------------------------------------------------
+;; Desktop File for Emacs
+;; --------------------------------------------------------------------------
+;; Created Fri Aug  5 15:49:29 2005
+;; Emacs version 21.3.1
+
+;; Global section:
+(setq desktop-missing-file-warning nil)
+(setq tags-file-name nil)
+(setq tags-table-list nil)
+(setq search-ring nil)
+(setq regexp-search-ring nil)
+(setq register-alist nil)
+
+;; Buffer section:
+(desktop-create-buffer 205
+  "/home/rlaakso/projects/sbcl-sse/sse2.lisp"
+  "sse2.lisp"
+  'lisp-mode
+  '(slime-mode)
+  1
+  '(nil nil)
+  nil
+  nil
+  nil)
+
+(desktop-create-buffer 205
+  "/home/rlaakso/projects/sbcl-sse/OPTIMIZATIONS"
+  "OPTIMIZATIONS"
+  'fundamental-mode
+  nil
+  161
+  '(nil nil)
+  nil
+  nil
+  nil)
+
+(desktop-create-buffer 205
+  "/home/rlaakso/projects/sbcl-sse/sse.lisp"
+  "sse.lisp"
+  'lisp-mode
+  '(slime-mode)
+  1630
+  '(nil nil)
+  nil
+  nil
+  nil)
+
+(desktop-create-buffer 205
+  "/home/rlaakso/projects/sbcl-sse/cpuid.lisp"
+  "cpuid.lisp"
+  'lisp-mode
+  '(slime-mode)
+  68
+  '(1 nil)
+  nil
+  nil
+  nil)
+
+(desktop-create-buffer 205
+  "/home/rlaakso/.emacs"
+  ".emacs"
+  'emacs-lisp-mode
+  nil
+  848
+  '(nil nil)
+  nil
+  nil
+  nil)
+
+(desktop-create-buffer 205
+  "/home/rlaakso/projects/sb-simd-tmp/sb-simd/scratch/cpuid.lisp"
+  "cpuid.lisp<2>"
+  'lisp-mode
+  '(slime-mode)
+  1442
+  '(nil nil)
+  nil
+  nil
+  nil)
+
diff --git a/scratch/README b/scratch/README
new file mode 100644 (file)
index 0000000..caad35e
--- /dev/null
@@ -0,0 +1,2 @@
+scratch space. do not look ;-)
+
diff --git a/scratch/asm-t1.asm b/scratch/asm-t1.asm
new file mode 100644 (file)
index 0000000..599e6a6
--- /dev/null
@@ -0,0 +1,10 @@
+
+my_func:       
+               xor eax, eax
+               movups xmm0, [edx+ebx+1]
+               movups xmm1, [esi+ecx+1]
+               addps xmm0, xmm4
+               addps xmm4, xmm0
+               movups [ecx+1], xmm0
+               
+               ret     
\ No newline at end of file
diff --git a/scratch/foo.lisp b/scratch/foo.lisp
new file mode 100644 (file)
index 0000000..0f54018
--- /dev/null
@@ -0,0 +1,159 @@
+(in-package :sb-vm)
+
+(define-vop (my-vop)
+  (:policy :fast-safe)
+
+  (:args (vector1 :scs (descriptor-reg))
+        (vector2 :scs (descriptor-reg)))
+  (:arg-types simple-array-single-float simple-array-single-float)
+
+  (:temporary (:sc unsigned-reg) index)
+
+;;  (:temporary (:sc unsigned-reg) temp1)
+;;  (:temporary (:sc unsigned-reg) temp2)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             (inst xor index index)
+
+
+             (inst movups sse-temp1
+                   (make-ea :dword :base vector1 :index index
+                            :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+             (inst movups sse-temp2
+                   (make-ea :dword :base vector2 :index index
+                            :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+
+             (inst addps sse-temp1 sse-temp2)
+
+;;           (inst add index 4)
+
+             (inst movups 
+                   (make-ea :dword :base vector1 :index index
+                            :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+                   sse-temp1)
+#|
+             (inst add index 4)
+             (inst mov 
+                   (make-ea :dword :base vector1 :index index
+                            :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+                   index)
+
+             (inst add index 4)
+             (inst movups 
+                   (make-ea :dword :base vector1 :index index
+                            :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
+                   sse-temp2)
+|#
+             ))
+
+#|
+00000000 <my_func>: 
+   0:   31 c0                   xor    %eax,%eax                                                                      2:   0f 10 04 c6             movups (%esi,%eax,8),%xmm0
+   6:   0f 10 0c c7             movups (%edi,%eax,8),%xmm1
+   a:   0f 58 c1                addps  %xmm1,%xmm0
+   d:   0f 11 44 c5 00          movups %xmm0,0x0(%ebp,%eax,8)       
+
+--- v2:
+   0:   31 c0                   xor    %eax,%eax
+   2:  0f 10 44 03 01          movups 0x1(%ebx,%eax,1),%xmm0
+   7:  0f 10 4c 01 01          movups 0x1(%ecx,%eax,1),%xmm1
+   c:  0f 58 c1                addps  %xmm1,%xmm0
+   f:  0f 11 44 01 01          movups %xmm0,0x1(%ecx,%eax,1)
+
+--- v3:
+   2:  0f 10 43 01             movups 0x1(%ebx),%xmm0
+   6:  0f 10 49 01             movups 0x1(%ecx),%xmm1
+   a:  0f 58 c1                addps  %xmm1,%xmm0
+   d:  0f 11 41 01             movups %xmm0,0x1(%ecx)
+
+--- v4:
+   2:  0f 10 44 1a 01          movups 0x1(%edx,%ebx,1),%xmm0
+   7:  0f 10 4c 0e 01          movups 0x1(%esi,%ecx,1),%xmm1
+   c:  0f 58 c1                addps  %xmm1,%xmm0
+   f:  0f 11 41 01             movups %xmm0,0x1(%ecx)
+
+10h = MOVUPS Vps, Wps
+11h = MOVUPS Wps, Vps
+
+V = 128bit xmm reg specified by the modrm reg field.
+W = 128bit xmm register or mem op specified by the modrm byte. 
+ps = 128bit single-precision float operand
+
+movups  xmm0,        [ebx       + 01]
+movups  md reg r/m  sc idx bse  disp8 
+0f 10   01 000 100  00 000 011    01
+       +d8 xm0 sib  *0 +0  ebx   +01
+|#
+#|
+;      43E: L4:   31C0             XOR EAX, EAX
+
+        7 6  5 4 3  2 1 0
+        m d  r e g  r / m
+
+44h = b 0 1  0 0 0  1 0 0
+4Ch = b 0 1  0 0 1  1 0 0 
+64h = b 0 1  1 0 0  1 0 0
+E0h = b 1 1  1 0 0  0 0 0
+C1h = b 1 1  0 0 0  0 0 1
+43h = b 0 1  0 0 0  0 1 1
+49h = b 0 1  0 0 1  0 0 1
+
+r/m b100 => has sib byte
+
+modrm md+r/m field:
+   r/m= 000, 001, 010, 011, 100, 101,    110  , 111
+md     
+00 =     ax,  cx,  dx,  bx, sib, rip+d32, si,   di
+01 = --||-- + disp8                  , bp+disp8, ..
+10 = --||-- + disp32
+11 = al/ax/eax/mmx0/xmm0, 1, 2, 3, 4, 5, 6, 7
+
+modrm reg:
+       000 001 010 011 100 101 110 111
+reg32  eax ecx edx ebx esp ebp esi edi
+xmm    xm0 xm1 xm2 xm3 xm4 xm5 xm6 xm7 ;; actually xmm0..xmm7
+
+
+44h = md 01, r/m 100, reg 000, => xmm0, [sib + disp8] => 44 03 01 : xmm0, [ebx + 01], 44 01 01 : xmm0, [ecx + 01]
+64h = md 01, r/m 100, reg 100, => xmm4, [sib + disp8] => xmm4, [ebx + 01]
+04 C6 = md 00, r/m 100, reg 000, => xmm0, [sib] => xmm0, [esi*8]
+4C 01 01 = md 01, reg 001, r/m 100 => xmm1, [sib + disp8] => [ecx + 01]
+43h = md 01, reg 0, r/m 011 => xmm0, [ebx + 01]
+49h = md 01, reg 1, r/m 001 => xmm1, [ecx + 01]
+
+
+        7 6  5 4 3  2 1 0
+        s c  i d x  b a s
+
+03h = b 0 0  0 0 0  0 1 1  = eax + ebx*1
+01h = b 0 0  0 0 0  0 0 1  = eax + ecx*1
+C6h = b 1 1  0 0 0  1 1 0  = eax + esi*8
+1Ah = b 0 0  0 1 1  0 1 0  = ebx + edx*1
+0Eh = b 0 0  0 0 1  1 1 0  = ecx + esi*1
+
+
+;; movups xmm0, ea 0F 10 44 03 01
+;      440:        0F 10 44 01 01         movups xmm0, [eax + ecx + 01]
+
+;; movups xmm1, ea 0F 10 4C 01 01
+;      445:        0F 10 64 03 01         movups xmm4, [eax + ebx + 01]
+
+;; addps xmm0, xmm1 0F 58 C1
+;      44A:         0F 58 E0        addps xmm0, xmm4
+
+;; movups ea, xmm0 0f 11 44 01 01
+                   0F 11 44 01 01     movups [eax + ecx + 01], xmm0
+
+;      452:       83C004           ADD EAX, 4
+
+
+--
+
+   c:  0f 58 c4                addps  %xmm4,%xmm0
+   f:  0f 58 e0                addps  %xmm0,%xmm4
+
+|#
diff --git a/scratch/sse.lisp b/scratch/sse.lisp
new file mode 100644 (file)
index 0000000..db99a8a
--- /dev/null
@@ -0,0 +1,125 @@
+;;; From sb-devel post by Christophe Rhodes
+(in-package :cl-user)
+
+(defun %vector+ (result vector1 vector2)
+  (loop for x across vector1
+        for y across vector2
+        for i from 0
+        do (setf (aref result i) (+ x y))))
+
+(in-package :sb-c)
+
+;; kludge
+(ignore-errors (defknown cl-user::%vector+ (vector vector vector) vector))
+
+(in-package :sb-vm)
+
+(pushnew :sse2 *backend-subfeatures*)
+
+(define-vop (vector+/simple-array-signed-byte-30)
+  (:translate cl-user::%vector+)
+  (:policy :fast)
+  (:args (result :scs (descriptor-reg))
+        (vector1 :scs (descriptor-reg))
+        (vector2 :scs (descriptor-reg)))
+  (:arg-types simple-array-signed-byte-30 simple-array-signed-byte-30 simple-array-signed-byte-30)
+  (:temporary (:sc any-reg) temp)
+  (:temporary (:sc unsigned-reg) index)
+  (:temporary (:sc unsigned-reg) length)
+  (:generator 30
+    (let ((top (gen-label))
+         (end (gen-label)))
+      (loadw length result vector-length-slot other-pointer-lowtag)
+      ;; check that the result vector doesn't have length 0
+      (inst cmp length 0)
+      (inst jmp :e end)
+      ;; zero the index
+      (inst xor index index)
+      (emit-label top)
+      ;; this is wasteful if one of the arguments is the same as the
+      ;; result; we can save a mov
+      (inst mov temp (make-ea :dword :base vector1 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst add temp (make-ea :dword :base vector2 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst mov (make-ea :dword :base result :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) temp)
+      (inst add index (fixnumize 1))
+      (inst cmp index length)
+      (inst jmp :ne top)
+      (emit-label end))))
+
+(define-vop (vector+/simple-array-signed-byte-30-sse)
+  (:translate cl-user::%vector+)
+  (:policy :fast)
+  (:args (result :scs (descriptor-reg))
+        (vector1 :scs (descriptor-reg))
+        (vector2 :scs (descriptor-reg)))
+  (:arg-types simple-array-signed-byte-30 simple-array-signed-byte-30 simple-array-signed-byte-30)
+  (:temporary (:sc any-reg) temp)
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+  (:temporary (:sc unsigned-reg) index)
+  (:temporary (:sc unsigned-reg) length)
+  (:guard (member :sse2 *backend-subfeatures*))
+  (:generator 25
+    (let ((top (gen-label))
+         (two (gen-label))
+         (four (gen-label))
+         (end (gen-label)))
+      (loadw length result vector-length-slot other-pointer-lowtag)
+      ;; check that the result vector doesn't have length 0
+      (inst cmp length 0)
+      (inst jmp :e end)
+      ;; zero the index
+      (inst xor index index)
+      (emit-label top)
+      (inst test length 1)
+      (inst jmp :z two)
+      (inst mov temp (make-ea :dword :base vector1 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst add temp (make-ea :dword :base vector2 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst mov (make-ea :dword :base result :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) temp)
+      (inst add index (fixnumize 1))
+      (inst cmp index length)
+      (inst jmp :e end)
+      (emit-label two)
+      ;; eventually at this point we put in a quadword add, but that
+      ;; would be one more instruction to write.
+      (inst test length 2)
+      (inst mov temp (make-ea :dword :base vector1 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst add temp (make-ea :dword :base vector2 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst mov (make-ea :dword :base result :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) temp)
+      (inst add index (fixnumize 1))
+      (inst cmp index length)
+      (inst jmp :e end)
+      (inst mov temp (make-ea :dword :base vector1 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst add temp (make-ea :dword :base vector2 :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst mov (make-ea :dword :base result :index index
+                             :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) temp)
+      (inst add index (fixnumize 1))
+      (inst cmp index length)
+      (inst jmp :e end)
+      (emit-label four)
+      ;; here, we do double quadword additions until we hit the end of
+      ;; the computation. No guarantees about alignment, so we have to
+      ;; use movdqu.
+      (inst movdqu sse-temp1 (make-ea :dword :base vector1 :index index
+                                     :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      ;; KLUDGE: We're using :dword EAs here. This is possibly non-optimal.
+      (inst movdqu sse-temp2 (make-ea :dword :base vector2 :index index
+                                     :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst paddd sse-temp1 sse-temp2)
+      (inst movdqu sse-temp1 (make-ea :dword :base result :index index
+                                     :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+      (inst add index (fixnumize 4))
+      (inst cmp index length)
+      (inst jmp :ne four)
+      (emit-label end))))
diff --git a/scratch/sse2.lisp b/scratch/sse2.lisp
new file mode 100644 (file)
index 0000000..78b95ac
--- /dev/null
@@ -0,0 +1,33 @@
+;;; From sb-devel post by Christophe Rhodes
+(in-package :cl-user)
+
+(declaim (inline fixnum/vector+))
+(defun fixnum/vector+ (vector1 vector2)
+  (let ((result (make-array (length vector1) :element-type 'fixnum)))
+    (dotimes (i 1000000)
+      (declare (fixnum i))
+      (%vector+ result vector1 vector2))
+    result))
+
+(defun foo ()
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((x (make-array 1000 :element-type 'fixnum 
+                      :initial-contents (loop for x fixnum from 0 to 999 collect x)))
+        (y (make-array 1000 :element-type 'fixnum 
+                      :initial-contents (loop for x fixnum from 0 to 999 collect x))))
+    (fixnum/vector+ x y)))
+
+(defun bar ()
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((x (make-array 1000 :element-type 'fixnum 
+                      :initial-contents (loop for x fixnum from 0 to 999 collect x)))
+        (y (make-array 1000 :element-type 'fixnum 
+                      :initial-contents (loop for x fixnum from 0 to 999 collect x))))
+    (let ((result (make-array 1000 :element-type 'fixnum)))
+      (dotimes (j 1000000)
+        (declare (fixnum j))
+        (loop for tx across x
+              for ty across y
+              for i fixnum upfrom 0
+              do (setf (aref result i) (+ tx ty))))
+      result)))
diff --git a/sse-vop.lisp b/sse-vop.lisp
new file mode 100644 (file)
index 0000000..bb1e880
--- /dev/null
@@ -0,0 +1,207 @@
+(in-package :sb-vm)
+
+(defmacro vect-ea (vect idx)
+  `(make-ea :dword :base ,vect :index ,idx
+    :disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
+
+
+(define-vop (%sse-add/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (vect2 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+             (inst movups sse-temp2 (vect-ea vect2 index))
+
+             ;; operate
+             (inst addps sse-temp1 sse-temp2)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp1)
+             ))
+
+(define-vop (%sse-sub/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (vect2 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+             (inst movups sse-temp2 (vect-ea vect2 index))
+
+             ;; operate
+             (inst subps sse-temp1 sse-temp2)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp1)
+             ))
+
+(define-vop (%sse-mul/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (vect2 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+             (inst movups sse-temp2 (vect-ea vect2 index))
+
+             ;; operate
+             (inst mulps sse-temp1 sse-temp2)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp1)
+             ))
+
+(define-vop (%sse-div/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (vect2 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+             (inst movups sse-temp2 (vect-ea vect2 index))
+
+             ;; operate
+             (inst divps sse-temp1 sse-temp2)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp1)
+             ))
+
+(define-vop (%sse-sqrt/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+
+             ;; operate
+             (inst sqrtps sse-temp2 sse-temp1)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp2)
+             ))
+
+
+(define-vop (%sse-recip/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+
+             ;; operate
+             (inst rcpps sse-temp2 sse-temp1)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp2)
+             ))
+
+
+(define-vop (%sse-recip-sqrt/simple-array-single-float-1)
+    (:policy :fast-safe)
+  
+  (:args (result :scs (descriptor-reg))
+        (vect1 :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+
+  (:arg-types simple-array-single-float simple-array-single-float fixnum)
+
+  (:temporary (:sc sse-reg) sse-temp1)
+  (:temporary (:sc sse-reg) sse-temp2)
+
+  (:generator 10
+
+             ;; scale index by 4 (size-of single-float)
+             (inst shl index 2)
+
+             ;; load
+             (inst movups sse-temp1 (vect-ea vect1 index))
+
+             ;; operate
+             (inst rsqrtps sse-temp2 sse-temp1)
+
+             ;; store
+             (inst movups (vect-ea result index) sse-temp2)
+             ))
+
+