From 8775b797d8546448deab512e79de5cfde4facae6 Mon Sep 17 00:00:00 2001 From: rlaakso Date: Fri, 5 Aug 2005 13:13:29 +0000 Subject: [PATCH] Initial revision --- TODO | 20 + cpuid-vop.lisp | 96 + cpuid.lisp | 139 ++ example-test.lisp | 23 + generate-sse-instructions.lisp | 79 + sbcl-src/makepatch.sh | 4 + sbcl-src/patch_against_sbcl_0_9_3 | 229 +++ sbcl-src/src-093/compiler/x86/insts.lisp | 2670 ++++++++++++++++++++++++++++ sbcl-src/src-093/compiler/x86/vm.lisp | 451 +++++ sbcl-src/src/compiler/x86/insts.lisp | 2794 ++++++++++++++++++++++++++++++ sbcl-src/src/compiler/x86/vm.lisp | 469 +++++ scratch/.emacs.desktop | 82 + scratch/README | 2 + scratch/asm-t1.asm | 10 + scratch/foo.lisp | 159 ++ scratch/sse.lisp | 125 ++ scratch/sse2.lisp | 33 + sse-vop.lisp | 207 +++ 18 files changed, 7592 insertions(+) create mode 100644 TODO create mode 100644 cpuid-vop.lisp create mode 100644 cpuid.lisp create mode 100644 example-test.lisp create mode 100644 generate-sse-instructions.lisp create mode 100755 sbcl-src/makepatch.sh create mode 100644 sbcl-src/patch_against_sbcl_0_9_3 create mode 100644 sbcl-src/src-093/compiler/x86/insts.lisp create mode 100644 sbcl-src/src-093/compiler/x86/vm.lisp create mode 100644 sbcl-src/src/compiler/x86/insts.lisp create mode 100644 sbcl-src/src/compiler/x86/vm.lisp create mode 100644 scratch/.emacs.desktop create mode 100644 scratch/README create mode 100644 scratch/asm-t1.asm create mode 100644 scratch/foo.lisp create mode 100644 scratch/sse.lisp create mode 100644 scratch/sse2.lisp create mode 100644 sse-vop.lisp diff --git a/TODO b/TODO new file mode 100644 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 index 0000000..2f79c70 --- /dev/null +++ b/cpuid-vop.lisp @@ -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 index 0000000..55c4f9c --- /dev/null +++ b/cpuid.lisp @@ -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 index 0000000..222f522 --- /dev/null +++ b/example-test.lisp @@ -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 index 0000000..6717ebc --- /dev/null +++ b/generate-sse-instructions.lisp @@ -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 index 0000000..641b804 --- /dev/null +++ b/sbcl-src/makepatch.sh @@ -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 index 0000000..234ef9d --- /dev/null +++ b/sbcl-src/patch_against_sbcl_0_9_3 @@ -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))) + ++ ++;;;; 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 + + ;;;; miscellaneous TNs for the various registers +@@ -444,6 +461,7 @@ + ;; FIXME: Shouldn't this be an ERROR? + (format nil "" 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 index 0000000..9eed6f8 --- /dev/null +++ b/sbcl-src/src-093/compiler/x86/insts.lisp @@ -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) + +(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 + +;;;; 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))) + +;;;; 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)) + +;;;; 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))) + +;;;; 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)) + +;;;; 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))) + +;;;; 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))) + +;;;; 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)))) + +;;;; 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))))) + + + +(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))) + +;;;; 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))))) + + +;;;; 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)))) + +;;;; 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))) + + +;;;; 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))) + + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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 index 0000000..833dd73 --- /dev/null +++ b/sbcl-src/src-093/compiler/x86/vm.lisp @@ -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)) + +;;;; 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)) + +;;;; 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) + +;;;; 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 + +;;;; 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. +|# + +;;; 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))))) + +;;;; 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) + +;;; 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 "" 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 index 0000000..da683b8 --- /dev/null +++ b/sbcl-src/src/compiler/x86/insts.lisp @@ -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) + +(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 + +;;;; 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))) + +;;;; 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)) + +;;;; 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))) + +;;;; 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)) + +;;;; 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))) + +;;;; 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))) + +;;;; 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)))) + +;;;; 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))))) + + + +(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))) + +;;;; 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))))) + + +;;;; 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)))) + +;;;; 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))) + + +;;;; 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))) + + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + +;;;; 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))) + + +;;;; 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 index 0000000..1bab6a3 --- /dev/null +++ b/sbcl-src/src/compiler/x86/vm.lisp @@ -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)) + +;;;; 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)) + +;;;; 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) + +;;;; 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 + +;;;; 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. +|# + +;;; 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))))) + +;;;; 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) + +;;; 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 "" 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 index 0000000..4fe6149 --- /dev/null +++ b/scratch/.emacs.desktop @@ -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 index 0000000..caad35e --- /dev/null +++ b/scratch/README @@ -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 index 0000000..599e6a6 --- /dev/null +++ b/scratch/asm-t1.asm @@ -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 index 0000000..0f54018 --- /dev/null +++ b/scratch/foo.lisp @@ -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 : + 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 index 0000000..db99a8a --- /dev/null +++ b/scratch/sse.lisp @@ -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 index 0000000..78b95ac --- /dev/null +++ b/scratch/sse2.lisp @@ -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 index 0000000..bb1e880 --- /dev/null +++ b/sse-vop.lisp @@ -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) + )) + + -- 2.11.4.GIT