diff --git a/compiler/amd64/alloc.lisp b/compiler/amd64/alloc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e437cf45c0812eefa3bec973552ec8eaa198b3d5
--- /dev/null
+++ b/compiler/amd64/alloc.lisp
@@ -0,0 +1,291 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/alloc.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the amd64 port.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1996.
+;;; 
+
+(in-package :amd64)
+
+
+;;;; Dynamic-Extent
+
+;;;
+;;; Take an arg where to move the stack pointer instead of returning
+;;; it via :results, because the former generates a single move.
+;;;
+(define-vop (%dynamic-extent-start)
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
+  (:results)
+  (:policy :safe)
+  (:generator 0 (inst mov saved-stack-pointer rsp-tn)))
+
+(define-vop (%dynamic-extent-end)
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
+  (:results)
+  (:policy :safe)
+  (:generator 0 (inst mov rsp-tn saved-stack-pointer)))
+
+
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+  (:args (things :more t))
+  (:temporary (:sc unsigned-reg) ptr temp)
+  (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
+  (:info num dynamic-extent)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:node-var node)
+  (:generator 0
+    (cond ((zerop num)
+	   ;; (move result nil-value)
+	   (inst mov result nil-value))
+	  ((and star (= num 1))
+	   (move result (tn-ref-tn things)))
+	  (t
+	   (macrolet
+	       ((store-car (tn list &optional (slot vm:cons-car-slot))
+		  `(let ((reg
+			  (sc-case ,tn
+			    ((any-reg descriptor-reg) ,tn)
+			    ((control-stack)
+			     (move temp ,tn)
+			     temp))))
+		     (storew reg ,list ,slot vm:list-pointer-type))))
+	     (let ((cons-cells (if star (1- num) num))
+		   (*enable-pseudo-atomic* (unless dynamic-extent
+					     *enable-pseudo-atomic*)))
+	       (pseudo-atomic
+		(allocation res (* (pad-data-block cons-size) cons-cells) temp node
+			    dynamic-extent)
+		(inst lea res
+		      (make-ea :byte :base res :disp list-pointer-type))
+		(move ptr res)
+		(dotimes (i (1- cons-cells))
+		  (store-car (tn-ref-tn things) ptr)
+		  (setf things (tn-ref-across things))
+		  (inst add ptr (pad-data-block cons-size))
+		  (storew ptr ptr (- cons-cdr-slot cons-size)
+			  list-pointer-type))
+		(store-car (tn-ref-tn things) ptr)
+		(cond (star
+		       (setf things (tn-ref-across things))
+		       (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+		      (t
+		       (storew nil-value ptr cons-cdr-slot
+			       list-pointer-type)))
+		(assert (null (tn-ref-across things)))))
+	     (move result res))))))
+
+(define-vop (list list-or-list*)
+  (:variant nil))
+
+(define-vop (list* list-or-list*)
+  (:variant t))
+
+
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+  (:args (boxed-arg :scs (any-reg) :target boxed)
+	 (unboxed-arg :scs (any-reg) :target unboxed))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg :from :eval) temp)
+  (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
+  (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
+  (:generator 100
+    (move boxed boxed-arg)
+    (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
+    (inst and boxed (lognot lowtag-mask))
+    (move unboxed unboxed-arg)
+    (inst shr unboxed word-shift)
+    (inst add unboxed lowtag-mask)
+    (inst and unboxed (lognot lowtag-mask))
+    (pseudo-atomic
+     ;; now loading code into static space cause it can't move
+     (load-symbol-value temp lisp::*static-space-free-pointer*)
+     (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+     (inst add temp boxed)
+     (inst add temp unboxed)
+     (store-symbol-value temp lisp::*static-space-free-pointer*)
+     (inst shl boxed (- type-bits word-shift))
+     (inst or boxed code-header-type)
+     (storew boxed result 0 other-pointer-type)
+     (storew unboxed result code-code-size-slot other-pointer-type)
+     (inst mov temp nil-value)
+     (storew temp result code-entry-points-slot other-pointer-type))
+    (storew temp result code-debug-info-slot other-pointer-type)))
+
+
+(define-vop (allocate-dynamic-code-object)
+  (:args (boxed-arg :scs (any-reg) :target boxed) ; fixnum, number of words
+	 (unboxed-arg :scs (any-reg) :target unboxed)) ; fixnum, number of bytes
+  (:results (result :scs (descriptor-reg) :from :eval))
+  (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
+  (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:generator 100
+    (move boxed boxed-arg)
+    ;; the compiled code assumes it's dual word aligned
+    (inst lea boxed (make-ea :byte :base boxed :index boxed
+			     :disp (* 8 (1+ code-trace-table-offset-slot))))
+    (inst and boxed (lognot 15))
+    (move unboxed unboxed-arg)
+    (inst shr unboxed 2)
+    (inst add unboxed 15)
+    (inst and unboxed (lognot 15)) ; alignment
+    (inst mov result boxed)
+    (inst add result unboxed) ; total number of bytes
+    (pseudo-atomic
+     (allocation result result temp node)
+     (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+     (inst shl boxed (- type-bits word-shift))
+     (inst or boxed code-header-type)
+     (storew boxed result 0 other-pointer-type)
+     (inst shr unboxed 1) ; number of code words (fixnum tag)
+     (storew unboxed result code-code-size-slot other-pointer-type)
+     (storew nil-value result code-entry-points-slot other-pointer-type))
+    (storew nil-value result code-debug-info-slot other-pointer-type)))
+
+
+(define-vop (make-fdefn)
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:generator 37
+    (with-fixed-allocation (result fdefn-type fdefn-size temp node)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew nil-value result fdefn-function-slot other-pointer-type)
+      (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+	      result fdefn-raw-addr-slot other-pointer-type))))
+
+
+(define-vop (make-closure)
+  (:args (function :to :save :scs (descriptor-reg)))
+  (:info length dynamic-extent)
+  (:temporary (:sc any-reg) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:node-var node)
+  (:generator 10
+   (let ((*enable-pseudo-atomic* (unless dynamic-extent
+				   *enable-pseudo-atomic*)))
+     (pseudo-atomic
+      (let ((size (+ length closure-info-offset)))
+	(allocation result (pad-data-block size) temp node dynamic-extent)
+	(inst lea result
+	      (make-ea :byte :base result :disp function-pointer-type))
+	(storew (logior (ash (1- size) type-bits) closure-header-type)
+		result 0 function-pointer-type))
+      (loadw temp function closure-function-slot function-pointer-type)
+      (storew temp result closure-function-slot function-pointer-type)))))
+
+;;; The compiler likes to be able to directly make value cells.
+;;; 
+(define-vop (make-value-cell)
+  (:args (value :scs (descriptor-reg any-reg) :to :result))
+  (:results (result :scs (descriptor-reg) :from :eval))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:generator 10
+    (with-fixed-allocation
+	(result value-cell-header-type value-cell-size temp node))
+    (storew value result value-cell-value-slot other-pointer-type)))
+
+
+
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst mov result unbound-marker-type)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag dynamic-extent)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:generator 50
+    (let ((*enable-pseudo-atomic* (unless dynamic-extent
+				    *enable-pseudo-atomic*)))
+      (pseudo-atomic
+       (allocation result (pad-data-block words) temp node dynamic-extent)
+       (inst lea result (make-ea :byte :base result :disp lowtag))
+       (when type
+	 (storew (logior (ash (1- words) type-bits) type) result 0 lowtag))))))
+
+(define-vop (var-alloc)
+  (:args (extra :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg) :from (:eval 1)))
+  (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
+  (:temporary (:sc any-reg :from :eval :to :result) header)
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:generator 50
+    (inst lea bytes
+	  (make-ea :qword :index extra :scale 2 :disp (* (1+ words) word-bytes)))
+    (inst mov header bytes)
+    (inst shl header (- type-bits 3))	; w+1 to length field
+    
+    (inst lea header			; (w-1 << 8) | type
+	  (make-ea :qword :base header :disp (+ (ash -2 type-bits) type)))
+    (inst and bytes (lognot 15)) ; alignment
+    (pseudo-atomic
+     (allocation result bytes temp node)
+     (inst lea result (make-ea :byte :base result :disp lowtag))
+     (storew header result 0 lowtag))))
+
+
+
+(define-vop (make-symbol)
+  (:policy :fast-safe)
+  (:translate make-symbol)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:sc unsigned-reg) temp) ; this cannot be the same register as name
+  (:temporary (:sc unsigned-reg :from :eval) state-addr)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:node-var node)
+  (:generator 37
+    (with-fixed-allocation (result symbol-header-type symbol-size temp node)
+      (storew name result symbol-name-slot other-pointer-type)
+      (storew unbound-marker-type result symbol-value-slot other-pointer-type)
+      ;; Setup a random hash value for the symbol.  Perhaps the object
+      ;; address could be used for even faster and smaller code!
+      (load-foreign-data-symbol2 state-addr "fast_random_state" temp)
+      (inst imul temp
+	    (make-ea :qword :base state-addr)
+	    1103515245)
+      (inst add temp 12345)
+      (inst mov (make-ea :qword :base state-addr) temp)
+      ;; Want a positive fixnum for the hash value, discard the LS bits.
+      (inst shr temp 1)
+      (inst and temp #xfffffffc)
+      (storew temp result symbol-hash-slot other-pointer-type)
+      (storew nil-value result symbol-plist-slot other-pointer-type)
+      (storew nil-value result symbol-package-slot other-pointer-type))))
diff --git a/compiler/amd64/arith.lisp b/compiler/amd64/arith.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fa979d62ea8cb22ae036edbd2a97aa27b6d8c206
--- /dev/null
+++ b/compiler/amd64/arith.lisp
@@ -0,0 +1,1475 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/arith.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,2000.
+;;; 
+
+(in-package :amd64)
+
+
+
+;;;; Unary operations.
+
+(define-vop (fast-safe-arith-op)
+  (:policy :fast-safe)
+  (:effects)
+  (:affected))
+
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+  (:args (x :scs (any-reg) :target res))
+  (:results (res :scs (any-reg)))
+  (:note "inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+  (:args (x :scs (signed-reg) :target res))
+  (:results (res :scs (signed-reg)))
+  (:note "inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (move res x)
+    (inst neg res)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (move res x)
+    (inst neg res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:translate lognot)
+  (:generator 2
+    (move res x)
+    (inst xor res (fixnumize -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (move res x)
+    (inst not res)))
+
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg)
+	    :load-if (not (and (sc-is x control-stack)
+			       (sc-is y any-reg)
+			       (sc-is r control-stack)
+			       (location= x r))))
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x control-stack)
+				  (sc-is y any-reg)
+				  (sc-is r control-stack)
+				  (location= x r)))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (sc-is r unsigned-stack)
+			       (location= x r))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (sc-is r unsigned-stack)
+			       (location= x r)))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (sc-is r signed-stack)
+			       (location= x r))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (sc-is r signed-stack)
+			       (location= x r)))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg control-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)
+	       :load-if (not (location= x r))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+  (:info y)
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)
+	       :load-if (not (location= x r))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+
+(eval-when (compile load eval)
+
+(defmacro define-binop (translate untagged-penalty op)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		  fast-fixnum-binop)
+       (:translate ,translate)
+       (:generator 2
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+		  fast-fixnum-binop-c)
+       (:translate ,translate)
+       (:generator 1
+	 (move r x)
+	 (inst ,op r (fixnumize y))))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+		  fast-signed-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+		  fast-unsigned-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (move r x)
+	 (inst ,op r y)))))
+
+); eval-when
+
+
+
+;(define-binop + 4 add)
+(define-binop - 4 sub)
+(define-binop logand 2 and)
+(define-binop logior 2 or)
+(define-binop logxor 2 xor)
+
+
+;;; Special handling of add on the x86; can use lea to avoid a
+;;; register load, otherwise it uses add.
+(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
+  (:translate +)
+  (:args (x :scs (any-reg) :target r
+	    :load-if (not (and (sc-is x control-stack)
+			       (sc-is y any-reg)
+			       (sc-is r control-stack)
+			       (location= x r))))
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x control-stack)
+				  (sc-is y any-reg)
+				  (sc-is r control-stack)
+				  (location= x r)))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 2
+    (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
+		(not (location= x r)))
+	   (inst lea r (make-ea :qword :base x :index y :scale 1)))
+	  (t
+	   (move r x)
+	   (inst add r y)))))
+
+(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (any-reg control-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)
+	       :load-if (not (location= x r))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 1
+    (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
+	   (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
+	  (t
+	   (move r x)
+	   (inst add r (fixnumize y))))))
+
+(define-vop (fast-+/signed=>signed fast-safe-arith-op)
+  (:translate +)
+  (:args (x :scs (signed-reg) :target r
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (sc-is r signed-stack)
+			       (location= x r))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x signed-stack)
+				  (sc-is y signed-reg)
+				  (location= x r)))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 5
+    (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
+		(not (location= x r)))
+	   (inst lea r (make-ea :qword :base x :index y :scale 1)))
+	  (t
+	   (move r x)
+	   (inst add r y)))))
+
+(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)
+	       :load-if (not (location= x r))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 4
+    (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
+		(not (location= x r)))
+	   (inst lea r (make-ea :qword :base x :disp y)))
+	  (t
+	   (move r x)
+	   (if (= y 1)
+	       (inst inc r)
+	     (inst add r y))))))
+
+(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
+  (:translate +)
+  (:args (x :scs (unsigned-reg) :target r
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (sc-is r unsigned-stack)
+			       (location= x r))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (sc-is y unsigned-reg)
+				  (sc-is r unsigned-stack)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:generator 5
+    (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
+		(sc-is r unsigned-reg) (not (location= x r)))
+	   (inst lea r (make-ea :qword :base x :index y :scale 1)))
+	  (t
+	   (move r x)
+	   (inst add r y)))))
+
+(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+  (:info y)
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:generator 4
+    (cond ((and (sc-is x unsigned-reg)
+		(sc-is r unsigned-reg)
+		(not (location= x r))
+		(valid-displacement-p y))
+	   (inst lea r (make-ea :qword :base x :disp y)))
+	  (t
+	   (move r x)
+	   (if (= y 1)
+	       (inst inc r)
+	       (inst add r y))))))
+
+
+;;;; Special logand cases: (logand signed unsigned) => unsigned
+
+(define-vop (fast-logand/signed-unsigned=>unsigned
+	     fast-logand/unsigned=>unsigned)
+  (:args (x :target r :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y unsigned-reg)
+			       (sc-is r unsigned-stack)
+			       (location= x r))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types signed-num unsigned-num))
+
+(define-vop (fast-logand-c/signed-unsigned=>unsigned
+	     fast-logand-c/unsigned=>unsigned)
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:arg-types signed-num (:constant (unsigned-byte 32))))
+
+(define-vop (fast-logand/unsigned-signed=>unsigned
+	     fast-logand/unsigned=>unsigned)
+  (:args (x :target r :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y signed-reg)
+			       (sc-is r unsigned-stack)
+			       (location= x r))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types unsigned-num signed-num))
+
+
+;;;; Multiplication and division.
+
+(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (any-reg) :target r)
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 4
+    (move r x)
+    (inst sar r 2)
+    (inst imul r y)))
+
+(define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (any-reg control-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 3
+    (inst imul r x y)))
+
+(define-vop (fast-*/signed=>signed fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (signed-reg) :target r)
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 5
+    (move r x)
+    (inst imul r y)))
+
+(define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 4
+    (inst imul r x y)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
+  (:translate *)
+  (:args (x :scs (unsigned-reg) :target rax)
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 0) :to :result) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset
+		   :from :eval :to :result) rdx)
+  (:ignore rdx)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 6
+    (move rax x)
+    (inst mul rax y)
+    (move result rax)))
+
+
+(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (any-reg) :target rax)
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:temporary (:sc signed-reg :offset rax-offset :target quo
+		   :from (:argument 0) :to (:result 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
+		   :from (:argument 0) :to (:result 1)) rdx)
+  (:results (quo :scs (any-reg))
+	    (rem :scs (any-reg)))
+  (:result-types tagged-num tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 31
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (if (sc-is y any-reg)
+	  (inst test y y)  ; Smaller instruction
+	  (inst cmp y 0))
+      (inst jmp :eq zero))
+    (move rax x)
+    (inst cdo)
+    (inst idiv rax y)
+    (if (location= quo rax)
+	(inst shl rax 2)
+	(inst lea quo (make-ea :qword :index rax :scale 4)))
+    (move rem rdx)))
+
+(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (any-reg) :target rax))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:temporary (:sc signed-reg :offset rax-offset :target quo
+		   :from :argument :to (:result 0)) rax)
+  (:temporary (:sc any-reg :offset rdx-offset :target rem
+		   :from :eval :to (:result 1)) rdx)
+  (:temporary (:sc any-reg :from :eval :to :result) y-arg)
+  (:results (quo :scs (any-reg))
+	    (rem :scs (any-reg)))
+  (:result-types tagged-num tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 30
+    (move rax x)
+    (inst cdq)
+    (inst mov y-arg (fixnumize y))
+    (inst idiv rax y-arg)
+    (if (location= quo rax)
+	(inst shl rax 2)
+	(inst lea quo (make-ea :qword :index rax :scale 4)))
+    (move rem rdx)))
+
+(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (unsigned-reg) :target rax)
+	 (y :scs (unsigned-reg signed-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target quo
+		   :from (:argument 0) :to (:result 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
+		   :from (:argument 0) :to (:result 1)) rdx)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 33
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (if (sc-is y unsigned-reg)
+	  (inst test y y)  ; Smaller instruction
+	  (inst cmp y 0))
+      (inst jmp :eq zero))
+    (move rax x)
+    (inst xor rdx rdx)
+    (inst div rax y)
+    (move quo rax)
+    (move rem rdx)))
+
+(define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (unsigned-reg) :target rax))
+  (:info y)
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:temporary (:sc unsigned-reg :offset rax-offset :target quo
+		   :from :argument :to (:result 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :target rem
+		   :from :eval :to (:result 1)) rdx)
+  (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 32
+    (move rax x)
+    (inst xor rdx rdx)
+    (inst mov y-arg y)
+    (inst div rax y-arg)
+    (move quo rax)
+    (move rem rdx)))
+
+(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed-reg) :target rax)
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:temporary (:sc signed-reg :offset rax-offset :target quo
+		   :from (:argument 0) :to (:result 0)) rax)
+  (:temporary (:sc signed-reg :offset rdx-offset :target rem
+		   :from (:argument 0) :to (:result 1)) rdx)
+  (:results (quo :scs (signed-reg))
+	    (rem :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 33
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (if (sc-is y signed-reg)
+	  (inst test y y)  ; Smaller instruction
+	  (inst cmp y 0))
+      (inst jmp :eq zero))
+    (move rax x)
+    (inst cdq)
+    (inst idiv rax y)
+    (move quo rax)
+    (move rem rdx)))
+
+(define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed-reg) :target rax))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:temporary (:sc signed-reg :offset rax-offset :target quo
+		   :from :argument :to (:result 0)) rax)
+  (:temporary (:sc signed-reg :offset rdx-offset :target rem
+		   :from :eval :to (:result 1)) rdx)
+  (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
+  (:results (quo :scs (signed-reg))
+	    (rem :scs (signed-reg)))
+  (:result-types signed-num signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 32
+    (move rax x)
+    (inst cdq)
+    (inst mov y-arg y)
+    (inst idiv rax y-arg)
+    (move quo rax)
+    (move rem rdx)))
+
+
+
+;;;; Shifting
+(define-vop (fast-ash-c/fixnum=>fixnum)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:args (number :scs (any-reg) :target result
+		 :load-if (not (and (sc-is number any-reg control-stack)
+				    (sc-is result any-reg control-stack)
+				    (location= number result)))))
+  (:info amount)
+  (:arg-types tagged-num (:constant integer))
+  (:results (result :scs (any-reg)
+		    :load-if (not (and (sc-is number control-stack)
+				       (sc-is result control-stack)
+				       (location= number result)))))
+  (:result-types tagged-num)
+  (:note "inline ASH")
+  (:generator 2
+    (cond ((and (= amount 1) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 2)))
+	  ((and (= amount 2) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 4)))
+	  ((and (= amount 3) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 8)))
+	  (t
+	   (move result number)
+	   (cond ((plusp amount)
+		  ;; We don't have to worry about overflow because of the
+		  ;; result type restriction.
+		  (inst shl result amount))
+		 (t
+		  ;; If the amount is greater than 31, only shift by 31.  We
+		  ;; have to do this because the shift instructions only look
+		  ;; at the low five bits of the result.
+		  (inst sar result (min 31 (- amount)))
+		  ;; Fixnum correction.
+		  (inst and result #xfffffffc)))))))
+
+(define-vop (fast-ash-left/fixnum=>fixnum)
+  (:translate ash)
+  (:args (number :scs (any-reg) :target result
+		 :load-if (not (and (sc-is number control-stack)
+				    (sc-is result control-stack)
+				    (location= number result))))
+	 (amount :scs (unsigned-reg) :target rcx))
+  (:arg-types tagged-num positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:results (result :scs (any-reg) :from (:argument 0)
+		    :load-if (not (and (sc-is number control-stack)
+				       (sc-is result control-stack)
+				       (location= number result)))))
+  (:result-types tagged-num)
+  (:policy :fast-safe)
+  (:note "inline ASH")
+  (:generator 3
+    (move result number)
+    (move rcx amount)
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)))
+
+(define-vop (fast-ash-c/unsigned=>unsigned)
+	    (:translate ash)
+  (:policy :fast-safe)
+  (:args (number :scs (unsigned-reg) :target result
+		 :load-if (not (and (sc-is number unsigned-stack)
+				    (sc-is result unsigned-stack)
+				    (location= number result)))))
+  (:info amount)
+  (:arg-types unsigned-num (:constant integer))
+  (:results (result :scs (unsigned-reg)
+		    :load-if (not (and (sc-is number unsigned-stack)
+				       (sc-is result unsigned-stack)
+				       (location= number result)))))
+  (:result-types unsigned-num)
+  (:note "inline ASH")
+  (:generator 3
+    (cond ((and (= amount 1) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 2)))
+	  ((and (= amount 2) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 4)))
+	  ((and (= amount 3) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 8)))
+	  (t
+	   (move result number)
+	   (cond ((plusp amount)
+		  ;; We don't have to worry about overflow because of the
+		  ;; result type restriction.
+		  (inst shl result amount))
+		 ((< amount -31)
+		  (inst mov result 0))
+		 (t
+		  (inst shr result (- amount))))))))
+
+(define-vop (fast-ash-c/signed=>signed)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:args (number :scs (signed-reg) :target result
+		 :load-if (not (and (sc-is number signed-stack)
+				    (sc-is result signed-stack)
+				    (location= number result)))))
+  (:info amount)
+  (:arg-types signed-num (:constant integer))
+  (:results (result :scs (signed-reg)
+		    :load-if (not (and (sc-is number signed-stack)
+				       (sc-is result signed-stack)
+				       (location= number result)))))
+  (:result-types signed-num)
+  (:note "inline ASH")
+  (:generator 3
+    (cond ((and (= amount 1) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 2)))
+	  ((and (= amount 2) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 4)))
+	  ((and (= amount 3) (not (location= number result)))
+	   (inst lea result (make-ea :qword :index number :scale 8)))
+	  (t
+	   (move result number)
+	   (cond ((plusp amount)
+		  ;; We don't have to worry about overflow because of the
+		  ;; result type restriction.
+		  (inst shl result amount))
+		 (t
+		  ;; If the amount is greater than 31, only shift by 31.  We
+		  ;; have to do this because the shift instructions only look
+		  ;; at the low five bits of the result.
+		  (inst sar result (min 31 (- amount)))))))))
+
+(define-vop (fast-ash-left/unsigned=>unsigned)
+  (:translate ash)
+  (:args (number :scs (unsigned-reg) :target result
+		 :load-if (not (and (sc-is number unsigned-stack)
+				    (sc-is result unsigned-stack)
+				    (location= number result))))
+	 (amount :scs (unsigned-reg) :target rcx))
+  (:arg-types unsigned-num positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:results (result :scs (unsigned-reg) :from (:argument 0)
+		    :load-if (not (and (sc-is number unsigned-stack)
+				       (sc-is result unsigned-stack)
+				       (location= number result)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:note "inline ASH")
+  (:generator 4
+    (move result number)
+    (move rcx amount)
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)))
+
+(define-vop (fast-ash-left/signed=>signed)
+  (:translate ash)
+  (:args (number :scs (signed-reg) :target result
+		 :load-if (not (and (sc-is number signed-stack)
+				    (sc-is result signed-stack)
+				    (location= number result))))
+	 (amount :scs (unsigned-reg) :target rcx))
+  (:arg-types signed-num positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:results (result :scs (signed-reg) :from (:argument 0)
+		    :load-if (not (and (sc-is number signed-stack)
+				       (sc-is result signed-stack)
+				       (location= number result)))))
+  (:result-types signed-num)
+  (:policy :fast-safe)
+  (:note "inline ASH")
+  (:generator 4
+    (move result number)
+    (move rcx amount)
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)))
+
+(define-vop (fast-ash/unsigned=>unsigned)
+	    (:translate ash)
+  (:policy :fast-safe)
+  (:args (number :scs (unsigned-reg) :target result)
+	 (amount :scs (signed-reg) :target rcx))
+  (:arg-types unsigned-num signed-num)
+  (:results (result :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num)
+  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:note "inline ASH")
+  (:generator 5
+    (move result number)
+    (move rcx amount)
+    (inst or rcx rcx)
+    (inst jmp :ns POSITIVE)
+    (inst neg rcx)
+    (inst cmp rcx 31)
+    (inst jmp :be OKAY)
+    (inst xor result result)
+    (inst jmp DONE)
+    OKAY
+    (inst shr result :cl)
+    (inst jmp DONE)
+    
+    POSITIVE
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)
+    
+    DONE))
+
+(define-vop (fast-ash/signed=>signed)
+  (:translate ash)
+  (:policy :fast-safe)
+  (:args (number :scs (signed-reg) :target result)
+	 (amount :scs (signed-reg) :target rcx))
+  (:arg-types signed-num signed-num)
+  (:results (result :scs (signed-reg) :from (:argument 0)))
+  (:result-types signed-num)
+  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:note "inline ASH")
+  (:generator 5
+    (move result number)
+    (move rcx amount)
+    (inst or rcx rcx)
+    (inst jmp :ns positive)
+    (inst neg rcx)
+    (inst cmp rcx 31)
+    (inst jmp :be okay)
+    (inst mov rcx 31)
+    OKAY
+    (inst sar result :cl)
+    (inst jmp done)
+      
+    POSITIVE
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)
+      
+    DONE))
+
+
+;;; note documentation for this function is wrong - rtfm
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg) :target res))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 30
+    (move res arg)
+    (inst cmp res 0)
+    (inst jmp :ge POS)
+    (inst not res)
+    POS
+    (inst bsr res res)
+    (inst jmp :z zero)
+    (inst inc res)
+    (inst shl res 2)
+    (inst jmp done)
+    ZERO
+    (inst xor res res)
+    DONE))
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
+  (:generator 30
+    (move result arg)
+
+    (inst mov temp result)
+    (inst shr temp 1)
+    (inst and result #x55555555)
+    (inst and temp #x55555555)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 2)
+    (inst and result #x33333333)
+    (inst and temp #x33333333)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 4)
+    (inst and result #x0f0f0f0f)
+    (inst and temp #x0f0f0f0f)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 8)
+    (inst and result #x00ff00ff)
+    (inst and temp #x00ff00ff)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 16)
+    (inst and result #x0000ffff)
+    (inst and temp #x0000ffff)
+    (inst add result temp)))
+
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg)
+	    :load-if (not (and (sc-is x control-stack)
+			       (sc-is y any-reg))))
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg control-stack)))
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg signed-stack)))
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:info target not-p y))
+
+
+(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
+  `(progn
+     ,@(mapcar
+	#'(lambda (suffix cost signed)
+	    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+					   tran suffix))
+			  ,(intern
+			    (format nil "~:@(FAST-CONDITIONAL~A~)"
+				    suffix)))
+	       (:translate ,tran)
+	       (:generator ,cost
+		 (inst cmp x
+		       ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
+		 (inst jmp (if not-p
+			       ,(if signed not-cond not-unsigned)
+			     ,(if signed cond unsigned))
+		       target))))
+	'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	'(4 3 6 5 6 5)
+	'(t t t t nil nil))))
+
+(define-conditional-vop < :l :b :ge :ae)
+
+(define-conditional-vop > :g :a :le :be)
+
+(define-vop (fast-if-eql/signed fast-conditional/signed)
+  (:translate eql)
+  (:generator 6
+    (inst cmp x y)
+    (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
+  (:translate eql)
+  (:generator 5
+    (cond ((and (sc-is x signed-reg) (zerop y))
+	   (inst test x x))  ; Smaller instruction
+	  (t
+	   (inst cmp x y)))
+    (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
+  (:translate eql)
+  (:generator 6
+    (inst cmp x y)
+    (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
+  (:translate eql)
+  (:generator 5
+    (cond ((and (sc-is x unsigned-reg) (zerop y))
+	   (inst test x x))  ; Smaller instruction
+	  (t
+	   (inst cmp x y)))
+    (inst jmp (if not-p :ne :e) target)))
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+;;; These versions specify a fixnum restriction on their first arg.  We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost.  The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+;;;
+
+(define-vop (fast-eql/fixnum fast-conditional)
+  (:args (x :scs (any-reg)
+	    :load-if (not (and (sc-is x control-stack)
+			       (sc-is y any-reg))))
+	 (y :scs (any-reg control-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:generator 4
+    (inst cmp x y)
+    (inst jmp (if not-p :ne :e) target)))
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+  (:args (x :scs (any-reg descriptor-reg)
+	    :load-if (not (and (sc-is x control-stack)
+			       (sc-is y any-reg))))
+	 (y :scs (any-reg control-stack)))
+  (:arg-types * tagged-num)
+  (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg control-stack)))
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
+	   (inst test x x))  ; Smaller instruction
+	  (t
+	   (inst cmp x (fixnumize y))))
+    (inst jmp (if not-p :ne :e) target)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  (:args (x :scs (any-reg descriptor-reg control-stack)))
+  (:arg-types * (:constant (signed-byte 30)))
+  (:variant-cost 6))
+
+
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+  (:translate merge-bits)
+  (:args (shift :scs (signed-reg unsigned-reg) :target rcx)
+	 (prev :scs (unsigned-reg) :target result)
+	 (next :scs (unsigned-reg)))
+  (:arg-types tagged-num unsigned-num unsigned-num)
+  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 0)) rcx)
+  (:results (result :scs (unsigned-reg) :from (:argument 1)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 4
+    (move rcx shift)
+    (move result prev)
+    (inst shrd result next :cl)))
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg) :target r
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is r unsigned-stack)
+			       (location= x r))))
+	 (y :scs (unsigned-reg)
+	    :load-if (or (not (sc-is y unsigned-stack))
+			 (and (sc-is x unsigned-stack)
+			      (sc-is y unsigned-stack)
+			      (location= x r)))))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)  :from (:argument 0)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (sc-is r unsigned-stack)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe))
+
+(define-vop (32bit-logical-not)
+  (:translate 32bit-logical-not)
+  (:args (x :scs (unsigned-reg) :target r
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is r unsigned-stack)
+			       (location= x r)))))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (sc-is r unsigned-stack)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (move r x)
+    (inst not r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (move r x)
+    (inst and r y)))
+
+(def-source-transform 32bit-logical-nand (x y)
+  `(32bit-logical-not (32bit-logical-and ,x ,y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+  (:translate 32bit-logical-or)
+  (:generator 1
+    (move r x)
+    (inst or r y)))
+
+(def-source-transform 32bit-logical-nor (x y)
+  `(32bit-logical-not (32bit-logical-or ,x ,y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (move r x)
+    (inst xor r y)))
+
+(def-source-transform 32bit-logical-eqv (x y)
+  `(32bit-logical-not (32bit-logical-xor ,x ,y)))
+
+(def-source-transform 32bit-logical-orc1 (x y)
+  `(32bit-logical-or (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-orc2 (x y)
+  `(32bit-logical-or ,x (32bit-logical-not ,y)))
+
+(def-source-transform 32bit-logical-andc1 (x y)
+  `(32bit-logical-and (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-andc2 (x y)
+  `(32bit-logical-and ,x (32bit-logical-not ,y)))
+
+;;; Only the lower 5 bits of the shift amount are significant.
+(define-vop (shift-towards-someplace)
+  (:policy :fast-safe)
+  (:args (num :scs (unsigned-reg) :target r)
+	 (amount :scs (signed-reg) :target rcx))
+  (:arg-types unsigned-num tagged-num)
+  (:temporary (:sc signed-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)))
+  (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+  (:translate shift-towards-start)
+  (:note "SHIFT-TOWARDS-START")
+  (:generator 1
+    (move r num)
+    (move rcx amount)
+    (inst shr r :cl)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:note "SHIFT-TOWARDS-END")
+  (:generator 1
+    (move r num)
+    (move rcx amount)
+    (inst shl r :cl)))
+
+
+
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+  (:translate bignum::%bignum-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+  (:translate bignum::%bignum-set-length)
+  (:policy :fast-safe))
+
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-set)
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:conditional)
+  (:info target not-p)
+  (:generator 3
+    (inst or digit digit)
+    (inst jmp (if not-p :s :ns) target)))
+
+
+;;; For add and sub with carry the sc of carry argument is any-reg so
+;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
+;;; 4. This is easy to deal with and may save a fixnum-word
+;;; conversion.
+;;;
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :target result)
+	 (b :scs (unsigned-reg unsigned-stack) :to :eval)
+	 (c :scs (any-reg) :target temp))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
+  (:results (result :scs (unsigned-reg) :from (:argument 0))
+	    (carry :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (move result a)
+    (move temp c)
+    (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
+    (inst adc result b)
+    (inst mov carry 0)
+    (inst adc carry carry)))
+
+;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
+;;; borrow and 0 for a borrow.
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :to :eval :target result)
+	 (b :scs (unsigned-reg unsigned-stack) :to :result)
+	 (c :scs (any-reg control-stack)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg) :from :eval)
+	    (borrow :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 5
+    (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
+    (move result a)
+    (inst sbb result b)
+    (inst mov borrow 0)
+    (inst adc borrow borrow)
+    (inst xor borrow 1)))
+
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :target rax)
+	 (y :scs (unsigned-reg unsigned-stack))
+	 (carry-in :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) rdx)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move rax x)
+    (inst mul rax y)
+    (inst add rax carry-in)
+    (inst adc rdx 0)
+    (move hi rdx)
+    (move lo rax)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :target rax)
+	 (y :scs (unsigned-reg unsigned-stack))
+	 (prev :scs (unsigned-reg unsigned-stack))
+	 (carry-in :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) rdx)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move rax x)
+    (inst mul rax y)
+    (inst add rax prev)
+    (inst adc rdx 0)
+    (inst add rax carry-in)
+    (inst adc rdx 0)
+    (move hi rdx)
+    (move lo rax)))
+
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg) :target rax)
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) rdx)
+  (:results (hi :scs (unsigned-reg))
+	    (lo :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move rax x)
+    (inst mul rax y)
+    (move hi rdx)
+    (move lo rax)))
+
+(define-vop (bignum-lognot)
+  (:translate bignum::%lognot)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg unsigned-stack) :target r))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move r x)
+    (inst not r)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (any-reg control-stack) :target digit))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)
+		   :load-if (not (and (sc-is fixnum control-stack)
+				      (sc-is digit unsigned-stack)
+				      (location= fixnum digit)))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move digit fixnum)
+    (inst sar digit 2)))
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg) :target rdx)
+	 (div-low :scs (unsigned-reg) :target rax)
+	 (divisor :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)
+		   :to (:result 0) :target quo) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :from (:argument 0)
+		   :to (:result 1) :target rem) rdx)
+  (:results (quo :scs (unsigned-reg))
+	    (rem :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 300
+    (move rdx div-high)
+    (move rax div-low)
+    (inst div rax divisor)
+    (move quo rax)
+    (move rem rdx)))
+
+(define-vop (signify-digit)
+  (:translate bignum::%fixnum-digit-with-correct-sign)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (any-reg signed-reg)
+		 :load-if (not (and (sc-is digit unsigned-stack)
+				    (sc-is res control-stack signed-stack)
+				    (location= digit res)))))
+  (:result-types signed-num)
+  (:generator 1
+    (move res digit)
+    (when (sc-is res any-reg control-stack)
+      (inst shl res 2))))
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
+	 (count :scs (unsigned-reg) :target rcx))
+  (:arg-types unsigned-num positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:results (result :scs (unsigned-reg) :from (:argument 0)
+		    :load-if (not (and (sc-is result unsigned-stack)
+				       (location= digit result)))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result digit)
+    (move rcx count)
+    (inst sar result :cl)))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 1
+    (move result digit)
+    (move rcx count)
+    (inst shr result :cl)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (move result digit)
+    (move rcx count)
+    (inst shl result :cl)))
+
+
+;;;; Static functions.
+
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
+
+
+;;; Support for the Mersenne Twister, MT19937, random number generator
+;;; due to Matsumoto and Nishimura.
+;;;
+;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
+;;; 623-dimensionally equidistributed uniform pseudorandom number
+;;; generator.", ACM Transactions on Modeling and Computer Simulation,
+;;; 1997, to appear.
+;;;
+;;; State:
+;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
+;;;  2:     Index; init. to 1.
+;;;  3-626: State.
+;;;
+(defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
+  (unsigned-byte 32) ())
+;;;
+(define-vop (random-mt19937)
+  (:policy :fast-safe)
+  (:translate random-mt19937)
+  (:args (state :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-unsigned-byte-32)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from (:eval 0) :to :result) tmp)
+  (:results (y :scs (unsigned-reg) :from (:eval 0)))
+  (:result-types unsigned-num)
+  (:generator 50
+    (inst mov k (make-ea :qword :base state
+			 :disp (- (* (+ 2 vm:vector-data-offset) vm:word-bytes)
+				  vm:other-pointer-type)))
+    (inst cmp k 624)
+    (inst jmp :ne no-update)
+    (inst mov tmp state)	; The state is passed in rAX.
+    (inst call (make-fixup 'random-mt19937-update :assembly-routine))
+    ;; Restore k, and set to 0.
+    (inst xor k k)
+    NO-UPDATE
+    ;; y = ptgfsr[k++];
+    (inst mov y (make-ea :qword :base state :index k :scale 4
+			 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes)
+				  vm:other-pointer-type)))
+    ;; y ^= (y >> 11);
+    (inst shr y 11)
+    (inst xor y (make-ea :qword :base state :index k :scale 4
+			 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes)
+				  vm:other-pointer-type)))
+    ;; y ^= (y << 7) & #x9d2c5680
+    (inst mov tmp y)
+    (inst inc k)
+    (inst shl tmp 7)
+    (inst mov (make-ea :qword :base state
+		       :disp (- (* (+ 2 vm:vector-data-offset) vm:word-bytes)
+				vm:other-pointer-type))
+	  k)
+    (inst and tmp #x9d2c5680)
+    (inst xor y tmp)
+    ;; y ^= (y << 15) & #xefc60000
+    (inst mov tmp y)
+    (inst shl tmp 15)
+    (inst and tmp #xefc60000)
+    (inst xor y tmp)
+    ;; y ^= (y >> 18);
+    (inst mov tmp y)
+    (inst shr tmp 18)
+    (inst xor y tmp)))
diff --git a/compiler/amd64/array.lisp b/compiler/amd64/array.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0bd2ccb182509a26aebb83366307e8838950dfb9
--- /dev/null
+++ b/compiler/amd64/array.lisp
@@ -0,0 +1,1595 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/array.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the x86 definitions for array operations.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999.
+;;;
+(in-package :amd64)
+
+
+;;;; Allocator for the array header.
+
+
+(define-vop (make-array-header)
+  (:translate make-array-header)
+  (:policy :fast-safe)
+  (:args (type :scs (any-reg))
+	 (rank :scs (any-reg)))
+  (:arg-types positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg :to :eval) bytes)
+  (:temporary (:sc any-reg :to :result) header)
+  (:temporary (:sc any-reg) temp)
+  (:results (result :scs (descriptor-reg) :from :eval))
+  (:node-var node)
+  (:generator 13
+    (inst lea bytes
+	  (make-ea :qword :base rank
+		   :disp (+ (* (1+ array-dimensions-offset) word-bytes)
+			    lowtag-mask)))
+    (inst and bytes (lognot lowtag-mask))
+    (inst lea header (make-ea :qword :base rank
+			      :disp (fixnumize (1- array-dimensions-offset))))
+    (inst shl header type-bits)
+    (inst or  header type)
+    (inst shr header 2)
+    (pseudo-atomic
+     (allocation result bytes temp node)
+     (inst lea result (make-ea :qword :base result :disp other-pointer-type))
+     (storew header result 0 other-pointer-type))))
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t index) index
+  (flushable))
+(defknown lisp::%set-array-dimension (t index index) index
+  ())
+
+(define-full-reffer %array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%set-array-dimension)
+
+
+(defknown lisp::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 other-pointer-type)
+    (inst shr res type-bits)
+    (inst sub res (1- array-dimensions-offset))))
+
+
+
+;;;; Bounds checking routine.
+
+;;; Note that the immediate SC for the index argument is disabled
+;;; because it is not possible to generate a valid error code SC for
+;;; an immediate value.
+(define-vop (check-bound)
+  (:translate %check-bound)
+  (:policy :fast-safe)
+  (:args (array :scs (descriptor-reg))
+	 (bound :scs (any-reg descriptor-reg))
+	 (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
+  (:arg-types * positive-fixnum tagged-num)
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:result-types positive-fixnum)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index))
+	  (index (if (sc-is index immediate) (fixnumize (tn-value index)) index)))
+      (inst cmp bound index)
+      ;; We use below-or-equal even though it's an unsigned test, because
+      ;; negative indexes appear as real large unsigned numbers.  Therefore,
+      ;; we get the < 0 and >= bound test all rolled into one.
+      (inst jmp :be error)
+      (unless (and (tn-p index) (location= result index))
+        (inst mov result index)))))
+
+
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(eval-when (compile eval)
+
+(defmacro def-full-data-vector-frobs (type element-type &rest scs)
+  `(progn
+     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-ref)
+     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+(eval-when (compile eval)
+
+(defmacro def-half-data-vector-frobs (type element-type &rest scs)
+  `(progn
+     (define-half-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-ref)
+     (define-half-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-half-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+  unsigned-reg)
+(def-half-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+(def-half-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg)
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;; 
+
+(eval-when (compile eval)
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor vm:word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (:note "inline array access")
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (result :scs (unsigned-reg) :from (:argument 0)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
+	 (:generator 20
+	   (move rcx index)
+	   (inst shr rcx ,bit-shift)
+	   (inst mov result
+		 (make-ea :qword :base object :index rcx :scale 4
+			  :disp (- (* vector-data-offset word-bytes)
+				   other-pointer-type)))
+	   (move rcx index)
+	   (inst and rcx ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst shl rcx ,(1- (integer-length bits)))))
+	   (inst shr result :cl)
+	   (inst and result ,(1- (ash 1 bits)))))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type (:constant index))
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:generator 15
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (loadw result object (+ word vector-data-offset) 
+		    other-pointer-type)
+	     (unless (zerop extra)
+	       (inst shr result (* extra ,bits)))
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst and result ,(1- (ash 1 bits)))))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note "inline array store")
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg) :target ptr)
+		(index :scs (unsigned-reg) :target rcx)
+		(value :scs (unsigned-reg immediate) :target result))
+	 (:arg-types ,type positive-fixnum positive-fixnum)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc unsigned-reg) word-index)
+	 (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
+	 (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1))
+		     rcx)
+	 (:generator 25
+	   (move word-index index)
+	   (inst shr word-index ,bit-shift)
+	   (inst lea ptr
+		 (make-ea :qword :base object :index word-index :scale 4
+			  :disp (- (* vector-data-offset word-bytes)
+				   other-pointer-type)))
+	   (loadw old ptr)
+	   (move rcx index)
+	   (inst and rcx ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst shl rcx ,(1- (integer-length bits)))))
+	   (inst ror old :cl)
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst and old ,(lognot (1- (ash 1 bits)))))
+	   (sc-case value
+	     (immediate
+	      (unless (zerop (tn-value value))
+		(inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
+	     (unsigned-reg
+	      (inst or old value)))
+	   (inst rol old :cl)
+	   (storew old ptr)
+	   (sc-case value
+	     (immediate
+	      (inst mov result (tn-value value)))
+	     (unsigned-reg
+	      (move result value)))))
+       (define-vop (,(symbolicate 'data-vector-set-c/ type))
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs (unsigned-reg immediate) :target result))
+	 (:arg-types ,type (:constant index) positive-fixnum)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc unsigned-reg :to (:result 0)) old)
+	 (:generator 20
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (inst mov old
+		   (make-ea :qword :base object
+			    :disp (- (* (+ word vector-data-offset) word-bytes)
+				     other-pointer-type)))
+	     (sc-case value
+	       (immediate
+		(let* ((value (tn-value value))
+		       (mask ,(1- (ash 1 bits)))
+		       (shift (* extra ,bits)))
+		  (unless (= value mask)
+		    (inst and old (lognot (ash mask shift))))
+		  (unless (zerop value)
+		    (inst or old (ash value shift)))))
+	       (unsigned-reg
+		(let ((shift (* extra ,bits)))
+		  (unless (zerop shift)
+		    (inst ror old shift)
+		    (inst and old (lognot ,(1- (ash 1 bits))))
+		    (inst or old value)
+		    (inst rol old shift)))))
+	     (inst mov (make-ea :qword :base object
+				:disp (- (* (+ word vector-data-offset) word-bytes)
+					 other-pointer-type))
+		   old)
+	     (sc-case value
+	       (immediate
+		(inst mov result (tn-value value)))
+	       (unsigned-reg
+		(move result value)))))))))
+
+
+); eval-when (compile eval)
+
+(def-small-data-vector-frobs simple-bit-vector 1)
+(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
+
+;;; And the float variants.
+;;; 
+
+(define-vop (data-vector-ref/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+   (with-empty-tn@fp-top(value)
+     (inst fld (make-ea	:qword :base object :index index :scale 1
+			:disp (- (* vm:vector-data-offset vm:word-bytes)
+				 vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30)))
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+   (with-empty-tn@fp-top(value)
+     (inst fld (make-ea	:qword :base object
+			:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				    (* 4 index))
+				 vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :qword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :qword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (data-vector-set-c/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (single-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30))
+	      single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :qword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :qword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 7
+   (with-empty-tn@fp-top(value)
+     (inst fldd (make-ea :qword :base object :index index :scale 2
+			 :disp (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30)))
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 6
+   (with-empty-tn@fp-top(value)
+     (inst fldd (make-ea :qword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 8 index))
+				  vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 20
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :qword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :qword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+(define-vop (data-vector-set-c/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (double-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30))
+	      double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :qword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :qword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :qword :base index :index index :scale 2))
+    (with-empty-tn@fp-top(value)
+      (inst fldl (make-ea :qword :base object :index temp :scale 1
+			  :disp (- (* vm:vector-data-offset vm:word-bytes)
+				   vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 6
+   (with-empty-tn@fp-top(value)
+     (inst fldl (make-ea :qword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 12 index))
+				  vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (long-reg) :target result))
+  (:arg-types simple-array-long-float positive-fixnum long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :qword :base index :index index :scale 2))
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float
+	    (make-ea :qword :base object :index temp :scale 1
+		     :disp (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float
+	    (make-ea :qword :base object :index temp :scale 1
+		     :disp (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float (make-ea :qword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+	     ;; Value is in ST0 but not result.
+	     (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float (make-ea :qword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+;;; Complex float variants.
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-single-float positive-fixnum)
+  (:results (value :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fld (make-ea :qword :base object :index index :scale 2
+			   :disp (- (* vm:vector-data-offset vm:word-bytes)
+				    vm:other-pointer-type)))))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fld (make-ea :qword :base object :index index :scale 2
+			   :disp (- (* (1+ vm:vector-data-offset)
+				       vm:word-bytes)
+				    vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 4
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fld (make-ea :qword :base object
+			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				       (* 8 index))
+				    vm:other-pointer-type)))))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fld (make-ea :qword :base object
+			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				       (* 8 index) 4)
+				    vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:arg-types simple-array-complex-single-float positive-fixnum
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fst (make-ea :qword :base object :index index :scale 2
+				:disp (- (* vm:vector-data-offset
+					    vm:word-bytes)
+					 vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fst result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fst (make-ea :qword :base object :index index :scale 2
+				:disp (- (* vm:vector-data-offset
+					    vm:word-bytes)
+					 vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fst value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fst result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fst (make-ea :qword :base object :index index :scale 2
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     4)
+				  vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fst result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 4
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fst (make-ea :qword :base object
+				:disp (- (+ (* vm:vector-data-offset
+					       vm:word-bytes)
+					    (* 8 index))
+					 vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fst result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fst (make-ea :qword :base object
+				:disp (- (+ (* vm:vector-data-offset
+					       vm:word-bytes)
+					    (* 8 index))
+					 vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fst value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fst result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fst (make-ea :qword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 8 index) 4)
+				  vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fst result-imag))
+      (inst fxch value-imag))))
+
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-float positive-fixnum)
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 7
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldd (make-ea :qword :base object :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldd (make-ea :qword :base object :index index :scale 4
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 6
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldd (make-ea :qword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index))
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldd (make-ea :qword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index) 8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:arg-types simple-array-complex-double-float positive-fixnum
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 20
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :qword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :qword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :qword :base object :index index :scale 4
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 19
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :qword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :qword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :qword :base object
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      (* 16 index) 8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :qword :base index :index index :scale 2))
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldl (make-ea :qword :base object :index temp :scale 2
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldl (make-ea :qword :base object :index temp :scale 2
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 6
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldl (make-ea :qword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index))
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldl (make-ea :qword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index) 12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:arg-types simple-array-complex-long-float positive-fixnum
+	      complex-long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :qword :base index :index index :scale 2))
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :qword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :qword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :qword :base object :index temp :scale 2
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
+	      complex-long-float)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 19
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :qword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :qword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :qword :base object
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+			    (* 24 index) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+
+;;;;
+;;;; dtc expanded and fixed the following:
+
+
+
+;;; unsigned-byte-8
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (inst movzx value
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (inst movzx value
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg signed-reg) :target rax))
+  (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      rax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (move rax value)
+    (inst mov (make-ea :byte :base object :index index :scale 1
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  al-tn)
+    (move result rax)))
+
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg signed-reg) :target rax))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
+	      positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      rax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (move rax value)
+    (inst mov (make-ea :byte :base object
+		       :disp (- (+ (* vector-data-offset word-bytes) index)
+				other-pointer-type))
+	  al-tn)
+    (move result rax)))
+
+
+;;; unsigned-byte-16
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (inst movzx value
+	  (make-ea :word :base object :index index :scale 2
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (inst movzx value
+	  (make-ea :word :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg signed-reg) :target rax))
+  (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      rax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (move rax value)
+    (inst mov (make-ea :word :base object :index index :scale 2
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  ax-tn)
+    (move result rax)))
+
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg signed-reg) :target rax))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
+	      positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      rax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (move rax value)
+    (inst mov (make-ea :word :base object
+		       :disp (- (+ (* vector-data-offset word-bytes)
+				   (* 2 index))
+				other-pointer-type))
+	  ax-tn)
+    (move result rax)))
+
+
+;;; simple-string
+
+(define-vop (data-vector-ref/simple-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-string positive-fixnum)
+  (:temporary (:sc unsigned-reg ; byte-reg
+		   :offset rax-offset ; al-offset
+		   :target value
+		   :from (:eval 0) :to (:result 0))
+	      rax)
+  (:ignore rax)
+  (:results (value :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 5
+    (inst mov al-tn
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))
+    (move value al-tn)))
+
+(define-vop (data-vector-ref-c/simple-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-string (:constant (signed-byte 30)))
+  (:temporary (:sc unsigned-reg :offset rax-offset :target value
+		   :from (:eval 0) :to (:result 0))
+	      rax)
+  (:ignore rax)
+  (:results (value :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 4
+    (inst mov al-tn
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type)))
+    (move value al-tn)))
+
+
+(define-vop (data-vector-set/simple-string)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (base-char-reg)))
+  (:arg-types simple-string positive-fixnum base-char)
+  (:results (result :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 5 
+    (inst mov (make-ea :byte :base object :index index :scale 1
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  value)
+    (move result value)))
+
+
+(define-vop (data-vector-set/simple-string-c)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (base-char-reg)))
+  (:info index)
+  (:arg-types simple-string (:constant (signed-byte 30)) base-char)
+  (:results (result :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 4
+   (inst mov (make-ea :byte :base object
+		      :disp (- (+ (* vector-data-offset word-bytes) index)
+			       other-pointer-type))
+	 value)
+   (move result value)))
+
+
+;;; signed-byte-8
+
+(define-vop (data-vector-ref/simple-array-signed-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-signed-byte-8 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 5
+    (inst movsx value
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 4
+    (inst movsx value
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-signed-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (signed-reg) :target rax))
+  (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      rax)
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 5
+    (move rax value)
+    (inst mov (make-ea :byte :base object :index index :scale 1
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  al-tn)
+    (move result rax)))
+
+(define-vop (data-vector-set-c/simple-array-signed-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (signed-reg) :target rax))
+  (:info index)
+  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
+	      tagged-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      rax)
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 4
+    (move rax value)
+    (inst mov (make-ea :byte :base object
+		       :disp (- (+ (* vector-data-offset word-bytes) index)
+				other-pointer-type))
+	  al-tn)
+    (move result rax)))
+
+;;; signed-byte-16
+
+(define-vop (data-vector-ref/simple-array-signed-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-signed-byte-16 positive-fixnum)
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 5
+    (inst movsx value
+	  (make-ea :word :base object :index index :scale 2
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
+  (:results (value :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 4
+    (inst movsx value
+	  (make-ea :word :base object
+		   :disp (- (+ (* vector-data-offset word-bytes)
+			       (* 2 index))
+			    other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-signed-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (signed-reg) :target rax))
+  (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
+  (:temporary (:sc signed-reg :offset rax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      rax)
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 5
+    (move rax value)
+    (inst mov (make-ea :word :base object :index index :scale 2
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  ax-tn)
+    (move result rax)))
+
+(define-vop (data-vector-set-c/simple-array-signed-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (signed-reg) :target rax))
+  (:info index)
+  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
+  (:temporary (:sc signed-reg :offset rax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      rax)
+  (:results (result :scs (signed-reg)))
+  (:result-types tagged-num)
+  (:generator 4
+    (move rax value)
+    (inst mov
+	  (make-ea :word :base object
+		   :disp (- (+ (* vector-data-offset word-bytes)
+			       (* 2 index))
+			    other-pointer-type))
+	  ax-tn)
+    (move result rax)))
+
+
+
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector.
+;;;
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      single-float))
+;;;
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      double-float))
+;;;
+#+long-float
+(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
+  (:translate %raw-ref-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#+long-float
+(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
+  (:translate %raw-ref-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+#+long-float
+(define-vop (raw-set-double data-vector-set/simple-array-long-float)
+  (:translate %raw-set-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
+#+long-float
+(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
+  (:translate %raw-set-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      long-float))
+
+;;;; Complex-float raw structure slot accessors.
+
+(define-vop (raw-ref-complex-single
+	     data-vector-ref/simple-array-complex-single-float)
+  (:translate %raw-ref-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-complex-single-c
+	     data-vector-ref-c/simple-array-complex-single-float)
+  (:translate %raw-ref-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+(define-vop (raw-set-complex-single
+	     data-vector-set/simple-array-complex-single-float)
+  (:translate %raw-set-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
+(define-vop (raw-set-complex-single-c
+	     data-vector-set-c/simple-array-complex-single-float)
+  (:translate %raw-set-complex-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      complex-single-float))
+;;;
+(define-vop (raw-ref-complex-double
+	     data-vector-ref/simple-array-complex-double-float)
+  (:translate %raw-ref-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-complex-double-c
+	     data-vector-ref-c/simple-array-complex-double-float)
+  (:translate %raw-ref-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+(define-vop (raw-set-complex-double
+	     data-vector-set/simple-array-complex-double-float)
+  (:translate %raw-set-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-double-float))
+(define-vop (raw-set-complex-double-c
+	     data-vector-set-c/simple-array-complex-double-float)
+  (:translate %raw-set-complex-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      complex-double-float))
+;;;
+#+long-float
+(define-vop (raw-ref-complex-long
+	     data-vector-ref/simple-array-complex-long-float)
+  (:translate %raw-ref-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#+long-float
+(define-vop (raw-ref-complex-long-c
+	     data-vector-ref-c/simple-array-complex-long-float)
+  (:translate %raw-ref-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+#+long-float
+(define-vop (raw-set-complex-long
+	     data-vector-set/simple-array-complex-long-float)
+  (:translate %raw-set-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-long-float))
+#+long-float
+(define-vop (raw-set-complex-long-c
+	     data-vector-set-c/simple-array-complex-long-float)
+  (:translate %raw-set-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      complex-long-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %set-raw-bits)
+
+
+;;;; Conditional setters.
+
+(export 'kernel::data-vector-set-conditional "KERNEL")
+(defknown data-vector-set-conditional (array index t t) t
+  (unsafe c::explicit-check))
+
+(define-full-conditional-setter data-vector-set-conditional/simple-vector
+  simple-vector vector-data-offset other-pointer-type
+  (descriptor-reg any-reg) *
+  data-vector-set-conditional)
+
+
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
diff --git a/compiler/amd64/c-call.lisp b/compiler/amd64/c-call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..416d75123426172531c78b2646bd809005c4a32a
--- /dev/null
+++ b/compiler/amd64/c-call.lisp
@@ -0,0 +1,367 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/c-call.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Debugging and Enhancements by Douglas Crosher 1996,1997,1998,1999.
+;;;
+
+(in-package :amd64)
+(use-package :alien)
+(use-package :alien-internals)
+
+;; The move-argument vop is going to store args on the stack for
+;; call-out. These tn's will be used for that. move-arg is normally
+;; used for things going down the stack but C wants to have args
+;; indexed in the positive direction.
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
+		 (sc-number-or-lose sc-name *backend*)
+		 offset))
+
+(defstruct arg-state
+  (register-args 0)
+  (stack-frame-size 0))
+
+(defun int-arg (state prim-type reg-sc stack-sc)
+  (let ((reg-args (arg-state-register-args state)))
+    (cond ((< reg-args 4) ; Should be 6 (r8 and r9)
+	   (setf (arg-state-register-args state) (1+ reg-args))
+	   (my-make-wired-tn prim-type reg-sc (ecase reg-args
+						(0 #.rdi-offset)
+						(1 #.rsi-offset)
+						(2 #.rdx-offset)
+						(3 #.rcx-offset))))
+	  (t
+	   (let ((frame-size (arg-state-stack-frame-size state)))
+	     (setf (arg-state-stack-frame-size state) (1+ frame-size))
+	     (my-make-wired-tn prim-type stack-sc frame-size))))))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (if (alien-integer-type-signed type)
+      (int-arg state 'signed-byte-64 'signed-reg 'signed-stack)
+      (int-arg state 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
+
+#+long-float
+(def-alien-type-method (long-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
+    (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+    (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
+
+(defstruct result-state
+  (num-results 0))
+
+(defun result-reg-offset (slot)
+  (ecase slot
+    (0 rax-offset)
+    (1 rdx-offset)))
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (multiple-value-bind
+	(ptype reg-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-64 'signed-reg)
+	    (values 'unsigned-byte-64 'unsigned-reg))
+      (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
+
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'system-area-pointer 'sap-reg
+		      (result-reg-offset num-results))))
+
+#+long-float
+(def-alien-type-method (long-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
+
+(def-alien-type-method (double-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
+
+(def-alien-type-method (values :result-tn) (type state)
+  (let ((values (alien-values-type-values type)))
+    (when (> (length values) 2)
+      (error "Too many result values from c-call."))
+    (mapcar #'(lambda (type)
+		(invoke-alien-type-method :result-tn type state))
+	    (alien-values-type-values type))))
+
+(def-vm-support-routine make-call-out-tns (type)
+  (let ((arg-state (make-arg-state)))
+    (collect ((arg-tns))
+      (dolist (arg-type (alien-function-type-arg-types type))
+	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+      (values (my-make-wired-tn 'positive-fixnum 'any-reg rsp-offset)
+	      (* (arg-state-stack-frame-size arg-state) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method :result-tn
+					(alien-function-type-result-type type)
+					(make-result-state))))))
+
+(deftransform %alien-funcall ((function type &rest args))
+  (assert (c::constant-continuation-p type))
+  (let* ((type (c::continuation-value type))
+	 (arg-types (alien-function-type-arg-types type))
+	 (result-type (alien-function-type-result-type type)))
+    (assert (= (length arg-types) (length args)))
+    (if (or (some #'(lambda (type)
+		      (and (alien-integer-type-p type)
+			   (> (alien::alien-integer-type-bits type) 32)))
+		  arg-types)
+	    (and (alien-integer-type-p result-type)
+		 (> (alien::alien-integer-type-bits result-type) 32)))
+	(collect ((new-args) (lambda-vars) (new-arg-types))
+	  (dolist (type arg-types)
+	    (let ((arg (gensym)))
+	      (lambda-vars arg)
+	      (cond ((and (alien-integer-type-p type)
+			  (> (alien::alien-integer-type-bits type) 32))
+		     (new-args `(logand ,arg #xffffffff))
+		     (new-args `(ash ,arg -32))
+		     (new-arg-types (parse-alien-type '(unsigned 32)))
+		     (if (alien-integer-type-signed type)
+			 (new-arg-types (parse-alien-type '(signed 32)))
+			 (new-arg-types (parse-alien-type '(unsigned 32)))))
+		    (t
+		     (new-args arg)
+		     (new-arg-types type)))))
+	  (cond ((and (alien-integer-type-p result-type)
+		      (> (alien::alien-integer-type-bits result-type) 32))
+		 (let ((new-result-type
+			(let ((alien::*values-type-okay* t))
+			  (parse-alien-type
+			   (if (alien-integer-type-signed result-type)
+			       '(values (unsigned 32) (signed 32))
+			       '(values (unsigned 32) (unsigned 32)))))))
+		   `(lambda (function type ,@(lambda-vars))
+		      (declare (ignore type))
+		      (multiple-value-bind (low high)
+			  (%alien-funcall function
+					  ',(make-alien-function-type
+					     :arg-types (new-arg-types)
+					     :result-type new-result-type)
+					  ,@(new-args))
+			(logior low (ash high 32))))))
+		(t
+		 `(lambda (function type ,@(lambda-vars))
+		    (declare (ignore type))
+		    (%alien-funcall function
+				    ',(make-alien-function-type
+				       :arg-types (new-arg-types)
+				       :result-type result-type)
+				    ,@(new-args))))))
+	(c::give-up))))
+
+(define-vop (foreign-symbol-code-address)
+  (:translate #+linkage-table foreign-symbol-code-address
+	      #-linkage-table foreign-symbol-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+   (inst mov-imm res (make-fixup (extern-alien-name foreign-symbol)
+			     :foreign))))
+
+(define-vop (foreign-symbol-data-address)
+  (:translate foreign-symbol-data-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+   (inst mov res (make-fixup (extern-alien-name foreign-symbol)
+			     :foreign-data))))
+
+(define-vop (call-out)
+  (:args (function :scs (sap-reg))
+	 (args :more t))
+  (:results (results :more t))
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :eval :to :result) rax)
+  (:temporary (:sc unsigned-reg :offset rbx-offset
+		   :from :eval :to :result) rbx)
+  (:temporary (:sc unsigned-reg :offset rcx-offset
+		   :from :eval :to :result) rcx)
+  (:temporary (:sc unsigned-reg :offset rdx-offset
+		   :from :eval :to :result) rdx)
+  (:node-var node)
+  (:vop-var vop)
+  (:save-p t)
+  (:ignore args rcx rdx)
+  (:generator 0 
+    (cond ((policy node (> space speed))
+	   (move rax function)
+	   (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
+	  (t
+	   (move rbx function)
+	   ;; With variable arguments, rax passes information about the number of
+	   ;; SSE register used. This is unnecessary for normal functions, but
+	   ;; I don't know how to distinguish them.
+	   (inst xor rax rax)
+	   
+	   ;; Setup the NPX for C; all the FP registers need to be
+	   ;; empty; pop them all.
+	   (dotimes (i 8)
+	     (fp-pop))
+
+	   (inst call rbx)
+	   ;; To give the debugger a clue. XX not really internal-error?
+	   (note-this-location vop :internal-error)
+
+	   ;; Restore the NPX for lisp; insure no regs are empty.
+	   (dotimes (i 7)
+	     (inst fldz))
+
+	   (if (and results
+		    (location= (tn-ref-tn results) fr0-tn))
+	       ;; The return result is in fr0.
+	       (inst fxch fr7-tn) ; move the result back to fr0
+	       (inst fldz)) ; insure no regs are empty
+	   ))))
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:generator 0
+    (assert (location= result rsp-tn))
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+	(inst sub rsp-tn delta)))
+    (move result rsp-tn)))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+	(inst add rsp-tn delta)))))
+
+(define-vop (alloc-alien-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:generator 0
+    (assert (not (location= result rsp-tn)))
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+	(inst mov result (+ nil-value
+			    (static-symbol-offset '*alien-stack*)
+			    (ash symbol-value-slot word-shift)
+			    (- other-pointer-type)))
+	(inst sub (make-ea :qword :base result)
+	      delta)))
+    (load-symbol-value result *alien-stack*)))
+
+(define-vop (dealloc-alien-stack-space)
+  (:temporary (:sc any-reg) temp-tn) ; from/to?
+  (:info amount)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+	(inst mov temp-tn (+ nil-value
+			     (static-symbol-offset '*alien-stack*)
+			     (ash symbol-value-slot word-shift)
+			     (- other-pointer-type)))
+	(inst add (make-ea :qword :base temp-tn)
+	      delta)))))
+
+;;; Support for callbacks to Lisp.
+(export '(make-callback-trampoline callback-accessor-form))
+
+(defun callback-accessor-form (type sp offset)
+  `(alien:deref (sap-alien 
+		 (sys:sap+ ,sp ,offset)
+		 (* ,type))))
+
+(defun make-callback-trampoline (index return-type)
+  "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+  (let* ((segment (make-segment))
+	 (rax amd64::rax-tn)
+	 (rdx amd64::rdx-tn)
+	 (rbp amd64::rbp-tn)
+	 (rsp amd64::rsp-tn)
+	 ([rbp-8] (amd64::make-ea :qword :base rbp :disp -8))
+	 ([rbp-4] (amd64::make-ea :qword :base rbp :disp -4)))
+    (assemble (segment)
+	      (inst push rbp)			    ; save old frame pointer
+	      (inst mov  rbp rsp)		    ; establish new frame
+	      (inst mov  rax rsp)		    ; 
+	      (inst sub  rax 8)		            ; place for result 
+	      (inst push rax)			    ; arg2
+	      (inst add  rax 16)		    ; arguments  
+	      (inst push rax)			    ; arg1
+	      (inst push (ash index 2))		    ; arg0
+	      (inst push (alien::address-of-call-callback))     ; function
+	      (inst mov  rax (alien::address-of-funcall3))
+	      (inst call rax)
+	      ;; now put the result into the right register
+	      (etypecase return-type
+		(alien::integer-64$
+		 (inst mov rax [rbp-8])
+		 (inst mov rdx [rbp-4]))
+		((or alien::integer$ alien::pointer$ alien::sap$)
+		 (inst mov rax [rbp-8]))
+		(alien::single$
+		 (inst fld  [rbp-8]))
+		(alien::double$
+		 (inst fldd [rbp-8]))
+		(alien::void$ ))
+	      (inst mov rsp rbp)		   ; discard frame
+	      (inst pop rbp)			   ; restore frame pointer
+	      (inst ret))
+    (let* ((length (finalize-segment segment)))
+      (prog1 (alien::segment-to-trampoline segment length)
+	(release-segment segment)))))
+
+
diff --git a/compiler/amd64/call.lisp b/compiler/amd64/call.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..afbf04f252d92df51fba65478efcb3d240c69383
--- /dev/null
+++ b/compiler/amd64/call.lisp
@@ -0,0 +1,1483 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/call.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the AMD64.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;;
+(in-package :amd64)
+
+;;;
+
+
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location  --  Interface
+;;;
+;;;    Return a wired TN describing the N'th full call argument passing
+;;; location.
+;;;
+(def-vm-support-routine standard-argument-location (n)
+  (declare (type unsigned-byte n))
+  (if (< n register-arg-count)
+      (make-wired-tn *any-primitive-type* descriptor-reg-sc-number
+		     (nth n register-arg-offsets))
+      (make-wired-tn *any-primitive-type* control-stack-sc-number n)))
+
+
+;;; Make-Return-PC-Passing-Location  --  Interface
+;;;
+;;; Make a passing location TN for a local call return PC.
+;;;
+;;; Always wire the return PC location to the stack in its standard
+;;; location.
+;;;
+;;; No problems.
+;#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (declare (ignore standard))
+  (make-wired-tn (primitive-type-or-lose 'system-area-pointer *backend*)
+		 sap-stack-sc-number return-pc-save-offset))
+;;;
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (let ((ptype (primitive-type-or-lose 'system-area-pointer *backend*)))
+    (if standard
+	(make-wired-tn ptype sap-stack-sc-number return-pc-save-offset)
+	(make-normal-tn ptype))))
+
+;;; Make-Old-FP-Passing-Location  --  Interface
+;;;
+;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in.
+;;;
+;;; This is wired in both the standard and the local-call
+;;; conventions, because we want to be able to assume it's always there.
+;;; Besides, the x86 doesn't have enough registers to really make it
+;;; profitable to pass it in a register.
+;;;
+;;; No problems
+;#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (declare (ignore standard))
+  (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+		 ocfp-save-offset))
+;;;
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (if standard
+      (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+		     ocfp-save-offset)
+      (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
+;;;
+;;; Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function.  We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-old-fp-save-location (env)
+  (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type*
+					    control-stack-sc-number
+					    ocfp-save-offset)
+			     env))
+;;;
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-old-fp-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+   (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+		  ocfp-save-offset)))
+
+;;;
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-return-pc-save-location (env)
+  (environment-debug-live-tn
+   (make-wired-tn (primitive-type-or-lose 'system-area-pointer *backend*)
+		  sap-stack-sc-number return-pc-save-offset)
+   env))
+;;;
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-return-pc-save-location (env)
+  (let ((ptype (primitive-type-or-lose 'system-area-pointer *backend*)))
+    (specify-save-tn
+     (environment-debug-live-tn (make-normal-tn ptype) env)
+     (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset))))
+
+;;; Make-Argument-Count-Location  --  Interface
+;;;
+;;;    Make a TN for the standard argument count passing location.  We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(def-vm-support-routine make-argument-count-location ()
+  (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rcx-offset))
+
+
+;;; MAKE-NFP-TN  --  Interface
+;;;
+;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
+;;; once per component, and is component-live.
+;;;
+(def-vm-support-routine make-nfp-tn ()
+  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-number-stack-pointer-tn ()
+  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+;;; Make-Unknown-Values-Locations  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(def-vm-support-routine make-unknown-values-locations ()
+  (list (make-stack-pointer-tn)
+	(make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; Select-Component-Format  --  Interface
+;;;
+;;;    This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure.  We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+;;; For the x86 the first constant is a pointer to a list of fixups,
+;;; or nil if the code object has none.
+;;;
+(def-vm-support-routine select-component-format (component)
+  (declare (type component component))
+  (dotimes (i (1+ code-constants-offset))
+    (vector-push-extend nil
+			(ir2-component-constants (component-info component))))
+  (undefined-value))
+
+
+;;;; Frame hackery:
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg control-stack)))
+  (:generator 1
+    (move val rbp-tn)))
+
+;;; We don't have a seperate NFP, so we don't need to do anything here.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val))
+  (:ignore val)
+  (:generator 1
+    nil))
+
+
+(define-vop (xep-allocate-frame)
+  (:info start-lab copy-more-arg-follows)
+  (:vop-var vop)
+  (:generator 1
+    ;; Make sure the function is aligned, and drop a label pointing to this
+    ;; function header.
+    (align lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    ;; Skip space for the function header.
+    (inst function-header-word)
+    (dotimes (i (1- vm:function-code-offset))
+      (inst qword 0))
+
+    ;; The start of the actual code.
+    ;; Save the return-pc.
+    (popw rbp-tn (- (1+ return-pc-save-offset)))
+
+    ;; If copy-more-arg follows it will allocate the correct stack
+    ;; size. The stack is not allocated first here as this may expose
+    ;; args on the stack if they take up more space than the frame!
+    (unless copy-more-arg-follows
+      ;; The args fit within the frame so just allocate the frame.
+      (inst lea rsp-tn
+	    (make-ea :qword :base rbp-tn
+		     :disp (- (* vm:word-bytes
+				 (max 3 (sb-allocated-size 'stack)))))))
+
+    (trace-table-entry trace-table-normal)))
+
+;;; This is emitted directly before either a known-call-local, call-local,
+;;; or a multiple-call-local.  All it does is allocate stack space for the
+;;; callee (who has the same size stack as us).
+;;; 
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg control-stack))
+	    (nfp))
+  (:info callee)
+  (:ignore nfp callee)
+  (:generator 2
+    (move res rsp-tn)
+    (inst sub rsp-tn (* vm:word-bytes (sb-allocated-size 'stack)))))
+
+;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
+;;; is the number of arguments passed.  We allocate at least 3 slots, because
+;;; the XEP noise is going to want to use them before it can extend the stack.
+;;;
+(define-vop (allocate-full-call-frame)
+  (:info nargs)
+  (:results (res :scs (any-reg control-stack)))
+  (:generator 2
+    (move res rsp-tn)
+    (inst sub rsp-tn (* (max nargs 3) vm:word-bytes))))
+
+
+
+;;; Default-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return-point from an unknown-values call for a
+;;; fixed number of values.  Values is the head of the TN-Ref list for the
+;;; locations that the values are to be received into.  Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;;    This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 3, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;;    If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case we have to do three things:
+;;;  -- Default unsupplied register values.  This need only be done when a
+;;;     single value is returned, since register values are defaulted by the
+;;;     called in the non-single case.
+;;;  -- Default unsupplied stack values.  This needs to be done whenever there
+;;;     are stack values.
+;;;  -- Reset SP.  This must be done whenever other than 1 value is returned,
+;;;     regardless of the number of values desired.
+;;;
+;;;
+(defun default-unknown-values (vop values nvals)
+  (declare (type (or tn-ref null) values)
+	   (type unsigned-byte nvals))
+  (cond
+   ((<= nvals 1)
+    (note-this-location vop :single-value-return)
+    (inst mov rsp-tn rbx-tn))
+   ((<= nvals register-arg-count)
+    (let ((regs-defaulted (gen-label)))
+      (note-this-location vop :unknown-return)
+      (inst jmp-short regs-defaulted)
+      ;; Default the unsuppled registers.
+      (let* ((2nd-tn-ref (tn-ref-across values))
+	     (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+	(inst mov 2nd-tn nil-value)
+	(when (> nvals 2)
+	  (loop
+	    for tn-ref = (tn-ref-across 2nd-tn-ref)
+	    then (tn-ref-across tn-ref)
+	    for count from 2 below register-arg-count
+	    do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+      (inst mov rbx-tn rsp-tn)
+      (emit-label regs-defaulted)
+      (inst mov rsp-tn rbx-tn)))
+   ((<= nvals 7)
+    ;; Number of bytes depends on the relative jump instructions. Best
+    ;; case is 31+(n-3)*14, worst case is 35+(n-3)*18.  For nvals=6
+    ;; that is 73/89 bytes, and for nvals=7 that is 87/107 bytes which
+    ;; is likely better than using the blt below.
+    (let ((regs-defaulted (gen-label))
+	  (defaulting-done (gen-label))
+	  (default-stack-slots (gen-label)))
+      (note-this-location vop :unknown-return)
+      ;; Branch off to the MV case.
+      (inst jmp-short regs-defaulted)
+      ;; Do the single value case.
+      ;; Default the register args
+      (inst mov rax-tn nil-value)
+      (do ((i 1 (1+ i))
+	   (val (tn-ref-across values) (tn-ref-across val)))
+	  ((= i (min nvals register-arg-count)))
+	(inst mov (tn-ref-tn val) rax-tn))
+
+      ;; Fake other registers so it looks like we returned with all the
+      ;; registers filled in.
+      (move rbx-tn rsp-tn)
+      (inst push rdx-tn)
+      (inst jmp default-stack-slots)
+      
+      (emit-label regs-defaulted)
+
+      (inst mov rax-tn nil-value)
+      (storew rdx-tn rbx-tn -1)
+      (collect ((defaults))
+	(do ((i register-arg-count (1+ i))
+	     (val (do ((i 0 (1+ i))
+		       (val values (tn-ref-across val)))
+		      ((= i register-arg-count) val))
+		  (tn-ref-across val)))
+	    ((null val))
+	  (let ((default-lab (gen-label))
+		(tn (tn-ref-tn val)))
+	    (defaults (cons default-lab tn))
+
+	    (inst cmp rcx-tn (fixnumize i))
+	    (inst jmp :be default-lab)
+	    (loadw rdx-tn rbx-tn (- (1+ i)))
+	    (inst mov tn rdx-tn)))
+	    
+	(emit-label defaulting-done)
+	(loadw rdx-tn rbx-tn -1)
+	(move rsp-tn rbx-tn)
+	    
+	(let ((defaults (defaults)))
+	  (when defaults
+	    (assemble (*elsewhere*)
+	      (trace-table-entry trace-table-function-prologue)
+	      (emit-label default-stack-slots)
+	      (dolist (default defaults)
+		(emit-label (car default))
+		(inst mov (cdr default) rax-tn))
+	      (inst jmp defaulting-done)
+	      (trace-table-entry trace-table-normal)))))))
+   (t
+    ;; 91 bytes for this branch.
+    (let ((regs-defaulted (gen-label))
+	  (restore-rdi (gen-label))
+	  (no-stack-args (gen-label))
+	  (default-stack-vals (gen-label))
+	  (count-okay (gen-label)))
+      (note-this-location vop :unknown-return)
+      ;; Branch off to the MV case.
+      (inst jmp-short regs-defaulted)
+
+      ;; Default the register args, and set up the stack as if we entered
+      ;; the MV return point.
+      (inst mov rbx-tn rsp-tn)
+      (inst push rdx-tn)
+      (inst mov rdi-tn nil-value)
+      (inst push rdi-tn)
+      (inst mov rsi-tn rdi-tn)
+      ;; Compute a pointer to where to put the [defaulted] stack values.
+      (emit-label no-stack-args)
+      (inst lea rdi-tn
+	    (make-ea :qword :base rbp-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Load RAX with NIL so we can quickly store it, and set up stuff
+      ;; for the loop.
+      (inst mov rax-tn nil-value)
+      (inst std)
+      (inst mov rcx-tn (- nvals register-arg-count))
+      ;; Jump into the default loop.
+      (inst jmp default-stack-vals)
+
+      ;; The regs are defaulted.  We need to copy any stack arguments,
+      ;; and then default the remaining stack arguments.
+      (emit-label regs-defaulted)
+      ;; Save RDI.
+      (storew rdi-tn rbx-tn (- (1+ 1)))
+      ;; Compute the number of stack arguments, and if it's zero or less,
+      ;; don't copy any stack arguments.
+      (inst sub rcx-tn (fixnumize register-arg-count))
+      (inst jmp :le no-stack-args)
+
+      ;; Throw away any unwanted args.
+      (inst cmp rcx-tn (fixnumize (- nvals register-arg-count)))
+      (inst jmp :be count-okay)
+      (inst mov rcx-tn (fixnumize (- nvals register-arg-count)))
+      (emit-label count-okay)
+      ;; Save the number of stack values.
+      (inst mov rax-tn rcx-tn)
+      ;; Compute a pointer to where the stack args go.
+      (inst lea rdi-tn
+	    (make-ea :qword :base rbp-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Save RSI, and compute a pointer to where the args come from.
+      (storew rsi-tn rbx-tn (- (1+ 2)))
+      (inst lea rsi-tn
+	    (make-ea :qword :base rbx-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Do the copy.
+      (inst shr rcx-tn 2)		; make word count
+      (inst std)
+      (inst rep)
+      (inst movs :qword)
+      ;; Restore RSI.
+      (loadw rsi-tn rbx-tn (- (1+ 2)))
+      ;; Now we have to default the remaining args.  Find out how many.
+      (inst sub rax-tn (fixnumize (- nvals register-arg-count)))
+      (inst neg rax-tn)
+      ;; If none, then just blow out of here.
+      (inst jmp :le restore-rdi)
+      (inst mov rcx-tn rax-tn)
+      (inst shr rcx-tn 2)	; word count
+      ;; Load RAX with NIL for fast storing.
+      (inst mov rax-tn nil-value)
+      ;; Do the store.
+      (emit-label default-stack-vals)
+      (inst rep)
+      (inst stos rax-tn)
+      ;; Restore RDI, and reset the stack.
+      (emit-label restore-rdi)
+      (loadw rdi-tn rbx-tn (- (1+ 1)))
+      (inst mov rsp-tn rbx-tn))))
+  (undefined-value))
+
+
+
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;;    We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;;    When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;;    When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;;    Args and Nargs are TNs wired to the named locations.  We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count)
+  (declare (type tn args nargs start count))
+  (let ((variable-values (gen-label))
+	(done (gen-label)))
+    (inst jmp-short variable-values)
+    
+    (inst mov start rsp-tn)
+    (inst push (first register-arg-tns))
+    (inst mov count (fixnumize 1))
+    (inst jmp done)
+
+    (emit-label variable-values)
+    ;; dtc: this writes the registers onto the stack even if they are
+    ;; not needed, only the number specified in ecx are used and have
+    ;; stack allocated to them. No harm is done.
+    (loop
+      for arg in register-arg-tns
+      for i downfrom -1
+      do (storew arg args i))
+    (move start args)
+    (move count nargs)
+
+    (emit-label done))
+  (undefined-value))
+
+
+;;; VOP that can be inherited by unknown values receivers.  The main thing this
+;;; handles is allocation of the result temporaries.
+;;;
+(define-vop (unknown-values-receiver)
+  (:temporary (:sc descriptor-reg :offset rbx-offset
+		   :from :eval :to (:result 0))
+	      values-start)
+  (:temporary (:sc any-reg :offset rcx-offset
+	       :from :eval :to (:result 1))
+	      nvals)
+  (:results (start :scs (any-reg control-stack))
+	    (count :scs (any-reg control-stack))))
+
+
+;;;; Local call with unknown values convention return:
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; FP is the frame pointer in install before doing the call.
+;;;
+;;; NFP would be the number-stack frame pointer if we had a seperate number
+;;; stack.
+;;; 
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;; Nvals is the number of values received.
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;;
+;;; Target is a continuation pointing to the start of the called function.
+;;;
+;;;
+(define-vop (call-local)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:results (values :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info arg-locs callee target nvals)
+  (:vop-var vop)
+  (:ignore nfp arg-locs args #+nil callee)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (move rbp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+      #+nil
+      (format t "*call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((sap-stack)
+	 #+nil (format t "*call-local: ret-tn on stack; offset=~s~%"
+		       (tn-offset ret-tn))
+	 ;; Stack
+	 (storew (make-fixup nil :code-object return)
+		 rbp-tn (- (1+ (tn-offset ret-tn)))))
+	((sap-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    RETURN
+    (default-unknown-values vop values nvals)
+    (trace-table-entry trace-table-normal)))
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention.  The results are the start of the values
+;;; glob and the number of values received.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info save callee target)
+  (:ignore args save nfp #+nil callee)
+  (:vop-var vop)
+  (:generator 20
+    (trace-table-entry trace-table-call-site)
+    (move rbp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+      #+nil
+      (format t "*multiple-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((sap-stack)
+	 #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~s~%"
+		       (tn-offset ret-tn))
+	 ;; Stack
+	 (storew (make-fixup nil :code-object return)
+		 rbp-tn (- (1+ (tn-offset ret-tn)))))
+	((sap-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    RETURN
+    (note-this-location vop :unknown-return)
+    (receive-unknown-values values-start nvals start count)
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Local call with known values return:
+
+;;; Non-TR local call with known return locations.  Known-value return works
+;;; just like argument passing in local call.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-call-local)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:temporary (:sc any-reg) temp-tn) ; from/to?
+  (:results (res :more t))
+  (:move-args :local-call)
+  (:save-p t)
+  (:info save callee target)
+  (:ignore args res save nfp #+nil callee)
+  (:vop-var vop)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (move rbp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+
+      #+nil
+      (format t "*known-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+      
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((sap-stack)
+	 #+nil (format t "*known-call-local: ret-tn on stack; offset=~s~%"
+		       (tn-offset ret-tn))
+	 ;; Stack
+	 ;; need a temp register since we need 64-bit address here
+	 (inst mov-imm temp-tn (make-fixup nil :code-object return))
+	 (storew temp-tn rbp-tn (- (1+ (tn-offset ret-tn)))))
+	((sap-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    RETURN
+    (note-this-location vop :known-return)
+    (trace-table-entry trace-table-normal)))
+
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; We can assume we know exactly where old-fp and return-pc are because
+;;; make-old-fp-save-location and make-return-pc-save-location always
+;;; return the same place.
+;;;
+#+nil
+(define-vop (known-return)
+  (:args (old-fp)
+	 (return-pc :scs (any-reg immediate-stack) :target rpc)
+	 (vals :more t))
+  (:move-args :known-return)
+  (:info val-locs)
+  (:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Save the return-pc in a register 'cause the frame-pointer is going away.
+    ;; Note this not in the usual stack location so we can't use RET
+    (move rpc return-pc)
+    ;; Restore the stack.
+    (move rsp-tn rbp-tn)
+    ;; Restore the old fp.  We know OLD-FP is going to be in it's stack
+    ;; save slot, which is a different frame that than this one,
+    ;; so we don't have to worry about having just cleared
+    ;; most of the stack.
+    (move rbp-tn old-fp)
+    (inst jmp rpc)
+    (trace-table-entry trace-table-normal)))
+
+;;; From Douglas Crosher
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; The old-fp may be either in a register or on the stack in its
+;;; standard save locations - slot 0.
+;;;
+;;; The return-pc may be in a register or on the stack in any slot.
+;;;
+(define-vop (known-return)
+  (:args (old-fp)
+	 (return-pc)
+	 (vals :more t))
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+
+    #+nil (format t "*known-return: old-fp ~s, tn-kind ~s; ~s ~s~%"
+		  old-fp (c::tn-kind old-fp) (c::tn-save-tn old-fp)
+		  (c::tn-kind (c::tn-save-tn old-fp)))
+
+    #+nil (format t "*known-return: return-pc ~s, tn-kind ~s; ~s ~s~%"
+		  return-pc (c::tn-kind return-pc) (c::tn-save-tn return-pc)
+		  (c::tn-kind (c::tn-save-tn return-pc)))
+    
+    ;; return-pc may be either in a register or on the stack.
+    (sc-case return-pc
+      ((sap-reg)
+       (sc-case old-fp
+         ((control-stack)
+
+	  #+nil (format t "*known-return: old-fp ~s on stack; offset=~s~%"
+			old-fp (tn-offset old-fp))
+	  
+	  (cond ((zerop (tn-offset old-fp))
+		 ;; Zot all of the stack except for the old-fp.
+		 (inst lea rsp-tn (make-ea :qword :base rbp-tn
+					   :disp (- (* (1+ ocfp-save-offset)
+						       word-bytes))))
+		 ;; Restore the old fp from its save location on the stack,
+		 ;; and zot the stack.
+		 (inst pop rbp-tn))
+
+		(t 
+		 (cerror "Continue any-way"
+			 "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0"
+			 (tn-offset old-fp)))))
+	  
+	 ((any-reg descriptor-reg)
+	  ;; Zot all the stack.
+	  (move rsp-tn rbp-tn)
+	  ;; Restore the old-fp.
+	  (move rbp-tn old-fp)))
+
+       ;; Return; return-pc is in a register.
+       (inst jmp return-pc))
+
+      ((sap-stack)
+
+       #+nil (format t "*known-return: return-pc ~s on stack; offset=~s~%"
+		     return-pc (tn-offset return-pc))
+       
+       ;; Zot all of the stack except for the old-fp and return-pc.
+       (inst lea rsp-tn
+	     (make-ea :qword :base rbp-tn
+		      :disp (- (* (1+ (tn-offset return-pc)) word-bytes))))
+       ;; Restore the old fp.  old-fp may be either on the stack in its
+       ;; save location or in a register, in either case this restores it.
+       (move rbp-tn old-fp)
+       ;; The return pops the return address (8 bytes), then we need
+       ;; to pop all the slots before the return-pc which includes the
+       ;; 8 bytes for the old-fp.
+       (inst ret (* (tn-offset return-pc) word-bytes))))
+
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Full call:
+;;;
+;;;    There is something of a cross-product effect with full calls.  Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame.  On entry to the
+;;; callee, this partial frame is pointed to by FP.
+
+;;; Define-Full-Call  --  Internal
+;;;
+;;;    This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;; 
+;;; Named is true if the first argument is an fdefinition object whose
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;;    the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;;    result values are specified by the Start and Count as in the
+;;;    unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call.  No values are returned.
+;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument.  If Variable is false, then the passing locations are
+;;; passed as a more arg.  Variable is true if there are a variable number of
+;;; arguments passed on the stack.  Variable cannot be specified with :Tail
+;;; return.  TR variable argument call is implemented separately.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+;;;
+(defmacro define-full-call (name named return variable)
+  (assert (not (and variable (eq return :tail))))
+  `(define-vop (,name
+		,@(when (eq return :unknown)
+		    '(unknown-values-receiver)))
+    (:args
+     ,@(unless (eq return :tail)
+	       '((new-fp :scs (any-reg) :to (:argument 1))))
+     
+     (fun :scs (descriptor-reg control-stack)
+          :target rax :to (:argument 0))
+     
+     ,@(when (eq return :tail)
+	     '((old-fp)
+	       (return-pc)))
+      
+     ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+    ,@(when (eq return :fixed)
+	    '((:results (values :more t))))
+   
+    (:save-p ,(if (eq return :tail) :compute-only t))
+
+    ,@(unless (or (eq return :tail) variable)
+	      '((:move-args :full-call)))
+
+    (:vop-var vop)
+    (:info
+     ,@(unless (or variable (eq return :tail)) '(arg-locs))
+     ,@(unless variable '(nargs))
+     ,@(when (eq return :fixed) '(nvals)))
+
+    (:ignore
+     ,@(unless (or variable (eq return :tail)) '(arg-locs))
+     ,@(unless variable '(args)))
+    
+    ;; We pass either the fdefn object (for named call) or the actual
+    ;; function object (for unnamed call) in RAX.  With named call,
+    ;; closure-tramp will replace it with the real function and invoke
+    ;; the real function for closures.  Non-closures do not need this
+    ;; value, so don't care what shows up in it.
+    (:temporary
+     (:sc descriptor-reg :offset rax-offset :from (:argument 0) :to :eval)
+     rax)
+
+    ;; We pass the number of arguments in RCX.
+    (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx)
+
+    ;; With variable call, we have to load the register-args out
+    ;; of the (new) stack frame before doing the call.  Therefore,
+    ;; we have to tell the lifetime stuff that we need to use them.
+    ,@(when variable
+	    (mapcar #'(lambda (name offset)
+			`(:temporary (:sc descriptor-reg
+				      :offset ,offset
+				      :from (:argument 0)
+				      :to :eval)
+			  ,name))
+		    register-arg-names register-arg-offsets))
+
+    ,@(when (eq return :tail)
+	    '((:temporary (:sc unsigned-reg
+			   :from (:argument 1) :to (:argument 2)) old-fp-tmp)))
+
+    (:generator ,(+ (if named 5 0)
+		    (if variable 19 1)
+		    (if (eq return :tail) 0 10)
+		    15
+		    (if (eq return :unknown) 25 0))
+     (trace-table-entry trace-table-call-site)
+
+     ;; This has to be done before the frame pointer is changed!
+     ;; rax stores the 'lexical environment' needed for closures
+     (move rax fun)
+     
+
+     ,@(if variable
+	   ;; For variable call, compute the number of arguments and
+	   ;; move some of the arguments to registers.
+	   (collect ((noise))
+		    ;; Compute the number of arguments.
+		    (noise '(inst mov rcx new-fp))
+		    (noise '(inst sub rcx rsp-tn))
+		    (noise '(inst shr rcx 1))
+		    ;; Move the necessary args to registers, this
+		    ;; moves them all even if they are not all needed.
+		    (loop
+		     for name in register-arg-names
+		     for index downfrom -1
+		     do (noise `(loadw ,name new-fp ,index)))
+		    (noise))
+	   '((if (zerop nargs)
+		 (inst xor rcx rcx)
+	       (inst mov rcx (fixnumize nargs)))))
+     ,@(cond ((eq return :tail)
+	      '(;; Python has figured out what frame we should return
+		;; to so might as well use that clue. This seems
+		;; really important to the implementation of things
+		;; like (without-interrupts ...)
+
+		;; dtc; Could be doing a tail call from a
+		;; known-local-call etc in which the old-fp or ret-pc
+		;; are in regs or in non-standard places. If the
+		;; passing location were wired to the stack in
+		;; standard locations then these moves will be
+		;; un-necessary; this is probably best for the x86.
+		(sc-case old-fp
+		  ((control-stack)
+		   (unless (= ocfp-save-offset (tn-offset old-fp))
+		     (format t "** tail-call old-fp not S0~%")
+		     (move old-fp-tmp old-fp)
+		     (storew old-fp-tmp rbp-tn (- (1+ ocfp-save-offset)))))
+		  ((any-reg descriptor-reg)
+		     (format t "** tail-call old-fp in reg not S0~%")
+		   (storew old-fp rbp-tn (- (1+ ocfp-save-offset)))))
+
+		;; For tail call, we have to push the return-pc so
+		;; that it looks like we CALLed despite the fact that
+		;; we are going to JMP.
+		(inst push return-pc)
+		))
+	     (t
+	      ;; For non-tail call, we have to save our frame pointer
+	      ;; and install the new frame pointer.  We can't load stack
+	      ;; tns after this point.
+	      `(;; Python doesn't seem to allocate a frame here which
+		;; doesn't leave room for the ofp/ret stuff.
+		
+		;; The variable args are on the stack and become the
+		;; frame, but there may be <3 args and 3 stack slots
+		;; are assumed allocate on the call. So need to ensure
+		;; there are at least 3 slots. This hack just adds 3
+		;; more.
+		,(if variable
+		     '(inst sub rsp-tn (* 3 word-bytes)))
+
+		;; Save the fp
+		(storew rbp-tn new-fp (- (1+ ocfp-save-offset)))
+
+		(move rbp-tn new-fp)	; NB - now on new stack frame.
+		)))
+  
+     (note-this-location vop :call-site)
+
+     (inst ,(if (eq return :tail) 'jmp 'call)
+      (make-ea :qword :base rax
+	       :disp ,(if named
+			  '(- (* fdefn-raw-addr-slot word-bytes)
+			    other-pointer-type)
+			  '(- (* closure-function-slot word-bytes)
+			    function-pointer-type))))
+     ,@(ecase return
+	      (:fixed
+		 '((default-unknown-values vop values nvals)))
+	      (:unknown
+	       '((note-this-location vop :unknown-return)
+		 (receive-unknown-values values-start nvals start count)))
+	      (:tail))
+     (trace-table-entry trace-table-normal))))
+
+
+(define-full-call call nil :fixed nil)
+(define-full-call call-named t :fixed nil)
+(define-full-call multiple-call nil :unknown nil)
+(define-full-call multiple-call-named t :unknown nil)
+(define-full-call tail-call nil :tail nil)
+(define-full-call tail-call-named t :tail nil)
+
+(define-full-call call-variable nil :fixed t)
+(define-full-call multiple-call-variable nil :unknown t)
+
+
+;;; Defined separately, since needs special code that BLT's the arguments
+;;; down.  All the real work is done in the assembly routine.  We just
+;;; set things up so that it can find what it needs.
+;;;
+(define-vop (tail-call-variable)
+  (:args (args :scs (any-reg control-stack) :target rsi)
+	 (function :scs (descriptor-reg control-stack) :target rax)
+	 (old-fp)
+	 (ret-addr))
+  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
+;  (:ignore ret-addr old-fp)
+  (:generator 75
+    ;; Move these into the passing locations if they are not already there.
+    (move rsi args)
+    (move rax function)
+
+    ;; The following assumes that the return-pc and old-fp are on the
+    ;; stack in their standard save locations - Check this.
+    (unless (and (sc-is old-fp control-stack)
+		 (= (tn-offset old-fp) ocfp-save-offset))
+	    (error "tail-call-variable: ocfp not on stack in standard save location?"))
+    (unless (and (sc-is ret-addr sap-stack)
+		 (= (tn-offset ret-addr) return-pc-save-offset))
+	    (error "tail-call-variable: ret-addr not on stack in standard save location?"))
+    
+
+    ;; And jump to the assembly routine.
+    (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))
+
+
+;;;; Unknown values return:
+
+;;; Return a single-value using the Unknown-Values convention.  Specifically,
+;;; we jump to clear the stack and jump to return-pc+3. 3 is the number of
+;;; bytes for the next instruction (MOV).
+;;;
+;;; We require old-fp to be in a register, because we want to reset rSP before
+;;; restoring rBP.  If old-fp were still on the stack, it could get clobbered
+;;; by a signal.
+;;; 
+;;; pfw--get wired-tn conflicts sometimes if register sc specd for args
+;;; having problems targeting args to regs -- using temps instead.
+(define-vop (return-single)
+  (:args (old-fp)
+	 (return-pc)
+	 (value))
+  (:temporary (:sc unsigned-reg) ofp)
+  (:temporary (:sc unsigned-reg) ret)
+  (:ignore value)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    (move ret return-pc)
+    ;; Clear the control stack
+    (move ofp old-fp)
+    ;; Adjust the return address for the single value return.
+    (inst add ret 3)
+    ;; Restore the frame pointer.
+    (move rsp-tn rbp-tn)
+    (move rbp-tn ofp)
+    ;; Out of here.
+    (inst jmp ret)))
+
+;;; Do unknown-values return of a fixed (other than 1) number of values.  The
+;;; Values are required to be set up in the standard passing locations.  Nvals
+;;; is the number of values returned.
+;;;
+;;; Basically, we just load rCX with the number of values returned and rBX
+;;; with a pointer to the values, set rSP to point to the end of the values,
+;;; and jump directly to return-pc.
+;;;
+(define-vop (return)
+  (:args (old-fp)
+	 (return-pc :to (:eval 1))
+	 (values :more t))
+  (:ignore values)
+  (:info nvals)
+
+  ;; In the case of other than one value, we need these registers to tell
+  ;; the caller where they are and how many there are.
+  (:temporary (:sc unsigned-reg :offset rbx-offset) rbx)
+  (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
+
+  ;; We need to stretch the lifetime of return-pc past the argument
+  ;; registers so that we can default the argument registers without
+  ;; trashing return-pc.
+  (:temporary (:sc unsigned-reg :offset (first register-arg-offsets)
+		   :from :eval) a0)
+  (:temporary (:sc unsigned-reg :offset (second register-arg-offsets)
+		   :from :eval) a1)
+  (:temporary (:sc unsigned-reg :offset (third register-arg-offsets)
+		   :from :eval) a2)
+
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Establish the values pointer and values count.
+    (move rbx rbp-tn)
+    (if (zerop nvals)
+	(inst xor rcx rcx) ; smaller
+      (inst mov rcx (fixnumize nvals)))
+    ;; restore the frame pointer.
+    (move rbp-tn old-fp)
+    ;; clear as much of the stack as possible, but not past the return
+    ;; address.
+    (inst lea rsp-tn (make-ea :qword :base rbx
+			      :disp (- (* (max nvals 2) word-bytes))))
+    ;; pre-default any argument register that need it.
+    (when (< nvals register-arg-count)
+      (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
+	     (first (first arg-tns)))
+	(inst mov first nil-value)
+	(dolist (tn (cdr arg-tns))
+	  (inst mov tn first))))
+    ;; And away we go.  Except that return-pc is still on the
+    ;; stack and we've changed the stack pointer.  So we have to
+    ;; tell it to index off of RBX instead of RBP.
+    (cond ((zerop nvals)
+	   ;; Return popping the return address and the OCFP.
+	   (inst ret word-bytes))
+	  ((= nvals 1)
+	   ;; Return popping the return, leaving 1 slot. Can this
+	   ;; happen, or is a single value return handled elsewhere?
+	   (inst ret))
+	  (t
+	   (inst jmp (make-ea :qword :base rbx
+			      :disp (- (* (1+ (tn-offset return-pc))
+					  word-bytes))))))
+    
+    (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.)  We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention.  Otherwise, we
+;;; branch off to code that calls an assembly-routine.
+;;;
+;;; The assembly routine takes the following args:
+;;;  rAX -- the return-pc to finally jump to.
+;;;  rBX -- pointer to where to put the values.
+;;;  rCX -- number of values to find there.
+;;;  rSI -- pointer to where to find the values.
+;;;
+(define-vop (return-multiple)
+  (:args (old-fp :to (:eval 1) :target old-fp-temp)
+	 (return-pc :target rax)
+	 (vals :scs (any-reg) :target rsi)
+	 (nvals :scs (any-reg) :target rcx))
+
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
+  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 2)) rsi)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 3)) rcx)
+  (:temporary (:sc unsigned-reg :offset rbx-offset :from (:eval 0)) rbx)
+  (:temporary (:sc descriptor-reg :offset (first register-arg-offsets)
+		   :from (:eval 0)) a0)
+  (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
+  (:node-var node)
+
+  (:generator 13
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Load the return-pc.
+    (move rax return-pc)
+    (unless (policy node (> space speed))
+      ;; Check for the single case.
+      (let ((not-single (gen-label)))
+	(inst cmp nvals (fixnumize 1))
+	(inst jmp :ne not-single)
+	
+	;; Return with one value.
+	(loadw a0 vals -1)
+	;; Clear the stack.  We load old-fp into a register before clearing
+	;; the stack.
+	(move old-fp-temp old-fp)
+	(move rsp-tn rbp-tn)
+	(move rbp-tn old-fp-temp)
+	;; Fix the return-pc to point at the single-value entry point.
+	(inst add rax 3)
+	;; Out of here.
+	(inst jmp rax)
+	
+	;; Nope, not the single case.  Jump to the assembly routine.
+	(emit-label not-single)))
+    (move rsi vals)
+    (move rcx nvals)
+    (move rbx rbp-tn)
+    (move rbp-tn old-fp)
+    (inst jmp (make-fixup 'return-multiple :assembly-routine))
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; XEP hackery:
+
+;;; We don't need to do anything special for regular functions.
+;;;
+(define-vop (setup-environment)
+  (:info label)
+  (:ignore label)
+  (:generator 0
+    ;; Don't bother doing anything.
+    nil))
+
+;;; Get the lexical environment from it's passing location.
+;;;
+(define-vop (setup-closure-environment)
+  (:results (closure :scs (descriptor-reg)))
+  (:info label)
+  (:ignore label)
+  (:generator 6
+    ;; Get result.
+    (move closure rax-tn)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments.
+;;;
+;;; The tricky part is doing this without trashing any of the calling
+;;; convention registers that are still needed.  This vop is emitted directly
+;;; after the xep-allocate frame.  That means the registers are in use as
+;;; follows:
+;;;
+;;;  RAX -- The lexenv.
+;;;  RBX -- Available.
+;;;  RCX -- The total number of arguments.
+;;;  RDX -- The first arg.
+;;;  RDI -- The second arg.
+;;;  RSI -- The third arg.
+;;;
+;;; So basically, we have one register available for our use: RBX.
+;;;
+;;; What we can do is push the other regs onto the stack, and then restore
+;;; their values by looking directly below where we put the more-args.
+;;; 
+(define-vop (copy-more-arg)
+  (:info fixed)
+  (:generator 20
+    ;; Avoid the copy if there are no more args.
+    (cond ((zerop fixed)
+	   (inst jecxz just-alloc-frame))
+	  (t
+	   (inst cmp rcx-tn (fixnumize fixed))
+	   (inst jmp :be just-alloc-frame)))
+    
+    ;; Allocate the space on the stack.
+    ;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
+    (inst lea rbx-tn
+	  (make-ea :qword :base rbp-tn
+		   :disp (* word-bytes
+			    (- fixed (max 3 (sb-allocated-size 'stack))))))
+    (inst sub rbx-tn rcx-tn)  ; need to do this twice since rcx-tn has only 2 tag bits
+    (inst sub rbx-tn rcx-tn)  ; Got the new stack in rbx
+    (inst mov rsp-tn rbx-tn)
+    
+    ;; Now: nargs>=1 && nargs>fixed
+    
+    ;; Save the original count of args.
+    (inst mov rbx-tn rcx-tn)
+    
+    (cond ((< fixed register-arg-count)
+	   ;; We must stop when we run out of stack args, not when we
+	   ;; run out of more args.
+	   ;; Number to copy = nargs-3
+	   (inst sub rcx-tn (fixnumize register-arg-count))
+	   ;; Everything of interest in registers.
+	   (inst jmp :be do-regs))
+	  (t
+	   ;; Number to copy = nargs-fixed
+	   (inst sub rcx-tn (fixnumize fixed))))
+    
+    ;; Save rdi and rsi register args.
+    (inst push rdi-tn)
+    (inst push rsi-tn)
+    ;; Okay, we have pushed the register args.  We can trash them
+    ;; now.
+    
+    ;; Initialize dst to be end of stack; skiping the values pushed
+    ;; above.
+    (inst lea rdi-tn (make-ea :qword :base rsp-tn :disp (* 2 word-bytes)))
+    
+    ;; Initialize src to be end of args.
+    (inst mov rsi-tn rbp-tn)
+    (inst sub rsi-tn rbx-tn)
+    (inst sub rsi-tn rbx-tn)  ; need to do this twice since rbx-tn has only 2 tag bits
+    
+    (inst shr rcx-tn 2)	; make word count
+    ;; And copy the args.
+    (inst cld)				; auto-inc RSI and RDI.
+    (inst rep)
+    (inst movs :qword)
+    
+    ;; So now we need to restore RDI and RSI.
+    (inst pop rsi-tn)
+    (inst pop rdi-tn)
+    
+    DO-REGS
+    
+    ;; Restore RCX
+    (inst mov rcx-tn rbx-tn)
+    
+    ;; Here: nargs>=1 && nargs>fixed
+    (when (< fixed register-arg-count)
+	  ;; Now we have to deposit any more args that showed up in
+	  ;; registers.
+	  (do ((i fixed))
+	      ( nil )
+	      ;; Store it relative to rbp
+	      (inst mov (make-ea :qword :base rbp-tn
+				 :disp (- (* word-bytes
+					     (+ 1 (- i fixed)
+						(max 3 (sb-allocated-size 'stack))))))
+		    (nth i register-arg-tns))
+	      
+	      (incf i)
+	      (when (>= i register-arg-count)
+		    (return))
+	      
+	      ;; Don't deposit any more than there are.
+	      (if (zerop i)
+		  (inst test rcx-tn rcx-tn)
+		(inst cmp rcx-tn (fixnumize i)))
+	      (inst jmp :eq done)))
+
+    (inst jmp done)
+    
+    JUST-ALLOC-FRAME
+    (inst lea rsp-tn
+	  (make-ea :qword :base rbp-tn
+		   :disp (- (* vm:word-bytes
+			       (max 3 (sb-allocated-size 'stack))))))
+    
+    DONE))
+
+;;; More args are stored contiguously on the stack, starting
+;;; immediately at the context pointer.  The context pointer is not
+;;; typed, so the lowtag is 0.
+;;;
+(define-vop (more-arg)
+  (:translate %more-arg)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg) :target temp))
+  (:arg-types * tagged-num)
+  (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
+  (:results (value :scs (any-reg descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (move temp index)
+    (inst neg temp)
+    ;; temp is tagged by 2 bits, we need another factor of 2
+    (inst mov value (make-ea :qword :base object :index temp :scale 2))))
+
+(define-vop (more-arg-c)
+  (:translate %more-arg)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types * (:constant (signed-byte 30)))
+  (:results (value :scs (any-reg descriptor-reg)))
+  (:result-types *)
+  (:generator 4
+   (inst mov value
+	 (make-ea :qword :base object :disp (- (* index word-bytes))))))
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:args (context :scs (descriptor-reg) :target src)
+	 (count :scs (any-reg) :target rcx))
+  (:info dynamic-extent)
+  (:arg-types * tagged-num (:constant t))
+  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) src)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
+  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
+  (:temporary (:sc unsigned-reg) dst)
+  (:results (result :scs (descriptor-reg)))
+  (:node-var node)
+  (:generator 20
+    (let ((enter (gen-label))
+	  (loop (gen-label))
+	  (done (gen-label)))
+      (move src context)
+      (move rcx count)
+      ;; Check to see if there are no arguments, and just return NIL if so.
+      (inst mov result nil-value)
+      (inst jecxz done)
+      (inst lea dst (make-ea :qword :index rcx :scale 4)) ; 2 words for each arg
+      (let ((*enable-pseudo-atomic* (unless dynamic-extent
+				      *enable-pseudo-atomic*)))
+	(pseudo-atomic
+	 (allocation dst dst rax node dynamic-extent)
+	 (inst lea dst (make-ea :byte :base dst :disp list-pointer-type))
+	 ;; Convert the count into a raw value, so we can use the LOOP inst.
+	 (inst shr rcx 2)
+	 ;; Set decrement mode (successive args at lower addresses)
+	 (inst std)
+	 ;; Set up the result.
+	 (move result dst)
+	 ;; Jump into the middle of the loop, 'cause that's were we want
+	 ;; to start.
+	 (inst jmp enter)
+	 (emit-label loop)
+	 ;; Compute a pointer to the next cons.
+	 (inst add dst (* cons-size word-bytes))
+	 ;; Store a pointer to this cons in the CDR of the previous cons.
+	 (storew dst dst -1 list-pointer-type)
+	 (emit-label enter)
+	 ;; Grab one value and stash it in the car of this cons.
+	 (inst lods rax)
+	 (storew rax dst 0 list-pointer-type)
+	 ;; Go back for more.
+	 (inst loop loop)
+	 ;; NIL out the last cons.
+	 (storew nil-value dst 1 vm:list-pointer-type)))
+      (emit-label done))))
+
+;;; Return the location and size of the more arg glob created by Copy-More-Arg.
+;;; Supplied is the total number of arguments supplied (originally passed in
+;;; rCX.)  Fixed is the number of non-rest arguments.
+;;;
+;;; We must duplicate some of the work done by Copy-More-Arg, since at that
+;;; time the environment is in a pretty brain-damaged state, preventing this
+;;; info from being returned as values.  What we do is compute
+;;; supplied - fixed, and return a pointer that many words below the current
+;;; stack top.
+;;;
+(define-vop (more-arg-context)
+  (:policy :fast-safe)
+  (:translate c::%more-arg-context)
+  (:args (supplied :scs (any-reg) :target count))
+  (:arg-types positive-fixnum (:constant fixnum))
+  (:info fixed)
+  (:results (context :scs (descriptor-reg))
+	    (count :scs (any-reg)))
+  (:result-types t tagged-num)
+  (:note "more-arg-context")
+  (:generator 5
+    (move count supplied)
+    ;; SP at this point points at the last arg pushed.
+    ;; Point to the first more-arg, not above it.
+    (inst lea context (make-ea :qword :base rsp-tn
+			       :index count :scale 2 ; count has 2 tag bits
+			       :disp (- (* (1+ fixed) vm:word-bytes))))
+    (unless (zerop fixed)
+      (inst sub count (fixnumize fixed)))))
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum (:constant t))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (if (zerop count)
+	  (inst test nargs nargs)  ; smaller instruction
+	(inst cmp nargs (fixnumize count)))
+      (inst jmp :ne err-lab))))
+
+;;; Various other error signallers.
+;;;
+(macrolet ((frob (name error translate &rest args)
+	     `(define-vop (,name)
+		,@(when translate
+		    `((:policy :fast-safe)
+		      (:translate ,translate)))
+		(:args ,@(mapcar #'(lambda (arg)
+				     `(,arg :scs (any-reg descriptor-reg)))
+				 args))
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1000
+		  (error-call vop ,error ,@args)))))
+  (frob argument-count-error invalid-argument-count-error
+    c::%argument-count-error nargs)
+  (frob type-check-error object-not-type-error c::%type-check-error
+    object type)
+  (frob layout-invalid-error layout-invalid-error c::%layout-invalid-error
+    object layout)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error
+    c::%odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error
+    c::%unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error nil fun))
diff --git a/compiler/amd64/cell.lisp b/compiler/amd64/cell.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..224aa8c8b3bf5021941417a7fd86a0dd0e797ffe
--- /dev/null
+++ b/compiler/amd64/cell.lisp
@@ -0,0 +1,394 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/cell.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the amd64.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999.
+;;; 
+
+(in-package :amd64)
+
+
+
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+  (:args (object :scs (descriptor-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 1
+    (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg immediate)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results)
+  (:generator 1
+     (if (sc-is value immediate)
+        (let ((val (tn-value value)))
+           (etypecase val
+              (integer
+	       (inst mov
+		     (make-ea :qword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (fixnumize val)))
+	      (symbol
+	       (inst mov
+		     (make-ea :qword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (+ nil-value (static-symbol-offset val))))
+	      (character
+	       (inst mov
+		     (make-ea :qword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (logior (ash (char-code val) type-bits)
+			     base-char-type)))))
+       ;; Else, value not immediate.
+       (storew value object offset lowtag))))
+
+
+
+;;;; Symbol hacking VOPs:
+
+;;; these next two cf the sparc version, by jrd.
+
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+  (:variant symbol-value-slot other-pointer-type))
+
+;;; Do a cell ref with an error check for being unbound.
+;;;
+(define-vop (checked-cell-ref)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
+
+
+
+;;; With Symbol-Value, we check that the value isn't the trap object.  So
+;;; Symbol-Value of NIL is NIL.
+;;;
+(define-vop (symbol-value)
+  (:translate symbol-value)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:result 1)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 9
+    (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
+      (loadw value object symbol-value-slot other-pointer-type)
+      (inst cmp value unbound-marker-type)
+      (inst jmp :e err-lab))))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+(export 'kernel::set-symbol-value-conditional "KERNEL")
+(defknown kernel::set-symbol-value-conditional (symbol t t) t (unsafe))
+
+(define-vop (set-symbol-value-conditional cell-set-conditional)
+  (:translate kernel::set-symbol-value-conditional)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast-safe))
+
+(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
+(define-vop (fast-symbol-value-xadd cell-xadd)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast)
+  (:translate fast-symbol-value-xadd)
+  (:arg-types * tagged-num))
+
+(define-vop (boundp)
+  (:translate boundp)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) value)
+  (:generator 9
+    (loadw value object symbol-value-slot other-pointer-type)
+    (inst cmp value unbound-marker-type)
+    (inst jmp (if not-p :e :ne) target)))
+
+(define-vop (symbol-hash)
+  (:policy :fast-safe)
+  (:translate symbol-hash)
+  (:args (symbol :scs (descriptor-reg)))
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 2
+    ;; the symbol-hash slot of NIL holds NIL because it is also the cdr
+    ;; slot, so we have to strip off the two low bits to make sure it is
+    ;; a fixnum.
+    (loadw res symbol symbol-hash-slot other-pointer-type)
+    (inst and res (lognot #b11))))
+
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (fdefn-function cell-ref)	; /pfw - alpha
+  (:variant fdefn-function-slot other-pointer-type))
+
+(define-vop (safe-fdefn-function)
+  (:args (object :scs (descriptor-reg) :to (:result 1)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 10
+    (loadw value object fdefn-function-slot other-pointer-type)
+    (inst cmp value nil-value)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
+      (inst jmp :e err-lab))))
+
+(define-vop (set-fdefn-function)
+  (:policy :fast-safe)
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg) raw)
+  (:temporary (:sc byte-reg) type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (load-type type function (- function-pointer-type))
+    (inst lea raw
+	  (make-ea :byte :base function
+		   :disp (- (* function-code-offset word-bytes)
+			    function-pointer-type)))
+    (inst cmp type function-header-type)
+    (inst jmp :e normal-fn)
+    (inst mov-imm raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
+    NORMAL-FN
+    (storew function fdefn fdefn-function-slot other-pointer-type)
+    (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result function)))
+
+(define-vop (fdefn-makunbound)
+  (:policy :fast-safe)
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew nil-value fdefn fdefn-function-slot other-pointer-type)
+    (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+	    fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
+
+
+
+;;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (symbol :scs (descriptor-reg)))
+  (:temporary (:sc descriptor-reg) temp)
+  (:temporary (:sc any-reg) bsp)
+  (:temporary (:sc any-reg) temp2)
+  (:generator 5
+    (load-symbol-value bsp *binding-stack-pointer*)
+    (loadw temp symbol symbol-value-slot other-pointer-type)
+    (inst add bsp (* binding-size word-bytes))
+    (store-symbol-value bsp *binding-stack-pointer* temp2)
+    (storew temp bsp (- binding-value-slot binding-size))
+    (storew symbol bsp (- binding-symbol-slot binding-size))
+    (storew val symbol symbol-value-slot other-pointer-type)))
+
+(define-vop (unbind)
+  (:temporary (:sc descriptor-reg) symbol value)
+  (:temporary (:sc any-reg) bsp)
+  (:generator 0
+    (load-symbol-value bsp *binding-stack-pointer*)
+    (loadw symbol bsp (- binding-symbol-slot binding-size))
+    (loadw value bsp (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew 0 bsp (- binding-symbol-slot binding-size))
+    (inst sub bsp (* binding-size word-bytes))
+    (store-symbol-value bsp *binding-stack-pointer* symbol)))
+
+
+(define-vop (unbind-to-here)
+  (:args (where :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg) symbol value)
+  (:temporary (:sc any-reg) bsp)
+  (:generator 0
+    (load-symbol-value bsp *binding-stack-pointer*)
+    (inst cmp where bsp)
+    (inst jmp :e done)
+
+    LOOP
+    (loadw symbol bsp (- binding-symbol-slot binding-size))
+    (inst or symbol symbol)
+    (inst jmp :z skip)
+    (loadw value bsp (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew 0 bsp (- binding-symbol-slot binding-size))
+
+    SKIP
+    (inst sub bsp (* binding-size word-bytes))
+    (inst cmp where bsp)
+    (inst jmp :ne loop)
+    (store-symbol-value bsp *binding-stack-pointer* symbol)
+
+    DONE))
+
+
+
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+  closure-info-offset function-pointer-type
+  (any-reg descriptor-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (any-reg descriptor-reg) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %funcallable-instance-info)
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+  (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+(define-vop (closure-ref slot-ref)
+  (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+  (:variant closure-info-offset function-pointer-type))
+
+
+
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+  (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+  (:variant value-cell-value-slot other-pointer-type))
+
+
+;;;; Structure hackery:
+
+(define-vop (instance-length)
+  (:policy :fast-safe)
+  (:translate %instance-length)
+  (:args (struct :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw res struct 0 instance-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (instance-ref slot-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:policy :fast-safe)
+  (:translate %instance-ref)
+  (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+  (:policy :fast-safe)
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+  instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+  instance-pointer-type (any-reg descriptor-reg) * %instance-set)
+
+(export 'kernel::%instance-set-conditional "KERNEL")
+(defknown kernel::%instance-set-conditional (instance index t t) t
+  (unsafe))
+
+(define-vop (instance-set-conditional-c slot-set-conditional)
+  (:policy :fast-safe)
+  (:translate kernel::%instance-set-conditional)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) * *))
+
+(define-vop (instance-set-conditional)
+  (:translate kernel::%instance-set-conditional)
+  (:args (object :scs (descriptor-reg) :to :eval)
+	 (slot :scs (any-reg) :to :result)
+	 (old-value :scs (descriptor-reg any-reg) :target rax)
+	 (new-value :scs (descriptor-reg any-reg)))
+  (:arg-types instance positive-fixnum * *)
+  (:temporary (:sc descriptor-reg :offset rax-offset
+		   :from (:argument 2) :to :result :target result)  rax)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:guard (backend-featurep :i486))
+  (:policy :fast-safe)
+  (:generator 5
+    (move rax old-value)
+    (inst cmpxchg (make-ea :qword :base object :index slot :scale 1
+			   :disp (- (* instance-slots-offset word-bytes)
+				    instance-pointer-type))
+	  new-value)
+    (move result rax)))
+
+(defknown %instance-xadd (instance index fixnum) fixnum ())
+(define-vop (instance-xadd-c slot-xadd)
+  (:policy :fast-safe)
+  (:translate %instance-xadd)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) tagged-num))
+
+
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+  (any-reg descriptor-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+  (any-reg descriptor-reg) * code-header-set)
+
+
+;;;; Cons conditional setters.
+
+(export 'kernel::rplaca-conditional "KERNEL")
+(defknown kernel::rplaca-conditional (cons t t) t
+  (unsafe))
+
+(define-vop (rplaca-conditional cell-set-conditional)
+  (:policy :fast-safe)
+  (:translate kernel::rplaca-conditional)
+  (:variant cons-car-slot list-pointer-type)
+  (:arg-types list * *))
+
+(export 'kernel::rplacd-conditional "KERNEL")
+(defknown kernel::rplacd-conditional (cons t t) t
+  (unsafe))
+
+(define-vop (rplacd-conditional cell-set-conditional)
+  (:policy :fast-safe)
+  (:translate kernel::rplacd-conditional)
+  (:variant cons-cdr-slot list-pointer-type)
+  (:arg-types list * *))
diff --git a/compiler/amd64/char.lisp b/compiler/amd64/char.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..43babcc79c42abe9fd2a1ab295fdbd172396b8b6
--- /dev/null
+++ b/compiler/amd64/char.lisp
@@ -0,0 +1,199 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/char.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the x86 VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; And then to the SPARC by William Lott.
+;;; And then to the x86, again by William.
+;;;
+;;; Debugged by Paul F. Werkowski, June-95.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;;
+
+(in-package :amd64)
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-char)
+  (:args (x :scs (any-reg control-stack) :target al))
+  (:temporary (:sc byte-reg :offset al-offset
+		   :from (:argument 0) :to (:eval 0)) al)
+  (:ignore al)
+  (:temporary (:sc byte-reg :offset ah-offset :target y
+		   :from (:argument 0) :to (:result 0)) ah)
+  (:results (y :scs (base-char-reg base-char-stack)))
+  (:note "character untagging")
+  (:generator 1
+    (move rax-tn x)
+    (move y ah)))
+;;;
+(define-move-vop move-to-base-char :move
+  (any-reg control-stack) (base-char-reg base-char-stack))
+
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-char)
+  (:args (x :scs (base-char-reg base-char-stack) :target ah))
+  (:temporary (:sc byte-reg :offset al-offset :target y
+		   :from (:argument 0) :to (:result 0)) al)
+  (:temporary (:sc byte-reg :offset ah-offset
+		   :from (:argument 0) :to (:result 0)) ah)
+  (:results (y :scs (any-reg descriptor-reg control-stack)))
+  (:note "character tagging")
+  (:generator 1
+    (move ah x)				; maybe move char byte
+    (inst mov al base-char-type)	; #x86 to type bits
+    (inst and rax-tn #xffff)		; remove any junk bits
+    (move y rax-tn)))
+
+;;;
+(define-move-vop move-from-base-char :move
+  (base-char-reg base-char-stack) (any-reg descriptor-reg control-stack))
+
+;;; Move untagged base-char values.
+;;;
+(define-vop (base-char-move)
+  (:args (x :target y
+	    :scs (base-char-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (base-char-reg base-char-stack)
+	       :load-if (not (location= x y))))
+  (:note "character move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop base-char-move :move
+  (base-char-reg) (base-char-reg base-char-stack))
+
+
+;;; Move untagged base-char arguments/return-values.
+;;;
+(define-vop (move-base-char-argument)
+  (:args (x :target y
+	    :scs (base-char-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y base-char-reg))))
+  (:results (y))
+  (:note "character arg move")
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move y x))
+      (base-char-stack
+       (inst mov
+	     (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) word-bytes)))
+	     x)))))
+;;;
+(define-move-vop move-base-char-argument :move-argument
+  (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-char-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
+
+(define-vop (char-code)
+  (:translate char-code)
+  (:policy :fast-safe)
+  (:args (ch :scs (base-char-reg base-char-stack)))
+  (:arg-types base-char)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+	      ;; ah to dh are not addressable when a rex prefix is used
+	      ;; The high 32 bits of doubleword operands are
+	      ;; zero-extended to 64-bits.
+    (inst movzx (64-bit-to-32-bit-tn res) ch)))
+
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (unsigned-reg unsigned-stack) :target rax))
+  (:arg-types positive-fixnum)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target res
+		   :from (:argument 0) :to (:result 0))
+	      rax)
+  (:results (res :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 1
+    (move rax code)
+    (move res al-tn)))
+
+
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare)
+  (:args (x :scs (base-char-reg base-char-stack))
+	 (y :scs (base-char-reg)
+	    :load-if (not (and (sc-is x base-char-reg)
+			       (sc-is y base-char-stack)))))
+  (:arg-types base-char base-char)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars condition not-condition)
+  (:generator 3
+    (inst cmp x y)
+    (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :e :ne))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :b :nb))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :a :na))
+
+(define-vop (base-char-compare-c)
+  (:args (x :scs (base-char-reg)))
+  (:arg-types base-char (:constant base-char))
+  (:conditional)
+  (:info target not-p y)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars condition not-condition)
+  (:generator 2
+    (inst cmp x (char-code y))
+    (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=-c/base-char base-char-compare-c)
+  (:translate char=)
+  (:variant :eq :ne))
+
+(define-vop (fast-char<-c/base-char base-char-compare-c)
+  (:translate char<)
+  (:variant :b :nb))
+
+(define-vop (fast-char>-c/base-char base-char-compare-c)
+  (:translate char>)
+  (:variant :a :na))
+
diff --git a/compiler/amd64/debug.lisp b/compiler/amd64/debug.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e30795727c260bde171f1214c91fef744ab8e029
--- /dev/null
+++ b/compiler/amd64/debug.lisp
@@ -0,0 +1,163 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/debug.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;; 
+(in-package :amd64)
+
+(define-vop (debug-cur-sp)
+  (:translate current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg sap-stack)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res rsp-tn)))
+
+(define-vop (debug-cur-fp)
+  (:translate current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg sap-stack)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res rbp-tn)))
+
+;;; Stack-ref and %set-stack-ref can be used to read and store
+;;; descriptor objects on the control stack.  Use the sap-ref
+;;; functions to access other data types.
+(define-vop (read-control-stack)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to :eval)
+	 (offset :scs (any-reg) :target temp))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:temporary (:sc unsigned-reg :from (:argument 1)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 9
+    (move temp offset)
+    (inst neg temp)
+    (inst mov result
+	  (make-ea :qword :base sap :disp (- word-bytes) :index temp))))
+
+(define-vop (read-control-stack-c)
+  (:translate stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:info index)
+  (:arg-types system-area-pointer (:constant (signed-byte 30)))
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst mov result (make-ea :qword :base sap
+			      :disp (- (* (1+ index) word-bytes))))))
+
+(define-vop (write-control-stack)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to :eval)
+	 (offset :scs (any-reg) :target temp)
+	 (value :scs (descriptor-reg) :to :result :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 9
+    (move temp offset)
+    (inst neg temp)
+    (inst mov
+	  (make-ea :qword :base sap :disp (- word-bytes) :index temp) value)
+    (move result value)))
+
+(define-vop (write-control-stack-c)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:info index)
+  (:arg-types system-area-pointer (:constant (signed-byte 30)) *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst mov (make-ea :qword :base sap
+		       :disp (- (* (1+ index) word-bytes)))
+	  value)
+    (move result value)))
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg)))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (let ((bogus (gen-label))
+	  (done (gen-label)))
+      (loadw temp thing 0 lowtag)
+      (inst shr temp type-bits)
+      (inst jmp :z bogus)
+      (inst shl temp (1- (integer-length word-bytes)))
+      (unless (= lowtag other-pointer-type)
+	(inst add temp (- lowtag other-pointer-type)))
+      (move code thing)
+      (inst sub code temp)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(inst mov code nil-value)
+	(inst jmp done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate di::lra-code-header)
+  (:variant other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate di::function-code-header)
+  (:variant function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate di::make-lisp-obj)
+  (:args (value :scs (unsigned-reg unsigned-stack) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)
+		    :load-if (not (sc-is value unsigned-reg))
+		    ))
+  (:generator 1
+    (move result value)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate di::get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg control-stack) :target result))
+  (:results (result :scs (unsigned-reg)
+		    :load-if (not (and (sc-is thing descriptor-reg)
+				       (sc-is result unsigned-stack)))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result thing)))
+
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate di::function-word-offset)
+  (:args (fun :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (loadw res fun 0 function-pointer-type)
+    (inst shr res type-bits)))
diff --git a/compiler/amd64/float.lisp b/compiler/amd64/float.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8436916e4483598719d7f8faec507ec2e5bd6cba
--- /dev/null
+++ b/compiler/amd64/float.lisp
@@ -0,0 +1,4647 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/float.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains floating point support for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+;;; Rewrite, enhancements, complex-float and long-float support by
+;;; Douglas Crosher, 1996, 1997, 1998, 1999, 2000.
+;;;
+
+(in-package :amd64)
+
+
+
+;;; Popping the FP stack.
+;;;
+;;; The default is to use a store and pop, fstp fr0.
+;;; For the AMD Athlon, using ffreep fr0 is faster.
+;;;
+(defun fp-pop ()
+  (if (backend-featurep :athlon)
+      (inst ffreep fr0-tn)
+      (inst fstp fr0-tn)))
+
+
+(macrolet ((ea-for-xf-desc (tn slot)
+	     `(make-ea
+	       :qword :base ,tn
+	       :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type))))
+  (defun ea-for-sf-desc (tn)
+    (ea-for-xf-desc tn vm:single-float-value-slot))
+  (defun ea-for-df-desc (tn)
+    (ea-for-xf-desc tn vm:double-float-value-slot))
+  #+long-float
+  (defun ea-for-lf-desc (tn)
+    (ea-for-xf-desc tn vm:long-float-value-slot))
+  ;; Complex floats
+  (defun ea-for-csf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-single-float-real-slot))
+  (defun ea-for-csf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-single-float-imag-slot))
+  (defun ea-for-cdf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-float-real-slot))
+  (defun ea-for-cdf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-float-imag-slot))
+  #+long-float
+  (defun ea-for-clf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-long-float-real-slot))
+  #+long-float
+  (defun ea-for-clf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-long-float-imag-slot)))
+
+(macrolet ((ea-for-xf-stack (tn kind)
+	     `(make-ea
+	       :qword :base rbp-tn
+	       :disp (- (* (+ (tn-offset ,tn)
+			      (ecase ,kind (:single 1) (:double 2) (:long 3)))
+			 vm:word-bytes)))))
+  (defun ea-for-sf-stack (tn)
+    (ea-for-xf-stack tn :single))
+  (defun ea-for-df-stack (tn)
+    (ea-for-xf-stack tn :double))
+  #+long-float
+  (defun ea-for-lf-stack (tn)
+    (ea-for-xf-stack tn :long)))
+
+;;; Complex float stack EAs
+(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
+	     `(make-ea
+	       :qword :base ,base
+	       :disp (- (* (+ (tn-offset ,tn)
+			      (* (ecase ,kind
+				   (:single 1)
+				   (:double 2)
+				   (:long 3))
+				 (ecase ,slot (:real 1) (:imag 2))))
+			 vm:word-bytes)))))
+  (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :single :real base))
+  (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :single :imag base))
+  ;;
+  (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :real base))
+  (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :imag base))
+  ;;
+  #+long-float
+  (defun ea-for-clf-real-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :long :real base))
+  #+long-float
+  (defun ea-for-clf-imag-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :long :imag base)))
+
+;;; Abstract out the copying of a FP register to the FP stack top, and
+;;; provide two alternatives for its implementation. Note: it's not
+;;; necessary to distinguish between a single or double register move
+;;; here.
+;;;
+;;; Using a Pop then load.
+(defun copy-fp-reg-to-fr0 (reg)
+  (assert (not (zerop (tn-offset reg))))
+  (fp-pop)
+  (inst fld (make-random-tn :kind :normal
+			    :sc (sc-or-lose 'double-reg *backend*)
+			    :offset (1- (tn-offset reg)))))
+;;;
+;;; Using Fxch then Fst to restore the original reg contents.
+#+nil
+(defun copy-fp-reg-to-fr0 (reg)
+  (assert (not (zerop (tn-offset reg))))
+  (inst fxch reg)
+  (inst fst  reg))
+
+;;; The x86 can't store a long-float to memory without popping the
+;;; stack and marking a register as empty, so it is necessary to
+;;; restore the register from memory.
+#+long-float
+(defun store-long-float (ea)
+   (inst fstpl ea)
+   (inst fldl ea))
+
+
+;;;; Move functions:
+
+;;; x is source, y is destination
+(define-move-function (load-single 2) (vop x y)
+  ((single-stack) (single-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fld (ea-for-sf-stack x))))
+
+(define-move-function (store-single 2) (vop x y)
+  ((single-reg) (single-stack))
+  (cond ((zerop (tn-offset x))
+	 (inst fst (ea-for-sf-stack y)))
+	(t
+	 (inst fxch x)
+	 (inst fst (ea-for-sf-stack y))
+	 ;; This may not be necessary as ST0 is likely invalid now.
+	 (inst fxch x))))
+
+(define-move-function (load-double 2) (vop x y)
+  ((double-stack) (double-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fldd (ea-for-df-stack x))))
+
+(define-move-function (store-double 2) (vop x y)
+  ((double-reg) (double-stack))
+  (cond ((zerop (tn-offset x))
+	 (inst fstd (ea-for-df-stack y)))
+	(t
+	 (inst fxch x)
+	 (inst fstd (ea-for-df-stack y))
+	 ;; This may not be necessary as ST0 is likely invalid now.
+	 (inst fxch x))))
+
+#+long-float
+(define-move-function (load-long 2) (vop x y)
+  ((long-stack) (long-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fldl (ea-for-lf-stack x))))
+
+#+long-float
+(define-move-function (store-long 2) (vop x y)
+  ((long-reg) (long-stack))
+  (cond ((zerop (tn-offset x))
+	 (store-long-float (ea-for-lf-stack y)))
+	(t
+	 (inst fxch x)
+	 (store-long-float (ea-for-lf-stack y))
+	 ;; This may not be necessary as ST0 is likely invalid now.
+	 (inst fxch x))))
+
+;;; The i387 has instructions to load some useful constants.
+;;; This doesn't save much time but might cut down on memory
+;;; access and reduce the size of the constant vector (CV).
+;;; Intel claims they are stored in a more precise form on chip.
+;;; Anyhow, might as well use the feature. It can be turned
+;;; off by hacking the "immediate-constant-sc" in vm.lisp.
+(define-move-function (load-fp-constant 2) (vop x y)
+  ((fp-constant) (single-reg double-reg #+long-float long-reg))
+  (let ((value (c::constant-value (c::tn-leaf x))))
+    (with-empty-tn@fp-top(y)
+      (cond ((zerop value)
+	     (inst fldz))
+	    ((= value 1l0)
+	     (inst fld1))
+	    ((= value pi)
+	     (inst fldpi))
+	    ((= value (log 10l0 2l0))
+	     (inst fldl2t))
+	    ((= value (log 2.718281828459045235360287471352662L0 2l0))
+	     (inst fldl2e))
+	    ((= value (log 2l0 10l0))
+	     (inst fldlg2))
+	    ((= value (log 2l0 2.718281828459045235360287471352662L0))
+	     (inst fldln2))
+	    (t (warn "Ignoring bogus i387 Constant ~a" value))))))
+
+
+;;;; Complex float move functions
+
+(defun complex-single-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+#+long-float
+(defun complex-long-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (tn-offset x)))
+#+long-float
+(defun complex-long-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+;;; x is source, y is destination
+(define-move-function (load-complex-single 2) (vop x y)
+  ((complex-single-stack) (complex-single-reg))
+  (let ((real-tn (complex-single-reg-real-tn y)))
+    (with-empty-tn@fp-top (real-tn)
+      (inst fld (ea-for-csf-real-stack x))))
+  (let ((imag-tn (complex-single-reg-imag-tn y)))
+    (with-empty-tn@fp-top (imag-tn)
+      (inst fld (ea-for-csf-imag-stack x)))))
+
+(define-move-function (store-complex-single 2) (vop x y)
+  ((complex-single-reg) (complex-single-stack))
+  (let ((real-tn (complex-single-reg-real-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fst (ea-for-csf-real-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fst (ea-for-csf-real-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-single-reg-imag-tn x)))
+    (inst fxch imag-tn)
+    (inst fst (ea-for-csf-imag-stack y))
+    (inst fxch imag-tn)))
+
+(define-move-function (load-complex-double 2) (vop x y)
+  ((complex-double-stack) (complex-double-reg))
+  (let ((real-tn (complex-double-reg-real-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldd (ea-for-cdf-real-stack x))))
+  (let ((imag-tn (complex-double-reg-imag-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldd (ea-for-cdf-imag-stack x)))))
+
+(define-move-function (store-complex-double 2) (vop x y)
+  ((complex-double-reg) (complex-double-stack))
+  (let ((real-tn (complex-double-reg-real-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cdf-real-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cdf-real-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-double-reg-imag-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cdf-imag-stack y))
+    (inst fxch imag-tn)))
+
+#+long-float
+(define-move-function (load-complex-long 2) (vop x y)
+  ((complex-long-stack) (complex-long-reg))
+  (let ((real-tn (complex-long-reg-real-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldl (ea-for-clf-real-stack x))))
+  (let ((imag-tn (complex-long-reg-imag-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldl (ea-for-clf-imag-stack x)))))
+
+#+long-float
+(define-move-function (store-complex-long 2) (vop x y)
+  ((complex-long-reg) (complex-long-stack))
+  (let ((real-tn (complex-long-reg-real-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (store-long-float (ea-for-clf-real-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (store-long-float (ea-for-clf-real-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-long-reg-imag-tn x)))
+    (inst fxch imag-tn)
+    (store-long-float (ea-for-clf-imag-stack y))
+    (inst fxch imag-tn)))
+
+
+;;;; Move VOPs:
+
+;;;
+;;; Float register to register moves.
+;;;
+(define-vop (float-move)
+  (:args (x))
+  (:results (y))
+  (:note "float move")
+  (:generator 0
+     (unless (location= x y)
+        (cond ((zerop (tn-offset y))
+	       (copy-fp-reg-to-fr0 x))
+	      ((zerop (tn-offset x))
+	       (inst fstd y))
+	      (t
+	       (inst fxch x)
+	       (inst fstd y)
+	       (inst fxch x))))))
+
+(define-vop (single-move float-move)
+  (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
+  (:results (y :scs (single-reg) :load-if (not (location= x y)))))
+(define-move-vop single-move :move (single-reg) (single-reg))
+
+(define-vop (double-move float-move)
+  (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-reg) :load-if (not (location= x y)))))
+(define-move-vop double-move :move (double-reg) (double-reg))
+
+#+long-float
+(define-vop (long-move float-move)
+  (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
+  (:results (y :scs (long-reg) :load-if (not (location= x y)))))
+#+long-float
+(define-move-vop long-move :move (long-reg) (long-reg))
+
+;;;
+;;; Complex float register to register moves.
+;;;
+(define-vop (complex-float-move)
+  (:args (x :target y :load-if (not (location= x y))))
+  (:results (y :load-if (not (location= x y))))
+  (:note "complex float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-reg-real-tn x))
+	     (y-real (complex-double-reg-real-tn y)))
+	 (cond ((zerop (tn-offset y-real))
+		(copy-fp-reg-to-fr0 x-real))
+	       ((zerop (tn-offset x-real))
+		(inst fstd y-real))
+	       (t
+		(inst fxch x-real)
+		(inst fstd y-real)
+		(inst fxch x-real))))
+       (let ((x-imag (complex-double-reg-imag-tn x))
+	     (y-imag (complex-double-reg-imag-tn y)))
+	 (inst fxch x-imag)
+	 (inst fstd y-imag)
+	 (inst fxch x-imag)))))
+
+(define-vop (complex-single-move complex-float-move)
+  (:args (x :scs (complex-single-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
+(define-move-vop complex-single-move :move
+  (complex-single-reg) (complex-single-reg))
+
+(define-vop (complex-double-move complex-float-move)
+  (:args (x :scs (complex-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
+(define-move-vop complex-double-move :move
+  (complex-double-reg) (complex-double-reg))
+
+#+long-float
+(define-vop (complex-long-move complex-float-move)
+  (:args (x :scs (complex-long-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
+#+long-float
+(define-move-vop complex-long-move :move
+  (complex-long-reg) (complex-long-reg))
+
+
+;;;
+;;; Move from float to a descriptor reg. allocating a new float
+;;; object in the process.
+;;;
+(define-vop (move-from-single)
+  (:args (x :scs (single-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:single-float-type vm:single-float-size temp node)
+       (with-tn@fp-top(x)
+	 (inst fst (ea-for-sf-desc y))))))
+(define-move-vop move-from-single :move
+  (single-reg) (descriptor-reg))
+
+(define-vop (move-from-double)
+  (:args (x :scs (double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:double-float-type vm:double-float-size temp node)
+       (with-tn@fp-top(x)
+	 (inst fstd (ea-for-df-desc y))))))
+(define-move-vop move-from-double :move
+  (double-reg) (descriptor-reg))
+
+#+long-float
+(define-vop (move-from-long)
+  (:args (x :scs (long-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:long-float-type vm:long-float-size node)
+       (with-tn@fp-top(x)
+	 (store-long-float (ea-for-lf-desc y))))))
+#+long-float
+(define-move-vop move-from-long :move
+  (long-reg) (descriptor-reg))
+
+(define-vop (move-from-fp-constant)
+  (:args (x :scs (fp-constant)))
+  (:results (y :scs (descriptor-reg)))
+  (:generator 2
+     (ecase (c::constant-value (c::tn-leaf x))
+       (0f0 (load-symbol-value y *fp-constant-0s0*))
+       (1f0 (load-symbol-value y *fp-constant-1s0*))
+       (0d0 (load-symbol-value y *fp-constant-0d0*))
+       (1d0 (load-symbol-value y *fp-constant-1d0*))
+       #+long-float
+       (0l0 (load-symbol-value y *fp-constant-0l0*))
+       #+long-float
+       (1l0 (load-symbol-value y *fp-constant-1l0*))
+       #+long-float
+       (#.pi (load-symbol-value y *fp-constant-pi*))
+       #+long-float
+       (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
+       #+long-float
+       (#.(log 2.718281828459045235360287471352662L0 2l0)
+	  (load-symbol-value y *fp-constant-l2e*))
+       #+long-float
+       (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
+       #+long-float
+       (#.(log 2l0 2.718281828459045235360287471352662L0)
+	  (load-symbol-value y *fp-constant-ln2*)))))
+(define-move-vop move-from-fp-constant :move
+  (fp-constant) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a float register
+;;;
+(define-vop (move-to-single)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (single-reg)))
+  (:note "pointer to float coercion")
+  (:generator 2
+     (with-empty-tn@fp-top(y)
+       (inst fld (ea-for-sf-desc x)))))
+(define-move-vop move-to-single :move (descriptor-reg) (single-reg))
+
+(define-vop (move-to-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-reg)))
+  (:note "pointer to float coercion")
+  (:generator 2
+     (with-empty-tn@fp-top(y)
+       (inst fldd (ea-for-df-desc x)))))
+(define-move-vop move-to-double :move (descriptor-reg) (double-reg))
+
+#+long-float
+(define-vop (move-to-long)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (long-reg)))
+  (:note "pointer to float coercion")
+  (:generator 2
+     (with-empty-tn@fp-top(y)
+       (inst fldl (ea-for-lf-desc x)))))
+#+long-float
+(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
+
+
+;;;
+;;; Move from complex float to a descriptor reg. allocating a new
+;;; complex float object in the process.
+;;;
+(define-vop (move-from-complex-single)
+  (:args (x :scs (complex-single-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:note "complex float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:complex-single-float-type
+			       vm:complex-single-float-size temp node)
+       (let ((real-tn (complex-single-reg-real-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (inst fst (ea-for-csf-real-desc y))))
+       (let ((imag-tn (complex-single-reg-imag-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fst (ea-for-csf-imag-desc y)))))))
+(define-move-vop move-from-complex-single :move
+  (complex-single-reg) (descriptor-reg))
+
+(define-vop (move-from-complex-double)
+  (:args (x :scs (complex-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:node-var node)
+  (:note "complex float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:complex-double-float-type
+			       vm:complex-double-float-size temp node)
+       (let ((real-tn (complex-double-reg-real-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (inst fstd (ea-for-cdf-real-desc y))))
+       (let ((imag-tn (complex-double-reg-imag-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fstd (ea-for-cdf-imag-desc y)))))))
+(define-move-vop move-from-complex-double :move
+  (complex-double-reg) (descriptor-reg))
+
+#+long-float
+(define-vop (move-from-complex-long)
+  (:args (x :scs (complex-long-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "complex float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:complex-long-float-type
+			       vm:complex-long-float-size node)
+       (let ((real-tn (complex-long-reg-real-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (store-long-float (ea-for-clf-real-desc y))))
+       (let ((imag-tn (complex-long-reg-imag-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (store-long-float (ea-for-clf-imag-desc y)))))))
+#+long-float
+(define-move-vop move-from-complex-long :move
+  (complex-long-reg) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a complex float register
+;;;
+(macrolet ((frob (name sc format)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note "pointer to complex float coercion")
+		  (:generator 2
+		    (let ((real-tn (complex-double-reg-real-tn y)))
+		      (with-empty-tn@fp-top(real-tn)
+			,@(ecase format
+			   (:single '((inst fld (ea-for-csf-real-desc x))))
+			   (:double '((inst fldd (ea-for-cdf-real-desc x))))
+			   #+long-float
+			   (:long '((inst fldl (ea-for-clf-real-desc x)))))))
+		    (let ((imag-tn (complex-double-reg-imag-tn y)))
+		      (with-empty-tn@fp-top(imag-tn)
+			,@(ecase format
+			   (:single '((inst fld (ea-for-csf-imag-desc x))))
+			   (:double '((inst fldd (ea-for-cdf-imag-desc x))))
+			   #+long-float
+			   (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+	  (frob move-to-complex-single complex-single-reg :single)
+	  (frob move-to-complex-double complex-double-reg :double)
+	  #+long-float
+	  (frob move-to-complex-double complex-long-reg :long))
+
+
+;;;
+;;; The move argument vops.
+;;;
+;;; Note these are also used to stuff fp numbers onto the c-call stack
+;;; so the order is different than the lisp-stack.
+
+;;; The general move-argument vop
+(macrolet ((frob (name sc stack-sc format)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (fp :scs (any-reg)
+			     :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "float argument move")
+		  (:generator ,(case format (:single 2) (:double 3) (:long 4))
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+	                  (cond ((zerop (tn-offset y))
+				 (copy-fp-reg-to-fr0 x))
+				((zerop (tn-offset x))
+				 (inst fstd y))
+				(t
+				 (inst fxch x)
+				 (inst fstd y)
+				 (inst fxch x)))))
+		      (,stack-sc
+		       (if (= (tn-offset fp) rsp-offset)
+			   (let* ((offset (* (tn-offset y) word-bytes))
+				  (ea (make-ea :qword :base fp :disp offset)))
+			     (with-tn@fp-top(x)
+				,@(ecase format
+					 (:single '((inst fst ea)))
+					 (:double '((inst fstd ea)))
+					 #+long-float
+					 (:long '((store-long-float ea))))))
+			   (let ((ea (make-ea
+				      :qword :base fp
+				      :disp (- (* (+ (tn-offset y)
+						     ,(case format
+							    (:single 1)
+							    (:double 2)
+							    (:long 3)))
+						  vm:word-bytes)))))
+			     (with-tn@fp-top(x)
+			       ,@(ecase format 
+				    (:single '((inst fst  ea)))
+				    (:double '((inst fstd ea)))
+				    #+long-float
+				    (:long '((store-long-float ea)))))))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-single-float-argument single-reg single-stack :single)
+  (frob move-double-float-argument double-reg double-stack :double)
+  #+long-float
+  (frob move-long-float-argument long-reg long-stack :long))
+
+;;;; Complex float move-argument vop
+(macrolet ((frob (name sc stack-sc format)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (fp :scs (any-reg)
+			     :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "complex float argument move")
+		  (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+			 (let ((x-real (complex-double-reg-real-tn x))
+			       (y-real (complex-double-reg-real-tn y)))
+			   (cond ((zerop (tn-offset y-real))
+				  (copy-fp-reg-to-fr0 x-real))
+				 ((zerop (tn-offset x-real))
+				  (inst fstd y-real))
+				 (t
+				  (inst fxch x-real)
+				  (inst fstd y-real)
+				  (inst fxch x-real))))
+			 (let ((x-imag (complex-double-reg-imag-tn x))
+			       (y-imag (complex-double-reg-imag-tn y)))
+			   (inst fxch x-imag)
+			   (inst fstd y-imag)
+			   (inst fxch x-imag))))
+		      (,stack-sc
+		       (let ((real-tn (complex-double-reg-real-tn x)))
+			 (cond ((zerop (tn-offset real-tn))
+				,@(ecase format
+				    (:single
+				     '((inst fst
+					(ea-for-csf-real-stack y fp))))
+				    (:double
+				     '((inst fstd
+					(ea-for-cdf-real-stack y fp))))
+				    #+long-float
+				    (:long
+				     '((store-long-float
+					(ea-for-clf-real-stack y fp))))))
+			       (t
+				(inst fxch real-tn)
+				,@(ecase format
+				    (:single
+				     '((inst fst
+					(ea-for-csf-real-stack y fp))))
+				    (:double
+				     '((inst fstd
+					(ea-for-cdf-real-stack y fp))))
+				    #+long-float
+				    (:long
+				     '((store-long-float
+					(ea-for-clf-real-stack y fp)))))
+				(inst fxch real-tn))))
+		       (let ((imag-tn (complex-double-reg-imag-tn x)))
+			 (inst fxch imag-tn)
+			 ,@(ecase format
+			     (:single
+			      '((inst fst (ea-for-csf-imag-stack y fp))))
+			     (:double
+			      '((inst fstd (ea-for-cdf-imag-stack y fp))))
+			     #+long-float
+			     (:long
+			      '((store-long-float
+				 (ea-for-clf-imag-stack y fp)))))
+			 (inst fxch imag-tn))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-complex-single-float-argument
+	complex-single-reg complex-single-stack :single)
+  (frob move-complex-double-float-argument
+	complex-double-reg complex-double-stack :double)
+  #+long-float
+  (frob move-complex-long-float-argument
+	complex-long-reg complex-long-stack :long))
+
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg #+long-float long-reg
+   complex-single-reg complex-double-reg #+long-float complex-long-reg)
+  (descriptor-reg))
+
+
+;;;; Arithmetic VOPs:
+
+;;; dtc: The floating point arithmetic vops.
+;;; 
+;;; Note: Although these can accept x and y on the stack or pointed to
+;;; from a descriptor register, they will work with register loading
+;;; without these.  Same deal with the result - it need only be a
+;;; register.  When load-tns are needed they will probably be in ST0
+;;; and the code below should be able to correctly handle all cases.
+;;;
+;;; However it seems to produce better code if all arg. and result
+;;; options are used; on the P86 there is no extra cost in using a
+;;; memory operand to the FP instructions - not so on the PPro.
+;;;
+;;; It may also be useful to handle constant args?
+;;;
+;;; 22-Jul-97: descriptor args lose in some simple cases when
+;;; a function result computed in a loop. Then Python insists
+;;; on consing the intermediate values! For example
+#|
+(defun test(a n)
+  (declare (type (simple-array double-float (*)) a)
+	   (fixnum n))
+  (let ((sum 0d0))
+    (declare (type double-float sum))
+  (dotimes (i n)
+    (incf sum (* (aref a i)(aref a i))))
+    sum))
+|#
+;;; So, disabling descriptor args until this can be fixed elsewhere.
+;;;
+(macrolet
+    ((frob (op fop-sti fopr-sti
+	       fop fopr sname scost
+	       fopd foprd dname dcost
+	       lname lcost)
+       `(progn
+	 (define-vop (,sname)
+	   (:translate ,op)
+	   (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
+		     :to :eval)
+		  (y :scs (single-reg single-stack #+nil descriptor-reg)
+		     :to :eval))
+	   (:temporary (:sc single-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (single-reg single-stack)))
+	   (:arg-types single-float single-float)
+	   (:result-types single-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,scost
+	     ;; Handle a few special cases
+	     (cond
+	      ;; x, y, and r are the same register.
+	      ((and (sc-is x single-reg) (location= x r) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (inst ,fop fr0))
+		     (t
+		      (inst fxch r)
+		      (inst ,fop fr0)
+		      ;; XX the source register will not be valid.
+		      (note-next-instruction vop :internal-error)
+		      (inst fxch r))))
+
+	      ;; x and r are the same register.
+	      ((and (sc-is x single-reg) (location= x r))
+	       (cond ((zerop (tn-offset r))
+		      (sc-case y
+		         (single-reg
+			  ;; ST(0) = ST(0) op ST(y)
+			  (inst ,fop y))
+			 (single-stack
+			  ;; ST(0) = ST(0) op Mem
+			  (inst ,fop (ea-for-sf-stack y)))
+			 (descriptor-reg
+			  (inst ,fop (ea-for-sf-desc y)))))
+		     (t
+		      ;; y to ST0
+		      (sc-case y
+	                 (single-reg
+			  (unless (zerop (tn-offset y))
+				  (copy-fp-reg-to-fr0 y)))
+			 ((single-stack descriptor-reg)
+			  (fp-pop)
+			  (if (sc-is y single-stack)
+			      (inst fld (ea-for-sf-stack y))
+			    (inst fld (ea-for-sf-desc y)))))
+		      ;; ST(i) = ST(i) op ST0
+		      (inst ,fop-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		     (note-next-instruction vop :internal-error)
+		     (inst wait)))
+	      ;; y and r are the same register.
+	      ((and (sc-is y single-reg) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (sc-case x
+	                 (single-reg
+			  ;; ST(0) = ST(x) op ST(0)
+			  (inst ,fopr x))
+			 (single-stack
+			  ;; ST(0) = Mem op ST(0)
+			  (inst ,fopr (ea-for-sf-stack x)))
+			 (descriptor-reg
+			  (inst ,fopr (ea-for-sf-desc x)))))
+		     (t
+		      ;; x to ST0
+		      (sc-case x
+		        (single-reg
+			 (unless (zerop (tn-offset x))
+				 (copy-fp-reg-to-fr0 x)))
+			((single-stack descriptor-reg)
+			 (fp-pop)
+			 (if (sc-is x single-stack)
+			     (inst fld (ea-for-sf-stack x))
+			   (inst fld (ea-for-sf-desc x)))))
+		      ;; ST(i) = ST(0) op ST(i)
+		      (inst ,fopr-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		     (note-next-instruction vop :internal-error)
+		     (inst wait)))
+	      ;; The default case
+	      (t
+	       ;; Get the result to ST0.
+
+	       ;; Special handling is needed if x or y are in ST0, and
+	       ;; simpler code is generated.
+	       (cond
+		;; x is in ST0
+		((and (sc-is x single-reg) (zerop (tn-offset x)))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (single-reg
+		    (inst ,fop y))
+		   (single-stack
+		    (inst ,fop (ea-for-sf-stack y)))
+		   (descriptor-reg
+		    (inst ,fop (ea-for-sf-desc y)))))
+		;; y is in ST0
+		((and (sc-is y single-reg) (zerop (tn-offset y)))
+		 ;; ST0 = x op ST0
+		 (sc-case x
+	           (single-reg
+		    (inst ,fopr x))
+		   (single-stack
+		    (inst ,fopr (ea-for-sf-stack x)))
+		   (descriptor-reg
+		    (inst ,fopr (ea-for-sf-desc x)))))
+		(t
+		 ;; x to ST0
+		 (sc-case x
+	           (single-reg
+		    (copy-fp-reg-to-fr0 x))
+		   (single-stack
+		    (fp-pop)
+		    (inst fld (ea-for-sf-stack x)))
+		   (descriptor-reg
+		    (fp-pop)
+		    (inst fld (ea-for-sf-desc x))))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (single-reg
+		    (inst ,fop y))
+		   (single-stack
+		    (inst ,fop (ea-for-sf-stack y)))
+		   (descriptor-reg
+		    (inst ,fop (ea-for-sf-desc y))))))
+
+	       (note-next-instruction vop :internal-error)
+
+	       ;; Finally save the result
+	       (sc-case r
+	         (single-reg
+		  (cond ((zerop (tn-offset r))
+			 (when (policy node (or (= debug 3) (> safety speed)))
+			       (inst wait)))
+			(t
+			 (inst fst r))))
+		 (single-stack
+		  (inst fst (ea-for-sf-stack r))))))))
+	       
+	 (define-vop (,dname)
+	   (:translate ,op)
+	   (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
+		     :to :eval)
+		  (y :scs (double-reg double-stack #+nil descriptor-reg)
+		     :to :eval))
+	   (:temporary (:sc double-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (double-reg double-stack)))
+	   (:arg-types double-float double-float)
+	   (:result-types double-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,dcost
+	     ;; Handle a few special cases
+	     (cond
+	      ;; x, y, and r are the same register.
+	      ((and (sc-is x double-reg) (location= x r) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (inst ,fop fr0))
+		     (t
+		      (inst fxch x)
+		      (inst ,fopd fr0)
+		      ;; XX the source register will not be valid.
+		      (note-next-instruction vop :internal-error)
+		      (inst fxch r))))
+	      
+	      ;; x and r are the same register.
+	      ((and (sc-is x double-reg) (location= x r))
+	       (cond ((zerop (tn-offset r))
+		      (sc-case y
+	                 (double-reg
+			  ;; ST(0) = ST(0) op ST(y)
+			  (inst ,fopd y))
+			 (double-stack
+			  ;; ST(0) = ST(0) op Mem
+			  (inst ,fopd (ea-for-df-stack y)))
+			 (descriptor-reg
+			  (inst ,fopd (ea-for-df-desc y)))))
+		     (t
+		      ;; y to ST0
+		      (sc-case y
+	                 (double-reg
+			  (unless (zerop (tn-offset y))
+				  (copy-fp-reg-to-fr0 y)))
+			 ((double-stack descriptor-reg)
+			  (fp-pop)
+			  (if (sc-is y double-stack)
+			      (inst fldd (ea-for-df-stack y))
+			    (inst fldd (ea-for-df-desc y)))))
+		      ;; ST(i) = ST(i) op ST0
+		      (inst ,fop-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		     (note-next-instruction vop :internal-error)
+		     (inst wait)))
+	      ;; y and r are the same register.
+	      ((and (sc-is y double-reg) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (sc-case x
+	                 (double-reg
+			  ;; ST(0) = ST(x) op ST(0)
+			  (inst ,foprd x))
+			 (double-stack
+			  ;; ST(0) = Mem op ST(0)
+			  (inst ,foprd (ea-for-df-stack x)))
+			 (descriptor-reg
+			  (inst ,foprd (ea-for-df-desc x)))))
+		     (t
+		      ;; x to ST0
+		      (sc-case x
+		         (double-reg
+			  (unless (zerop (tn-offset x))
+				  (copy-fp-reg-to-fr0 x)))
+			 ((double-stack descriptor-reg)
+			  (fp-pop)
+			  (if (sc-is x double-stack)
+			      (inst fldd (ea-for-df-stack x))
+			    (inst fldd (ea-for-df-desc x)))))
+		      ;; ST(i) = ST(0) op ST(i)
+		      (inst ,fopr-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		     (note-next-instruction vop :internal-error)
+		     (inst wait)))
+	      ;; The default case
+	      (t
+	       ;; Get the result to ST0.
+
+	       ;; Special handling is needed if x or y are in ST0, and
+	       ;; simpler code is generated.
+	       (cond
+		;; x is in ST0
+		((and (sc-is x double-reg) (zerop (tn-offset x)))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (double-reg
+		    (inst ,fopd y))
+		   (double-stack
+		    (inst ,fopd (ea-for-df-stack y)))
+		   (descriptor-reg
+		    (inst ,fopd (ea-for-df-desc y)))))
+		;; y is in ST0
+		((and (sc-is y double-reg) (zerop (tn-offset y)))
+		 ;; ST0 = x op ST0
+		 (sc-case x
+	           (double-reg
+		    (inst ,foprd x))
+		   (double-stack
+		    (inst ,foprd (ea-for-df-stack x)))
+		   (descriptor-reg
+		    (inst ,foprd (ea-for-df-desc x)))))
+		(t
+		 ;; x to ST0
+		 (sc-case x
+	           (double-reg
+		    (copy-fp-reg-to-fr0 x))
+		   (double-stack
+		    (fp-pop)
+		    (inst fldd (ea-for-df-stack x)))
+		   (descriptor-reg
+		    (fp-pop)
+		    (inst fldd (ea-for-df-desc x))))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+		   (double-reg
+		    (inst ,fopd y))
+		   (double-stack
+		    (inst ,fopd (ea-for-df-stack y)))
+		   (descriptor-reg
+		    (inst ,fopd (ea-for-df-desc y))))))
+
+	       (note-next-instruction vop :internal-error)
+
+	       ;; Finally save the result
+	       (sc-case r
+	         (double-reg
+		  (cond ((zerop (tn-offset r))
+			 (when (policy node (or (= debug 3) (> safety speed)))
+			       (inst wait)))
+			(t
+			 (inst fst r))))
+		 (double-stack
+		  (inst fstd (ea-for-df-stack r))))))))
+
+	 #+long-float
+	 (define-vop (,lname)
+	   (:translate ,op)
+	   (:args (x :scs (long-reg) :to :eval)
+		  (y :scs (long-reg) :to :eval))
+	   (:temporary (:sc long-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (long-reg)))
+	   (:arg-types long-float long-float)
+	   (:result-types long-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,lcost
+	     ;; Handle a few special cases
+	     (cond
+	      ;; x, y, and r are the same register.
+	      ((and (location= x r) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (inst ,fop fr0))
+		     (t
+		      (inst fxch x)
+		      (inst ,fopd fr0)
+		      ;; XX the source register will not be valid.
+		      (note-next-instruction vop :internal-error)
+		      (inst fxch r))))
+	      
+	      ;; x and r are the same register.
+	      ((location= x r)
+	       (cond ((zerop (tn-offset r))
+		      ;; ST(0) = ST(0) op ST(y)
+		      (inst ,fopd y))
+		     (t
+		      ;; y to ST0
+		      (unless (zerop (tn-offset y))
+			(copy-fp-reg-to-fr0 y))
+		      ;; ST(i) = ST(i) op ST0
+		      (inst ,fop-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		 (note-next-instruction vop :internal-error)
+		 (inst wait)))
+	      ;; y and r are the same register.
+	      ((location= y r)
+	       (cond ((zerop (tn-offset r))
+		      ;; ST(0) = ST(x) op ST(0)
+		      (inst ,foprd x))
+		     (t
+		      ;; x to ST0
+		      (unless (zerop (tn-offset x))
+			(copy-fp-reg-to-fr0 x))
+		      ;; ST(i) = ST(0) op ST(i)
+		      (inst ,fopr-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		 (note-next-instruction vop :internal-error)
+		 (inst wait)))
+	      ;; The default case
+	      (t
+	       ;; Get the result to ST0.
+
+	       ;; Special handling is needed if x or y are in ST0, and
+	       ;; simpler code is generated.
+	       (cond
+		;; x is in ST0
+		((zerop (tn-offset x))
+		 ;; ST0 = ST0 op y
+		 (inst ,fopd y))
+		;; y is in ST0
+		((zerop (tn-offset y))
+		 ;; ST0 = x op ST0
+		 (inst ,foprd x))
+		(t
+		 ;; x to ST0
+		 (copy-fp-reg-to-fr0 x)
+		 ;; ST0 = ST0 op y
+		 (inst ,fopd y)))
+
+	       (note-next-instruction vop :internal-error)
+
+	       ;; Finally save the result
+	       (cond ((zerop (tn-offset r))
+		      (when (policy node (or (= debug 3) (> safety speed)))
+			(inst wait)))
+		     (t
+		      (inst fst r))))))))))
+    
+    (frob + fadd-sti fadd-sti
+	  fadd fadd +/single-float 2
+	  faddd faddd +/double-float 2
+	  +/long-float 2)
+    (frob - fsub-sti fsubr-sti
+	  fsub fsubr -/single-float 2
+	  fsubd fsubrd -/double-float 2
+	  -/long-float 2)
+    (frob * fmul-sti fmul-sti
+	  fmul fmul */single-float 3
+	  fmuld fmuld */double-float 3
+	  */long-float 3)
+    (frob / fdiv-sti fdivr-sti
+	  fdiv fdivr //single-float 12
+	  fdivd fdivrd //double-float 12
+	  //long-float 12))
+
+
+(macrolet ((frob (name inst translate sc type)
+	     `(define-vop (,name)
+	       (:args (x :scs (,sc) :target fr0))
+	       (:results (y :scs (,sc)))
+	       (:translate ,translate)
+	       (:policy :fast-safe)
+	       (:arg-types ,type)
+	       (:result-types ,type)
+	       (:temporary (:sc double-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:ignore fr0)
+	       (:note "inline float arithmetic")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 1
+		(note-this-location vop :internal-error)
+		(unless (zerop (tn-offset x))
+		  (inst fxch x)		; x to top of stack
+		  (unless (location= x y)
+		    (inst fst x)))	; maybe save it
+		(inst ,inst)		; clobber st0
+		(unless (zerop (tn-offset y))
+		  (inst fst y))))))
+
+  (frob abs/single-float fabs abs single-reg single-float)
+  (frob abs/double-float fabs abs double-reg double-float)
+  #+long-float
+  (frob abs/long-float fabs abs long-reg long-float)
+  (frob %negate/single-float fchs %negate single-reg single-float)
+  (frob %negate/double-float fchs %negate double-reg double-float)
+  #+long-float
+  (frob %negate/long-float fchs %negate long-reg long-float))
+
+
+;;;; Comparison:
+
+#+long-float
+(deftransform eql ((x y) (long-float long-float))
+  `(and (= (long-float-low-bits x) (long-float-low-bits y))
+	(= (long-float-high-bits x) (long-float-high-bits y))
+	(= (long-float-exp-bits x) (long-float-exp-bits y))))
+
+(define-vop (=/float)
+  (:args (x) (y))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+     (note-this-location vop :internal-error)
+     (cond
+      ;; x is in ST0; y is in any reg.
+      ((zerop (tn-offset x))
+       (inst fucom y)
+       (inst fnstsw))			; status word to ax
+      ;; y is in ST0; x is in another reg. Can swap args saving a reg. swap.
+      ((zerop (tn-offset y))
+       (inst fucom x)
+       (inst fnstsw))			; status word to ax
+      ;; x and y are the same register, not ST0
+      ((location= x y)
+       (inst fxch x)
+       (inst fucom fr0-tn)
+       (inst fnstsw)			; status word to ax
+       (inst fxch x))
+      ;; x and y are different registers, neither ST0.
+      (t
+       (inst fxch x)
+       (inst fucom y)
+       (inst fnstsw)			; status word to ax
+       (inst fxch x)))
+     (inst and ah-tn #x45)		; C3 C2 C0
+     (inst cmp ah-tn #x40)
+     (inst jmp (if not-p :ne :e) target)))
+
+(macrolet ((frob (type sc)
+	     `(define-vop (,(symbolicate "=/" type) =/float)
+	        (:translate =)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+	        (:arg-types ,type ,type))))
+  (frob single-float single-reg)
+  (frob double-float double-reg)
+  #+long-float (frob long-float long-reg))
+
+(macrolet ((frob (translate test ntest)
+	     `(define-vop (,(symbolicate translate "/SINGLE-FLOAT"))
+		(:translate ,translate)
+		(:args (x :scs (single-reg single-stack descriptor-reg))
+		       (y :scs (single-reg single-stack descriptor-reg)))
+		(:arg-types single-float single-float)
+		(:temporary (:sc single-reg :offset fr0-offset :from :eval)
+			    fr0)
+		(:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+		(:conditional)
+		(:info target not-p)
+		(:policy :fast-safe)
+		(:guard (not (backend-featurep :ppro)))
+		(:note "inline float comparison")
+		(:ignore temp fr0)
+		(:generator 3
+		   ;; Handle a few special cases
+		   (cond
+		     ;; x is ST0.
+		     ((and (sc-is x single-reg) (zerop (tn-offset x)))
+		      (sc-case y
+			(single-reg
+			 (inst fcom y))
+			((single-stack descriptor-reg)
+			 (if (sc-is y single-stack)
+			     (inst fcom (ea-for-sf-stack y))
+			     (inst fcom (ea-for-sf-desc y)))))
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)
+		      ,@(unless (zerop test)
+			  `((inst cmp ah-tn ,test))))
+		     ;; y is ST0.
+		     ((and (sc-is y single-reg) (zerop (tn-offset y)))
+		      (sc-case x
+			(single-reg
+			 (inst fcom x))
+			((single-stack descriptor-reg)
+			 (if (sc-is x single-stack)
+			     (inst fcom (ea-for-sf-stack x))
+			     (inst fcom (ea-for-sf-desc x)))))
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)
+		      ,@(unless (zerop ntest)
+			  `((inst cmp ah-tn ,ntest))))
+		     ;; General case when neither x or y is in ST0.
+		     (t
+		      ,@(if (zerop ntest)
+			    `(;; y to ST0
+			      (sc-case y
+			        (single-reg
+				 (copy-fp-reg-to-fr0 y))
+			        ((single-stack descriptor-reg)
+				 (fp-pop)
+				 (if (sc-is y single-stack)
+				     (inst fld (ea-for-sf-stack y))
+				     (inst fld (ea-for-sf-desc y)))))
+			      (sc-case x
+			        (single-reg
+				 (inst fcom x))
+			        ((single-stack descriptor-reg)
+				 (if (sc-is x single-stack)
+				     (inst fcom (ea-for-sf-stack x))
+				     (inst fcom (ea-for-sf-desc x)))))
+			      (inst fnstsw)		; status word to ax
+			      (inst and ah-tn #x45))	; C3 C2 C0
+			    `(;; x to ST0
+			      (sc-case x
+			        (single-reg
+				 (copy-fp-reg-to-fr0 x))
+			        ((single-stack descriptor-reg)
+				 (fp-pop)
+				 (if (sc-is x single-stack)
+				     (inst fld (ea-for-sf-stack x))
+				     (inst fld (ea-for-sf-desc x)))))
+			      (sc-case y
+			        (single-reg
+				 (inst fcom y))
+			        ((single-stack descriptor-reg)
+				 (if (sc-is y single-stack)
+				     (inst fcom (ea-for-sf-stack y))
+				     (inst fcom (ea-for-sf-desc y)))))
+			      (inst fnstsw)		; status word to ax
+			      (inst and ah-tn #x45)		; C3 C2 C0
+			      ,@(unless (zerop test)
+				  `((inst cmp ah-tn ,test)))))))
+		 (inst jmp (if not-p :ne :e) target)))))
+  (frob < #x01 #x00)
+  (frob > #x00 #x01))
+
+(macrolet ((frob (translate test ntest)
+	     `(define-vop (,(symbolicate translate "/DOUBLE-FLOAT"))
+		(:translate ,translate)
+		(:args (x :scs (double-reg double-stack descriptor-reg))
+		       (y :scs (double-reg double-stack descriptor-reg)))
+		(:arg-types double-float double-float)
+		(:temporary (:sc double-reg :offset fr0-offset :from :eval)
+			    fr0)
+		(:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+		(:conditional)
+		(:info target not-p)
+		(:policy :fast-safe)
+		(:guard (not (backend-featurep :ppro)))
+		(:note "inline float comparison")
+		(:ignore temp fr0)
+		(:generator 3
+		   ;; Handle a few special cases
+		   (cond
+		     ;; x is in ST0.
+		     ((and (sc-is x double-reg) (zerop (tn-offset x)))
+		      (sc-case y
+			(double-reg
+			 (inst fcomd y))
+			((double-stack descriptor-reg)
+			 (if (sc-is y double-stack)
+			     (inst fcomd (ea-for-df-stack y))
+			     (inst fcomd (ea-for-df-desc y)))))
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)
+		      ,@(unless (zerop test)
+			  `((inst cmp ah-tn ,test))))
+		     ;; y is in ST0.
+		     ((and (sc-is y double-reg) (zerop (tn-offset y)))
+		      (sc-case x
+			(double-reg
+			 (inst fcomd x))
+			((double-stack descriptor-reg)
+			 (if (sc-is x double-stack)
+			     (inst fcomd (ea-for-df-stack x))
+			     (inst fcomd (ea-for-df-desc x)))))
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)
+		      ,@(unless (zerop ntest)
+			  `((inst cmp ah-tn ,ntest))))
+		     ;; General case when neither x or y is in ST0.
+		     (t
+		      ,@(if (zerop ntest)
+			    `(;; y to ST0
+			      (sc-case y
+			        (double-reg
+				 (copy-fp-reg-to-fr0 y))
+			        ((double-stack descriptor-reg)
+				 (fp-pop)
+				 (if (sc-is y double-stack)
+				     (inst fldd (ea-for-df-stack y))
+				     (inst fldd (ea-for-df-desc y)))))
+			      (sc-case x
+			        (double-reg
+				 (inst fcomd x))
+			        ((double-stack descriptor-reg)
+				 (if (sc-is x double-stack)
+				     (inst fcomd (ea-for-df-stack x))
+				     (inst fcomd (ea-for-df-desc x)))))
+			      (inst fnstsw)		; status word to ax
+			      (inst and ah-tn #x45))	; C3 C2 C0
+			    `(;; x to ST0
+			      (sc-case x
+			        (double-reg
+				 (copy-fp-reg-to-fr0 x))
+			        ((double-stack descriptor-reg)
+				 (fp-pop)
+				 (if (sc-is x double-stack)
+				     (inst fldd (ea-for-df-stack x))
+				     (inst fldd (ea-for-df-desc x)))))
+			      (sc-case y
+			        (double-reg
+				 (inst fcomd y))
+			        ((double-stack descriptor-reg)
+				 (if (sc-is y double-stack)
+				     (inst fcomd (ea-for-df-stack y))
+				     (inst fcomd (ea-for-df-desc y)))))
+			      (inst fnstsw)		; status word to ax
+			      (inst and ah-tn #x45)	; C3 C2 C0
+			      ,@(unless (zerop test)
+				  `((inst cmp ah-tn ,test)))))))
+		 (inst jmp (if not-p :ne :e) target)))))
+  (frob < #x01 #x00)
+  (frob > #x00 #x01))
+
+#+long-float
+(macrolet ((frob (translate test ntest)
+	     `(define-vop (,(symbolicate translate "/LONG-FLOAT"))
+		(:translate ,translate)
+		(:args (x :scs (long-reg))
+		       (y :scs (long-reg)))
+		(:arg-types long-float long-float)
+		(:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+		(:conditional)
+		(:info target not-p)
+		(:policy :fast-safe)
+		(:guard (not (backend-featurep :ppro)))
+		(:note "inline float comparison")
+		(:ignore temp)
+		(:generator 3
+		   (cond
+		     ;; x is in ST0; y is in any reg.
+		     ((zerop (tn-offset x))
+		      (inst fcomd y)
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)		; C3 C2 C0
+		      ,@(unless (zerop test)
+			  `((inst cmp ah-tn ,test))))
+		     ;; y is in ST0; x is in another reg.
+		     ((zerop (tn-offset y))
+		      (inst fcomd x)
+		      (inst fnstsw)			; status word to ax
+		      (inst and ah-tn #x45)
+		      ,@(unless (zerop ntest)
+			  `((inst cmp ah-tn ,ntest))))
+		     ;; x and y are the same register, not ST0
+		     ((location= x y)
+		      (inst fxch x)
+		      (inst fcomd fr0-tn)
+		      (inst fnstsw)		; status word to ax
+		      (inst fxch x)
+		      (inst and ah-tn #x45)	; C3 C2 C0
+		      ,@(unless (or (zerop test) (zerop ntest))
+			  `((inst cmp ah-tn ,test))))
+		     ;; x and y are different registers, neither ST0.
+		     (t
+		      ,@(cond ((zerop ntest)
+			       `((inst fxch y)
+				 (inst fcomd x)
+				 (inst fnstsw)		; status word to ax
+				 (inst fxch y)
+				 (inst and ah-tn #x45)))	; C3 C2 C0
+			      (t
+			       `((inst fxch x)
+				 (inst fcomd y)
+				 (inst fnstsw)		; status word to ax
+				 (inst fxch x)
+				 (inst and ah-tn #x45)	; C3 C2 C0
+				 ,@(unless (zerop test)
+				     `((inst cmp ah-tn ,test))))))))
+		   (inst jmp (if not-p :ne :e) target)))))
+  (frob < #x01 #x00)
+  (frob > #x00 #x01))
+
+;;; Comparisons with 0 can use the FTST instruction.
+
+(define-vop (float-test)
+  (:args (x))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p y)
+  (:variant-vars code)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp y)
+  (:generator 2
+     (note-this-location vop :internal-error)
+     (cond
+      ;; x is in ST0
+      ((zerop (tn-offset x))
+       (inst ftst)
+       (inst fnstsw))			; status word to ax
+      ;; x not ST0
+      (t
+       (inst fxch x)
+       (inst ftst)
+       (inst fnstsw)			; status word to ax
+       (inst fxch x)))
+     (inst and ah-tn #x45)		; C3 C2 C0
+     (unless (zerop code)
+       (inst cmp ah-tn code))
+     (inst jmp (if not-p :ne :e) target)))
+
+(macrolet ((frob (translate test)
+	     `(progn
+		(define-vop (,(symbolicate translate "0/SINGLE-FLOAT")
+			      float-test)
+		  (:translate ,translate)
+		  (:args (x :scs (single-reg)))
+		  (:arg-types single-float (:constant (single-float 0f0 0f0)))
+		  (:variant ,test))
+		(define-vop (,(symbolicate translate "0/DOUBLE-FLOAT")
+			      float-test)
+		  (:translate ,translate)
+		  (:args (x :scs (double-reg)))
+		  (:arg-types double-float (:constant (double-float 0d0 0d0)))
+		  (:variant ,test))
+		#+long-float
+		(define-vop (,(symbolicate translate "0/LONG-FLOAT")
+			      float-test)
+		  (:translate ,translate)
+		  (:args (x :scs (long-reg)))
+		  (:arg-types long-float (:constant (long-float 0l0 0l0)))
+		  (:variant ,test)))))
+  (frob > #x00)
+  (frob < #x01)
+  (frob = #x40))
+
+
+
+;;;; Enhanced Pentium Pro floating point comparisons.
+
+;;; These comparisions use the faster sequences bases upon FCOMI and FUCOMI,
+;;; which write to the condition codes.  However, correct IEEE handling of
+;;; unordered arguments requires the comparision of multiple flags which is
+;;; only possible for the comparison (> ST0 operand) in which case the :b and
+;;; :be tests can check that both ZF and CF are zero, or either is one
+;;; respectively. For the opposite comparision (< ST0 operand), the arguments
+;;; may be swapped and the > comparision used, but for equality the slower
+;;; FNSTSW variation must be used.
+
+(define-vop (ppro-</float)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:guard (backend-featurep :ppro))
+  (:note "inline float comparison")
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+      ;; x is in ST0; y is in any reg.
+      ((zerop (tn-offset x))
+       (inst fxch y)
+       (inst fcomi y)
+       (inst fxch y))
+      ;; y is in ST0; x is in another reg.
+      ((zerop (tn-offset y))
+       (inst fcomi x))
+      ;; x and y are the same register, not ST0.
+      ((location= x y)
+       (inst fxch x)
+       (inst fcomi fr0-tn)
+       (inst fxch x))
+      ;; x and y are different registers, neither ST0.
+      (t
+       (inst fxch y)
+       (inst fcomi x)
+       (inst fxch y)))
+    (inst jmp (if not-p :be :nbe) target)))
+
+(macrolet ((frob (type sc)
+	     `(define-vop (,(symbolicate "PPRO-</" type) ppro-</float)
+	        (:translate <)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+	        (:arg-types ,type ,type))))
+  (frob single-float single-reg)
+  (frob double-float double-reg)
+  #+long-float (frob long-float long-reg))
+
+(define-vop (ppro->/float)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:guard (backend-featurep :ppro))
+  (:note "inline float comparison")
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+      ;; x is in ST0; y is in any reg.
+      ((zerop (tn-offset x))
+       (inst fcomi y))
+      ;; y is in ST0; x is in another reg.
+      ((zerop (tn-offset y))
+       (inst fxch x)
+       (inst fcomi x)
+       (inst fxch x))
+      ;; x and y are the same register, not ST0.
+      ((location= x y)
+       (inst fxch x)
+       (inst fcomi fr0-tn)
+       (inst fxch x))
+      ;; x and y are different registers, neither ST0.
+      (t
+       (inst fxch x)
+       (inst fcomi y)
+       (inst fxch x)))
+    (inst jmp (if not-p :be :nbe) target)))
+
+(macrolet ((frob (type sc)
+	     `(define-vop (,(symbolicate "PPRO->/" type) ppro->/float)
+	        (:translate >)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+	        (:arg-types ,type ,type))))
+  (frob single-float single-reg)
+  (frob double-float double-reg)
+  #+long-float (frob long-float long-reg))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (signed-stack signed-reg) :target temp))
+		(:temporary (:sc signed-stack) temp)
+		(:results (y :scs (,to-sc)))
+		(:arg-types signed-num)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (sc-case x
+		    (signed-reg
+		     (inst mov temp x)
+		     (with-empty-tn@fp-top(y)
+		       (note-this-location vop :internal-error)
+		       (inst fild temp)))
+		    (signed-stack
+		     (with-empty-tn@fp-top(y)
+		       (note-this-location vop :internal-error)
+		       (inst fild x))))))))
+  (frob %single-float/signed %single-float single-reg single-float)
+  (frob %double-float/signed %double-float double-reg double-float)
+  #+long-float
+  (frob %long-float/signed %long-float long-reg long-float))
+
+(macrolet ((frob (name translate to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (unsigned-reg)))
+		(:results (y :scs (,to-sc)))
+		(:arg-types unsigned-num)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 6
+		 (inst push 0)
+		 (inst push x)
+		 (with-empty-tn@fp-top(y)
+		   (note-this-location vop :internal-error)
+		   (inst fildl (make-ea :qword :base rsp-tn)))
+		 (inst add rsp-tn 8)))))
+  (frob %single-float/unsigned %single-float single-reg single-float)
+  (frob %double-float/unsigned %double-float double-reg double-float)
+  #+long-float
+  (frob %long-float/unsigned %long-float long-reg long-float))
+
+;;; These should be no-ops but the compiler might want to move
+;;; some things around
+(macrolet ((frob (name translate from-sc from-type to-sc to-type)
+	     `(define-vop (,name)
+	       (:args (x :scs (,from-sc) :target y))
+	       (:results (y :scs (,to-sc)))
+	       (:arg-types ,from-type)
+	       (:result-types ,to-type)
+	       (:policy :fast-safe)
+	       (:note "inline float coercion")
+	       (:translate ,translate)
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 2
+		(note-this-location vop :internal-error)
+		(unless (location= x y)
+		  (cond 
+		   ((zerop (tn-offset x))
+		    ;; x is in ST0, y is in another reg. not ST0
+		    (inst fst  y))
+		   ((zerop (tn-offset y))
+		    ;; y is in ST0, x is in another reg. not ST0
+		    (copy-fp-reg-to-fr0 x))
+		   (t
+		    ;; Neither x or y are in ST0, and they are not in
+		    ;; the same reg.
+		    (inst fxch x)
+		    (inst fst  y)
+		    (inst fxch x))))))))
+  
+  (frob %single-float/double-float %single-float double-reg
+	double-float single-reg single-float)
+  #+long-float
+  (frob %single-float/long-float %single-float long-reg
+	long-float single-reg single-float)
+  (frob %double-float/single-float %double-float single-reg single-float
+	double-reg double-float)
+  #+long-float
+  (frob %double-float/long-float %double-float long-reg long-float
+	double-reg double-float)
+  #+long-float
+  (frob %long-float/single-float %long-float single-reg single-float
+	long-reg long-float)
+  #+long-float
+  (frob %long-float/double-float %long-float double-reg double-float
+	long-reg long-float))
+
+
+
+(macrolet ((frob (trans from-sc from-type round-p)
+	     `(define-vop (,(symbolicate trans "/" from-type))
+	       (:args (x :scs (,from-sc)))
+	       (:temporary (:sc signed-stack) stack-temp)
+	       ,@(unless round-p
+		       '((:temporary (:sc unsigned-stack) scw)
+			 (:temporary (:sc any-reg) rcw)))
+	       (:results (y :scs (signed-reg)))
+	       (:arg-types ,from-type)
+	       (:result-types signed-num)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline float truncate")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 5
+		,@(unless round-p
+		   '((note-this-location vop :internal-error)
+		     ;; Catch any pending FPE exceptions.
+		     (inst wait)))
+		(,(if round-p 'progn 'pseudo-atomic)
+		 ;; normal mode (for now) is "round to best"
+		 (with-tn@fp-top(x)
+		   ,@(unless round-p
+		     '((inst fnstcw scw)	; save current control word
+		       (move rcw scw)	; into 16-bit register
+		       (inst or rcw (ash #b11 10)) ; CHOP
+		       (move stack-temp rcw)
+		       (inst fldcw stack-temp)))
+		   (sc-case y
+		     (signed-stack
+		      (inst fist y))
+		     (signed-reg
+		      (inst fist stack-temp)
+		      (inst mov y stack-temp)))
+		   ,@(unless round-p
+		      '((inst fldcw scw)))))))))
+  (frob %unary-truncate single-reg single-float nil)
+  (frob %unary-truncate double-reg double-float nil)
+  #+long-float
+  (frob %unary-truncate long-reg long-float nil)
+  (frob %unary-round single-reg single-float t)
+  (frob %unary-round double-reg double-float t)
+  #+long-float
+  (frob %unary-round long-reg long-float t))
+
+(macrolet ((frob (trans from-sc from-type round-p)
+	     `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
+	       (:args (x :scs (,from-sc) :target fr0))
+	       (:temporary (:sc double-reg :offset fr0-offset
+			    :from :argument :to :result) fr0)
+	       ,@(unless round-p
+		  '((:temporary (:sc unsigned-stack) stack-temp)
+		    (:temporary (:sc unsigned-stack) scw)
+		    (:temporary (:sc any-reg) rcw)))
+	       (:results (y :scs (unsigned-reg)))
+	       (:arg-types ,from-type)
+	       (:result-types unsigned-num)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline float truncate")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 5
+		,@(unless round-p
+		   '((note-this-location vop :internal-error)
+		     ;; Catch any pending FPE exceptions.
+		     (inst wait)))
+		;; normal mode (for now) is "round to best"
+		(unless (zerop (tn-offset x))
+		  (copy-fp-reg-to-fr0 x))
+		,@(unless round-p
+		   '((inst fnstcw scw)	; save current control word
+		     (move rcw scw)	; into 16-bit register
+		     (inst or rcw (ash #b11 10)) ; CHOP
+		     (move stack-temp rcw)
+		     (inst fldcw stack-temp)))
+		(inst sub rsp-tn 8)
+		(inst fistpl (make-ea :qword :base rsp-tn))
+		(inst pop y)
+		(inst fld fr0) ; copy fr0 to at least restore stack.
+		(inst add rsp-tn 4)
+		,@(unless round-p
+		   '((inst fldcw scw)))))))
+  (frob %unary-truncate single-reg single-float nil)
+  (frob %unary-truncate double-reg double-float nil)
+  #+long-float
+  (frob %unary-truncate long-reg long-float nil)
+  (frob %unary-round single-reg single-float t)
+  (frob %unary-round double-reg double-float t)
+  #+long-float
+  (frob %unary-round long-reg long-float t))
+
+
+(define-vop (make-single-float)
+  (:args (bits :scs (signed-reg) :target res
+	       :load-if (not (or (and (sc-is bits signed-stack)
+				      (sc-is res single-reg))
+				 (and (sc-is bits signed-stack)
+				      (sc-is res single-stack)
+				      (location= bits res))))))
+  (:results (res :scs (single-reg single-stack)))
+  (:temporary (:sc signed-stack) stack-temp)
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case res
+       (single-stack
+	(sc-case bits
+	  (signed-reg
+	   (inst mov res bits))
+	  (signed-stack
+	   (assert (location= bits res)))))
+       (single-reg
+	(sc-case bits
+	  (signed-reg
+	   ;; source must be in memory
+	   (inst mov stack-temp bits)
+	   (with-empty-tn@fp-top(res)
+	      (inst fld stack-temp)))
+	  (signed-stack
+	   (with-empty-tn@fp-top(res)
+	      (inst fld bits))))))))
+
+(define-vop (make-double-float)
+  (:args (hi-bits :scs (signed-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (double-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types signed-num unsigned-num)
+  (:result-types double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (let ((offset (1+ (tn-offset temp))))
+      (storew hi-bits rbp-tn (- offset))
+      (storew lo-bits rbp-tn (- (1+ offset)))
+      (with-empty-tn@fp-top(res)
+	(inst fldd (make-ea :qword :base rbp-tn
+			    :disp (- (* (1+ offset) word-bytes))))))))
+
+#+long-float
+(define-vop (make-long-float)
+  (:args (exp-bits :scs (signed-reg))
+	 (hi-bits :scs (unsigned-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (long-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types signed-num unsigned-num unsigned-num)
+  (:result-types long-float)
+  (:translate make-long-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (let ((offset (1+ (tn-offset temp))))
+      (storew exp-bits rbp-tn (- offset))
+      (storew hi-bits rbp-tn (- (1+ offset)))
+      (storew lo-bits rbp-tn (- (+ offset 2)))
+      (with-empty-tn@fp-top(res)
+	(inst fldl (make-ea :qword :base rbp-tn
+			    :disp (- (* (+ offset 2) word-bytes))))))))
+
+(define-vop (single-float-bits)
+  (:args (float :scs (single-reg descriptor-reg)
+		:load-if (not (sc-is float single-stack))))
+  (:results (bits :scs (signed-reg)))
+  (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
+  (:arg-types single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case float
+	 (single-reg
+	  (with-tn@fp-top(float)
+	    (inst fst stack-temp)
+	    (inst mov bits stack-temp)))
+	 (single-stack
+	  (inst mov bits float))
+	 (descriptor-reg
+	  (loadw
+	   bits float vm:single-float-value-slot vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (single-reg
+	  (with-tn@fp-top(float)
+	    (inst fst bits))))))))
+
+(define-vop (double-float-high-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (double-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :qword :base rbp-tn
+				:disp (- (* (+ 2 (tn-offset temp))
+					    word-bytes)))))
+	    (inst fstd where)))
+	(loadw hi-bits rbp-tn (- (1+ (tn-offset temp)))))
+       (double-stack
+	(loadw hi-bits rbp-tn (- (1+ (tn-offset float)))))
+       (descriptor-reg
+	(loadw hi-bits float (1+ vm:double-float-value-slot)
+	       vm:other-pointer-type)))))
+
+(define-vop (double-float-low-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (double-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :qword :base rbp-tn
+				:disp (- (* (+ 2 (tn-offset temp))
+					    word-bytes)))))
+	    (inst fstd where)))
+	(loadw lo-bits rbp-tn (- (+ 2 (tn-offset temp)))))
+       (double-stack
+	(loadw lo-bits rbp-tn (- (+ 2 (tn-offset float)))))
+       (descriptor-reg
+	(loadw lo-bits float vm:double-float-value-slot
+	       vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-exp-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (exp-bits :scs (signed-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types signed-num)
+  (:translate long-float-exp-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :qword :base rbp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(inst movsx exp-bits
+	      (make-ea :word :base rbp-tn
+		       :disp (* (- (1+ (tn-offset temp))) word-bytes))))
+       (long-stack
+	(inst movsx exp-bits
+	      (make-ea :word :base rbp-tn
+		       :disp (* (- (1+ (tn-offset float))) word-bytes))))
+       (descriptor-reg
+	(inst movsx exp-bits
+	      (make-ea :word :base float
+		       :disp (- (* (+ 2 vm:long-float-value-slot) word-bytes)
+				vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (long-float-high-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (hi-bits :scs (unsigned-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :qword :base rbp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(loadw hi-bits rbp-tn (- (+ (tn-offset temp) 2))))
+       (long-stack
+	(loadw hi-bits rbp-tn (- (+ (tn-offset float) 2))))
+       (descriptor-reg
+	(loadw hi-bits float (1+ vm:long-float-value-slot)
+	       vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-low-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :qword :base rbp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(loadw lo-bits rbp-tn (- (+ (tn-offset temp) 3))))
+       (long-stack
+	(loadw lo-bits rbp-tn (- (+ (tn-offset float) 3))))
+       (descriptor-reg
+	(loadw lo-bits float vm:long-float-value-slot
+	       vm:other-pointer-type)))))
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 32)) ; really only 16
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+  float-modes)
+
+(defconstant npx-env-size (* 7 vm:word-bytes))
+(defconstant npx-cw-offset 0)
+(defconstant npx-sw-offset 4)
+
+(define-vop (floating-point-modes)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target res
+		   :to :result) rax)
+  (:generator 8
+   (inst sub rsp-tn npx-env-size)	; make space on stack
+   (inst wait)                          ; Catch any pending FPE exceptions
+   (inst fstenv (make-ea :qword :base rsp-tn)) ; masks all exceptions
+   (inst fldenv (make-ea :qword :base rsp-tn)) ; restore previous state
+   ;; Current status to high word
+   (inst mov rax (make-ea :qword :base rsp-tn :disp (- npx-sw-offset 2)))
+   ;; Exception mask to low word
+   (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
+   (inst add rsp-tn npx-env-size)	; Pop stack
+   (inst xor rax #x3f)	; Flip exception mask to trap enable bits
+   (move res rax)))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg) :to :result :target res))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :eval :to :result) rax)
+  (:generator 3
+   (inst sub rsp-tn npx-env-size)	; make space on stack
+   (inst wait)                          ; Catch any pending FPE exceptions
+   (inst fstenv (make-ea :qword :base rsp-tn))
+   (inst mov rax new)
+   (inst xor rax #x3f)	    ; turn trap enable bits into exception mask
+   (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
+   (inst shr rax 16)			; position status word
+   (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
+   (inst fldenv (make-ea :qword :base rsp-tn))
+   (inst add rsp-tn npx-env-size)	; Pop stack
+   (move res new)))
+
+
+
+#-long-float
+(progn
+
+;;; Lets use some of the 80387 special functions.
+;;;
+;;; These defs will not take effect unless code/irrat.lisp is modified
+;;; to remove the inlined alien routine def.
+
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+	       (:args (x :scs (double-reg) :target fr0))
+	       (:temporary (:sc double-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:results (y :scs (double-reg)))
+	       (:arg-types double-float)
+	       (:result-types double-float)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline NPX function")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:node-var node)
+	       (:ignore fr0)
+	       (:generator 5
+		(note-this-location vop :internal-error)
+		(unless (zerop (tn-offset x))
+		  (inst fxch x)		; x to top of stack
+		  (unless (location= x y)
+		    (inst fst x)))	; maybe save it
+		(inst ,op)		; clobber st0
+		(cond ((zerop (tn-offset y))
+		       (when (policy node (or (= debug 3) (> safety speed)))
+			     (inst wait)))
+		      (t
+		       (inst fst y)))))))
+
+  ;; Quick versions of fsin and fcos that require the argument to be
+  ;; within range 2^63.
+  (frob fsin-quick %sin-quick fsin)
+  (frob fcos-quick %cos-quick fcos)
+  ;;
+  (frob fsqrt %sqrt fsqrt))
+
+;;; Quick version of ftan that requires the argument to be within
+;;; range 2^63.
+(define-vop (ftan-quick)
+  (:translate %tan-quick)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+	     
+;;; These versions of fsin, fcos, and ftan try to use argument
+;;; reduction but to do this accurately requires greater precision and
+;;; it is hopelessly inaccurate.
+#+nil
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (double-reg) :target fr0))
+		(:temporary (:sc unsigned-reg :offset rax-offset
+				 :from :eval :to :result) rax)
+		(:temporary (:sc unsigned-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc unsigned-reg :offset fr1-offset
+				 :from :argument :to :result) fr1)
+		(:results (y :scs (double-reg)))
+		(:arg-types double-float)
+		(:result-types double-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:ignore rax)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (unless (zerop (tn-offset x))
+			  (inst fxch x)		 ; x to top of stack
+			  (unless (location= x y)
+				  (inst fst x))) ; maybe save it
+		  (inst ,op)
+		  (inst fnstsw)			 ; status word to ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (inst fstp fr1) 		; Load 2*PI
+		  (inst fldpi)
+		  (inst fadd fr0)
+		  (inst fxch fr1)
+		  LOOP
+		  (inst fprem1)
+		  (inst fnstsw)		; status word to ax
+		  (inst and ah-tn #x04)	; C2
+		  (inst jmp :nz LOOP)
+		  (inst ,op)
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+#+nil
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :argument :to :result) rax)
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore rax)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldpi)                         ; Load 2*PI
+    (inst fadd fr0)
+    (inst fxch fr1)
+    LOOP
+    (inst fprem1)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :nz LOOP)
+    (inst fstp fr1)
+    (inst fptan)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
+;;; the argument is out of range 2^63 and would thus be hopelessly
+;;; inaccurate.
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (double-reg) :target fr0))
+		(:temporary (:sc double-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc unsigned-reg :offset rax-offset
+			     :from :argument :to :result) rax)
+		(:results (y :scs (double-reg)))
+	        (:arg-types double-float)
+	        (:result-types double-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+	        (:ignore rax fr0)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (unless (zerop (tn-offset x))
+			  (inst fxch x)		 ; x to top of stack
+			  (unless (location= x y)
+				  (inst fst x))) ; maybe save it
+		  (inst ,op)
+		  (inst fnstsw)			 ; status word to ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (fp-pop)			; Load 0.0
+		  (inst fldz)
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :argument :to :result) rax)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:ignore rax)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore rax fr0)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldz)                         ; Load 0.0
+    (inst fxch fr1)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+#+nil
+(define-vop (fexp)
+  (:translate %exp)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline exp function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (cond ((zerop (tn-offset x))
+		;; x is in fr0
+		(inst fstp fr1)
+		(inst fldl2e)
+		(inst fmul fr1))
+	       (t
+		;; x is in a FP reg, not fr0
+		(fp-pop)
+		(inst fldl2e)
+		(inst fmul x))))
+	((double-stack descriptor-reg)
+	 (fp-pop)
+	 (inst fldl2e)
+	 (if (sc-is x double-stack)
+	     (inst fmuld (ea-for-df-stack x))
+	   (inst fmuld (ea-for-df-desc x)))))
+     ;; Now fr0=x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+;;; Modified exp that handles the following special cases:
+;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
+(define-vop (fexp)
+  (:translate %exp)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp)
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline exp function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)	; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)	; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)	; Test sign of Inf.
+     (inst jmp :z DONE)		; +Inf gives +Inf.
+     (fp-pop)			; -Inf gives 0
+     (inst fldz)
+     (inst jmp-short DONE)
+     NOINFNAN
+     (inst fstp fr1)
+     (inst fldl2e)
+     (inst fmul fr1)
+     ;; Now fr0=x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     DONE
+     (unless (zerop (tn-offset y))
+	     (inst fstd y))))
+
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+  (:translate %expm1)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp)
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline expm1 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)	; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)	; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)	; Test sign of Inf.
+     (inst jmp :z DONE)		; +Inf gives +Inf.
+     (fp-pop)			; -Inf gives -1.0
+     (inst fld1)
+     (inst fchs)
+     (inst jmp-short DONE)
+     NOINFNAN
+     ;; Free two stack slots leaving the argument on top.
+     (inst fstp fr2)
+     (fp-pop)
+     (inst fldl2e)
+     (inst fmul fr1)	; Now fr0 = x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fsub-sti fr1)
+     (inst fxch fr1)
+     (inst f2xm1)
+     (inst fscale)
+     (inst fxch fr1)
+     (inst fld1)
+     (inst fscale)
+     (inst fstp fr1)
+     (inst fld1)
+     (inst fsub fr1)
+     (inst fsubr fr2)
+     DONE
+     (unless (zerop (tn-offset y))
+       (inst fstd y))))
+
+(define-vop (flog)
+  (:translate %log)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline log function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((double-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldln2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	     (inst fldd (ea-for-df-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flog10)
+  (:translate %log10)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline log10 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldlg2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((double-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldlg2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	     (inst fldd (ea-for-df-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (fpow)
+  (:translate %pow)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :load :to :result) fr2)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline pow function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x))
+	    (sc-is y double-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (fp-pop)
+       (fp-pop)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fyl2x)
+     ;; Now fr0=y log2(x)
+     (inst fld fr0)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fscalen)
+  (:translate %scalbn)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (signed-stack signed-reg) :target temp))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
+  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float signed-num)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline scalbn function")
+  (:ignore fr0)
+  (:generator 5
+     ;; Setup x in fr0 and y in fr1
+     (sc-case x
+       (double-reg
+	(case (tn-offset x)
+	  (0
+	   (inst fstp fr1)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fxch fr1))
+	  (1
+	   (fp-pop)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fxch fr1))
+	  (t
+	   (fp-pop)
+	   (fp-pop)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fld (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'double-reg *backend*)
+				     :offset (1- (tn-offset x)))))))
+       ((double-stack descriptor-reg)
+	(fp-pop)
+	(fp-pop)
+	(sc-case y
+          (signed-reg
+	   (inst mov temp y)
+	   (inst fild temp))
+	  (signed-stack
+	   (inst fild y)))
+	(if (sc-is x double-stack)
+	    (inst fldd (ea-for-df-stack x))
+	    (inst fldd (ea-for-df-desc x)))))
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+       (inst fstd r))))
+
+(define-vop (fscale)
+  (:translate %scalb)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline scalb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x))
+	    (sc-is y double-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (fp-pop)
+       (fp-pop)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+	     (inst fstd r))))
+
+(define-vop (flog1p)
+  (:translate %log1p)
+  (:args (x :scs (double-reg) :to :result))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:guard (not (backend-featurep :pentium)))
+  (:note "inline log1p function")
+  (:ignore temp)
+  (:generator 5
+     ;; x is in a FP reg, not fr0, fr1.
+     (fp-pop)
+     (fp-pop)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 2)))
+     ;; Check the range
+     (inst push #x3e947ae1)	; Constant 0.29
+     (inst fabs)
+     (inst fld (make-ea :qword :base rsp-tn))
+     (inst fcompp)
+     (inst add rsp-tn 4)
+     (inst fnstsw)			; status word to ax
+     (inst and ah-tn #x45)
+     (inst jmp :z WITHIN-RANGE)
+     ;; Out of range for fyl2xp1.
+     (inst fld1)
+     (inst faddd (make-random-tn :kind :normal
+				 :sc (sc-or-lose 'double-reg *backend*)
+				 :offset (- (tn-offset x) 1)))
+     (inst fldln2)
+     (inst fxch fr1)
+     (inst fyl2x)
+     (inst jmp DONE)
+
+     WITHIN-RANGE
+     (inst fldln2)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 1)))
+     (inst fyl2xp1)
+     DONE
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+;;; The Pentium has a less restricted implementation of the fyl2xp1
+;;; instruction and a range check can be avoided.
+(define-vop (flog1p-pentium)
+  (:translate %log1p)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:guard (backend-featurep :pentium))
+  (:note "inline log1p with limited x range function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x)))))))
+	((double-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldln2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))))
+     (inst fyl2xp1)
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flogb)
+  (:translate %logb)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline logb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (- (tn-offset x) 2))))))
+	((double-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))))
+     (inst fxtract)
+     (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t (inst fxch fr1)
+	  (inst fstd y)))))
+
+(define-vop (fatan)
+  (:translate %atan)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline atan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and 1.0 in fr0
+     (cond 
+      ;; x in fr0
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fstp fr1))
+      ;; x in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       (fp-pop))
+      ;; x not in fr0 or fr1
+      (t
+       ;; Load x then 1.0
+       (fp-pop)
+       (fp-pop)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+     (inst fld1)
+     ;; Now have x at fr1; and 1.0 at fr0
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fatan2)
+  (:translate %atan2)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 1) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline atan2 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and y in fr0
+     (cond 
+      ;; y in fr0; x in fr1
+      ((and (sc-is y double-reg) (zerop (tn-offset y))
+	    (sc-is x double-reg) (= 1 (tn-offset x))))
+      ;; x in fr1; y not in fr0
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y)))))
+      ;; y in fr0, x in fr0
+      ((and (sc-is y double-reg) (zerop (tn-offset y))
+	    (sc-is x double-reg) (zerop (tn-offset x)))
+       ;; Copy x to fr1, leave y in fr0
+       (inst fst fr1))
+      ;; y in fr0; x not in fr1
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x))))
+       (inst fxch fr1))
+      ;; y in fr1; x not in fr1
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc x))))
+       (inst fxch fr1))
+      ;; x in fr0;
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (double-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (double-stack
+	   (fp-pop)
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldd (ea-for-df-desc y)))))
+      ;; Neither y or x are in either fr0 or fr1
+      (t
+       ;; Load x then y
+       (fp-pop)
+       (fp-pop)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))
+       ;; Load y to fr0
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))))
+      
+     ;; Now have y at fr0; and x at fr1
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+) ; progn #-long-float
+
+
+
+#+long-float
+(progn
+
+;;; Lets use some of the 80387 special functions.
+;;;
+;;; These defs will not take effect unless code/irrat.lisp is modified
+;;; to remove the inlined alien routine def.
+
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+	       (:args (x :scs (long-reg) :target fr0))
+	       (:temporary (:sc long-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:ignore fr0)
+	       (:results (y :scs (long-reg)))
+	       (:arg-types long-float)
+	       (:result-types long-float)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline NPX function")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:node-var node)
+	       (:generator 5
+		(note-this-location vop :internal-error)
+		(unless (zerop (tn-offset x))
+		  (inst fxch x)		; x to top of stack
+		  (unless (location= x y)
+		    (inst fst x)))	; maybe save it
+		(inst ,op)		; clobber st0
+		(cond ((zerop (tn-offset y))
+		       (when (policy node (or (= debug 3) (> safety speed)))
+			     (inst wait)))
+		      (t
+		       (inst fst y)))))))
+
+  ;; Quick versions of fsin and fcos that require the argument to be
+  ;; within range 2^63.
+  (frob fsin-quick %sin-quick fsin)
+  (frob fcos-quick %cos-quick fcos)
+  ;;
+  (frob fsqrt %sqrt fsqrt))
+
+;;; Quick version of ftan that requires the argument to be within
+;;; range 2^63.
+(define-vop (ftan-quick)
+  (:translate %tan-quick)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+	     
+;;; These versions of fsin, fcos, and ftan try to use argument
+;;; reduction but to do this accurately requires greater precision and
+;;; it is hopelessly inaccurate.
+#+nil
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (long-reg) :target fr0))
+		(:temporary (:sc unsigned-reg :offset rax-offset
+				 :from :eval :to :result) rax)
+		(:temporary (:sc long-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc long-reg :offset fr1-offset
+				 :from :argument :to :result) fr1)
+		(:results (y :scs (long-reg)))
+		(:arg-types long-float)
+		(:result-types long-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:ignore rax)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (unless (zerop (tn-offset x))
+			  (inst fxch x)		 ; x to top of stack
+			  (unless (location= x y)
+				  (inst fst x))) ; maybe save it
+		  (inst ,op)
+		  (inst fnstsw)			 ; status word to ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (inst fstp fr1) 		; Load 2*PI
+		  (inst fldpi)
+		  (inst fadd fr0)
+		  (inst fxch fr1)
+		  LOOP
+		  (inst fprem1)
+		  (inst fnstsw)		; status word to ax
+		  (inst and ah-tn #x04)	; C2
+		  (inst jmp :nz LOOP)
+		  (inst ,op)
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+#+nil
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :argument :to :result) rax)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore rax)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldpi)                         ; Load 2*PI
+    (inst fadd fr0)
+    (inst fxch fr1)
+    LOOP
+    (inst fprem1)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :nz LOOP)
+    (inst fstp fr1)
+    (inst fptan)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
+;;; the argument is out of range 2^63 and would thus be hopelessly
+;;; inaccurate.
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (long-reg) :target fr0))
+		(:temporary (:sc long-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc unsigned-reg :offset rax-offset
+			     :from :argument :to :result) rax)
+		(:results (y :scs (long-reg)))
+	        (:arg-types long-float)
+	        (:result-types long-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+	        (:ignore rax fr0)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (unless (zerop (tn-offset x))
+			  (inst fxch x)		 ; x to top of stack
+			  (unless (location= x y)
+				  (inst fst x))) ; maybe save it
+		  (inst ,op)
+		  (inst fnstsw)			 ; status word to ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (fp-pop)			; Load 0.0
+		  (inst fldz)
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from :argument :to :result) rax)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:ignore rax)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore rax fr0)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(fp-pop))
+       (t
+	(fp-pop)
+	(fp-pop)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldz)                         ; Load 0.0
+    (inst fxch fr1)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+;;; Modified exp that handles the following special cases:
+;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
+(define-vop (fexp)
+  (:translate %exp)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline exp function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+	     (inst fxch x)		; x to top of stack
+	     (unless (location= x y)
+		     (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)              ; Test sign of Inf.
+     (inst jmp :z DONE)                 ; +Inf gives +Inf.
+     (fp-pop)                    ; -Inf gives 0
+     (inst fldz)
+     (inst jmp-short DONE)
+     NOINFNAN
+     (inst fstp fr1)
+     (inst fldl2e)
+     (inst fmul fr1)
+     ;; Now fr0=x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     DONE
+     (unless (zerop (tn-offset y))
+	     (inst fstd y))))
+
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;;   expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+  (:translate %expm1)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc word-reg :offset rax-offset :from :eval :to :result) temp)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline expm1 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+       (inst fxch x)		; x to top of stack
+       (unless (location= x y)
+	 (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)              ; Test sign of Inf.
+     (inst jmp :z DONE)                 ; +Inf gives +Inf.
+     (fp-pop)                    ; -Inf gives -1.0
+     (inst fld1)
+     (inst fchs)
+     (inst jmp-short DONE)
+     NOINFNAN
+     ;; Free two stack slots leaving the argument on top.
+     (inst fstp fr2)
+     (fp-pop)
+     (inst fldl2e)
+     (inst fmul fr1)	; Now fr0 = x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fsub-sti fr1)
+     (inst fxch fr1)
+     (inst f2xm1)
+     (inst fscale)
+     (inst fxch fr1)
+     (inst fld1)
+     (inst fscale)
+     (inst fstp fr1)
+     (inst fld1)
+     (inst fsub fr1)
+     (inst fsubr fr2)
+     DONE
+     (unless (zerop (tn-offset y))
+       (inst fstd y))))
+
+(define-vop (flog)
+  (:translate %log)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline log function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (long-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((long-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldln2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	     (inst fldl (ea-for-lf-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flog10)
+  (:translate %log10)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline log10 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (long-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldlg2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((long-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldlg2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	     (inst fldl (ea-for-lf-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (fpow)
+  (:translate %pow)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :load :to :result) fr2)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline pow function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x))
+	    (sc-is y long-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (fp-pop)
+       (fp-pop)
+       (sc-case y
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fyl2x)
+     ;; Now fr0=y log2(x)
+     (inst fld fr0)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fscalen)
+  (:translate %scalbn)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (signed-stack signed-reg) :target temp))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
+  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float signed-num)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline scalbn function")
+  (:ignore fr0)
+  (:generator 5
+     ;; Setup x in fr0 and y in fr1
+     (sc-case x
+       (long-reg
+	(case (tn-offset x)
+	  (0
+	   (inst fstp fr1)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fxch fr1))
+	  (1
+	   (fp-pop)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fxch fr1))
+	  (t
+	   (fp-pop)
+	   (fp-pop)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fld (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'double-reg *backend*)
+				     :offset (1- (tn-offset x)))))))
+       ((long-stack descriptor-reg)
+	(fp-pop)
+	(fp-pop)
+	(sc-case y
+          (signed-reg
+	   (inst mov temp y)
+	   (inst fild temp))
+	  (signed-stack
+	   (inst fild y)))
+	(if (sc-is x long-stack)
+	    (inst fldl (ea-for-lf-stack x))
+	    (inst fldl (ea-for-lf-desc x)))))
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+       (inst fstd r))))
+
+(define-vop (fscale)
+  (:translate %scalb)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline scalb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x))
+	    (sc-is y long-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (fp-pop)
+       (fp-pop)
+       (sc-case y
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+	     (inst fstd r))))
+
+(define-vop (flog1p)
+  (:translate %log1p)
+  (:args (x :scs (long-reg) :to :result))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:guard (not (backend-featurep :pentium)))
+  (:note "inline log1p function")
+  (:ignore temp)
+  (:generator 5
+     ;; x is in a FP reg, not fr0, fr1.
+     (fp-pop)
+     (fp-pop)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 2)))
+     ;; Check the range
+     (inst push #x3e947ae1)	; Constant 0.29
+     (inst fabs)
+     (inst fld (make-ea :qword :base rsp-tn))
+     (inst fcompp)
+     (inst add rsp-tn 4)
+     (inst fnstsw)			; status word to ax
+     (inst and ah-tn #x45)
+     (inst jmp :z WITHIN-RANGE)
+     ;; Out of range for fyl2xp1.
+     (inst fld1)
+     (inst faddd (make-random-tn :kind :normal
+				 :sc (sc-or-lose 'double-reg *backend*)
+				 :offset (- (tn-offset x) 1)))
+     (inst fldln2)
+     (inst fxch fr1)
+     (inst fyl2x)
+     (inst jmp DONE)
+
+     WITHIN-RANGE
+     (inst fldln2)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 1)))
+     (inst fyl2xp1)
+     DONE
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+;;; The Pentium has a less restricted implementation of the fyl2xp1
+;;; instruction and a range check can be avoided.
+(define-vop (flog1p-pentium)
+  (:translate %log1p)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:guard (backend-featurep :pentium))
+  (:note "inline log1p function")
+  (:generator 5
+     (sc-case x
+        (long-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (1- (tn-offset x)))))))
+	((long-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (inst fldln2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	   (inst fldl (ea-for-lf-desc x)))))
+     (inst fyl2xp1)
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flogb)
+  (:translate %logb)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline logb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore fr0)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (long-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1))
+	    (1
+	     ;; x is in fr1
+	     (fp-pop))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (fp-pop)
+	     (fp-pop)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg *backend*)
+					:offset (- (tn-offset x) 2))))))
+	((long-stack descriptor-reg)
+	 (fp-pop)
+	 (fp-pop)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	   (inst fldl (ea-for-lf-desc x)))))
+     (inst fxtract)
+     (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t (inst fxch fr1)
+	  (inst fstd y)))))
+
+(define-vop (fatan)
+  (:translate %atan)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline atan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and 1.0 in fr0
+     (cond 
+      ;; x in fr0
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fstp fr1))
+      ;; x in fr1
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       (fp-pop))
+      ;; x not in fr0 or fr1
+      (t
+       ;; Load x then 1.0
+       (fp-pop)
+       (fp-pop)
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))))
+     (inst fld1)
+     ;; Now have x at fr1; and 1.0 at fr0
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fatan2)
+  (:translate %atan2)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 1) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline atan2 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and y in fr0
+     (cond 
+      ;; y in fr0; x in fr1
+      ((and (sc-is y long-reg) (zerop (tn-offset y))
+	    (sc-is x long-reg) (= 1 (tn-offset x))))
+      ;; x in fr1; y not in fr0
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y)))))
+      ;; y in fr0; x not in fr1
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x))))
+       (inst fxch fr1))
+      ;; y in fr1; x not in fr1
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc x))))
+       (inst fxch fr1))
+      ;; x in fr0;
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (fp-pop)
+	   (inst fldl (ea-for-lf-desc y)))))
+      ;; Neither y or x are in either fr0 or fr1
+      (t
+       ;; Load x then y
+       (fp-pop)
+       (fp-pop)
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset y)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc y))))))
+      
+     ;; Now have y at fr0; and x at fr1
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+) ; progn #+long-float
+
+
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+  (:translate complex)
+  (:args (real :scs (single-reg) :to :result :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (single-reg) :to :save))
+  (:arg-types single-float single-float)
+  (:results (r :scs (complex-single-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-single-stack))))
+  (:result-types complex-single-float)
+  (:note "inline complex single-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-single-reg
+       (let ((r-real (complex-double-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 real))
+		 ((zerop (tn-offset real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch real)
+		  (inst fstd r-real)
+		  (inst fxch real)))))
+       (let ((r-imag (complex-double-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (cond ((zerop (tn-offset imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch imag)
+		  (inst fstd r-imag)
+		  (inst fxch imag))))))
+      (complex-single-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fst (ea-for-csf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fst (ea-for-csf-real-stack r))
+		(inst fxch real))))
+       (inst fxch imag)
+       (inst fst (ea-for-csf-imag-stack r))
+       (inst fxch imag)))))
+
+(define-vop (make-complex-double-float)
+  (:translate complex)
+  (:args (real :scs (double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-reg) :to :save))
+  (:arg-types double-float double-float)
+  (:results (r :scs (complex-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-stack))))
+  (:result-types complex-double-float)
+  (:note "inline complex double-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-double-reg
+       (let ((r-real (complex-double-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 real))
+		 ((zerop (tn-offset real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch real)
+		  (inst fstd r-real)
+		  (inst fxch real)))))
+       (let ((r-imag (complex-double-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (cond ((zerop (tn-offset imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch imag)
+		  (inst fstd r-imag)
+		  (inst fxch imag))))))
+      (complex-double-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fstd (ea-for-cdf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fstd (ea-for-cdf-real-stack r))
+		(inst fxch real))))
+       (inst fxch imag)
+       (inst fstd (ea-for-cdf-imag-stack r))
+       (inst fxch imag)))))
+
+#+long-float
+(define-vop (make-complex-long-float)
+  (:translate complex)
+  (:args (real :scs (long-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (long-reg) :to :save))
+  (:arg-types long-float long-float)
+  (:results (r :scs (complex-long-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-long-stack))))
+  (:result-types complex-long-float)
+  (:note "inline complex long-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-long-reg
+       (let ((r-real (complex-double-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 real))
+		 ((zerop (tn-offset real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch real)
+		  (inst fstd r-real)
+		  (inst fxch real)))))
+       (let ((r-imag (complex-double-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (cond ((zerop (tn-offset imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch imag)
+		  (inst fstd r-imag)
+		  (inst fxch imag))))))
+      (complex-long-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(store-long-float (ea-for-clf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(store-long-float (ea-for-clf-real-stack r))
+		(inst fxch real))))
+       (inst fxch imag)
+       (store-long-float (ea-for-clf-imag-stack r))
+       (inst fxch imag)))))
+
+
+(define-vop (complex-float-value)
+  (:args (x :target r))
+  (:results (r))
+  (:variant-vars offset)
+  (:policy :fast-safe)
+  (:generator 3
+    (cond ((sc-is x complex-single-reg complex-double-reg
+		  #+long-float complex-long-reg)
+	   (let ((value-tn
+		  (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (+ offset (tn-offset x)))))
+	     (unless (location= value-tn r)
+	       (cond ((zerop (tn-offset r))
+		      (copy-fp-reg-to-fr0 value-tn))
+		     ((zerop (tn-offset value-tn))
+		      (inst fstd r))
+		     (t
+		      (inst fxch value-tn)
+		      (inst fstd r)
+		      (inst fxch value-tn))))))
+	  ((sc-is r single-reg)
+	   (let ((ea (sc-case x
+		       (complex-single-stack
+			(ecase offset
+			  (0 (ea-for-csf-real-stack x))
+			  (1 (ea-for-csf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-csf-real-desc x))
+			  (1 (ea-for-csf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fld ea))))
+	  ((sc-is r double-reg)
+	   (let ((ea (sc-case x
+		       (complex-double-stack
+			(ecase offset
+			  (0 (ea-for-cdf-real-stack x))
+			  (1 (ea-for-cdf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-cdf-real-desc x))
+			  (1 (ea-for-cdf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fldd ea))))
+	  #+long-float
+	  ((sc-is r long-reg)
+	   (let ((ea (sc-case x
+		       (complex-long-stack
+			(ecase offset
+			  (0 (ea-for-clf-real-stack x))
+			  (1 (ea-for-clf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-clf-real-desc x))
+			  (1 (ea-for-clf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fldl ea))))
+	  (t (error "Complex-float-value VOP failure")))))
+
+(define-vop (realpart/complex-single-float complex-float-value)
+  (:translate realpart)
+  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:note "complex float realpart")
+  (:variant 0))
+
+(define-vop (realpart/complex-double-float complex-float-value)
+  (:translate realpart)
+  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "complex float realpart")
+  (:variant 0))
+
+#+long-float
+(define-vop (realpart/complex-long-float complex-float-value)
+  (:translate realpart)
+  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-long-float)
+  (:results (r :scs (long-reg)))
+  (:result-types long-float)
+  (:note "complex float realpart")
+  (:variant 0))
+
+(define-vop (imagpart/complex-single-float complex-float-value)
+  (:translate imagpart)
+  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:note "complex float imagpart")
+  (:variant 1))
+
+(define-vop (imagpart/complex-double-float complex-float-value)
+  (:translate imagpart)
+  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "complex float imagpart")
+  (:variant 1))
+
+#+long-float
+(define-vop (imagpart/complex-long-float complex-float-value)
+  (:translate imagpart)
+  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-long-float)
+  (:results (r :scs (long-reg)))
+  (:result-types long-float)
+  (:note "complex float imagpart")
+  (:variant 1))
+
+
+;;; A hack dummy VOP to bias the representation selection of its
+;;; argument towards a FP register which can help avoid consing at
+;;; inappropriate locations.
+
+(defknown double-float-reg-bias (double-float) (values))
+;;;
+(define-vop (double-float-reg-bias)
+  (:translate double-float-reg-bias)
+  (:args (x :scs (double-reg double-stack) :load-if nil))
+  (:arg-types double-float)
+  (:policy :fast-safe)
+  (:note "inline dummy FP register bias")
+  (:ignore x)
+  (:generator 0))
+
+(defknown single-float-reg-bias (single-float) (values))
+;;;
+(define-vop (single-float-reg-bias)
+  (:translate single-float-reg-bias)
+  (:args (x :scs (single-reg single-stack) :load-if nil))
+  (:arg-types single-float)
+  (:policy :fast-safe)
+  (:note "inline dummy FP register bias")
+  (:ignore x)
+  (:generator 0))
diff --git a/compiler/amd64/insts.lisp b/compiler/amd64/insts.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8d817dc7cc12f5378f6c85ee1d75b45e80808b99
--- /dev/null
+++ b/compiler/amd64/insts.lisp
@@ -0,0 +1,3068 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/insts.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Description of the AMD64 instruction set.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Debugging and enhancements by Douglas Crosher 1996, 1997, 1998.
+;;;
+
+(in-package :amd64)
+
+(use-package :new-assem)
+
+(def-assembler-params
+  :scheduler-p nil)
+
+(disassem:set-disassem-params :instruction-alignment 8
+			      :opcode-column-width 8)
+
+
+
+;;;; Primitive emitters.
+
+(define-emitter emit-word 16
+  (byte 16 0))
+
+(define-emitter emit-dword 32
+  (byte 32 0))
+
+(define-emitter emit-qword 64
+  (byte 64 0))
+
+(define-emitter emit-byte-with-reg 8
+  (byte 5 3) (byte 3 0))
+
+(define-emitter emit-mod-reg-r/m-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+(define-emitter emit-sib-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+
+
+;;;; Fixup emitters.
+
+(defun emit-absolute-fixup (segment fixup &optional 64-bit-p)
+  ;; absolute fixup should always be 64 bit.
+  (note-fixup segment :absolute fixup)
+  (let ((offset (fixup-offset fixup)))
+    (if 64-bit-p
+	(if (label-p offset)
+	    (emit-back-patch segment 8
+			     #'(lambda (segment posn)
+				 (declare (ignore posn))
+				 (emit-qword segment
+					     (- (+ (component-header-length)
+						   (or (label-position offset) 0))
+						other-pointer-type))))
+	    (emit-qword segment (or offset 0)))
+	;; should get rid of this case
+	(if (label-p offset)
+	    (emit-back-patch segment 4
+			     #'(lambda (segment posn)
+				 (declare (ignore posn))
+				 (emit-dword segment
+					     (- (+ (component-header-length)
+						   (or (label-position offset) 0))
+						other-pointer-type))))
+	    (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))
+  (assert (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))
+	    (:print-function %print-ea))
+  (size nil :type (member :byte :word :dword :qword))
+  (base nil :type (or tn null))
+  (index nil :type (or tn null))
+  (scale 1 :type (member 1 2 4 8))
+  (disp 0 :type (or (signed-byte 32) fixup)))
+
+(defun valid-displacement-p (x)
+  (typep x '(or (signed-byte 32) fixup)))
+
+(defun %print-ea (ea stream depth)
+  (declare (ignore depth))
+  (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 (amd64-location-print-name (ea-base ea)) stream)
+	   (when (ea-index ea)
+	     (write-string "+" stream)))
+	 (when (ea-index ea)
+	   (write-string (amd64-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 absolute-ea-p (ea)
+  (and (ea-p ea)
+       (eq (ea-size ea) :qword)
+       (null (ea-base ea))
+       (null (ea-index ea))
+       (= (ea-scale ea) 1)))
+
+(defun emit-absolute-ea (segment ea)
+  (assert (absolute-ea-p ea))
+  (emit-qword segment (ea-disp ea)))
+
+(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 RBP.
+	(let ((disp (- (* (1+ (tn-offset thing)) 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 #b100)
+	;; This is bad. We'd get rid of 32 bit addresses
+	(emit-sib-byte segment #b00 #b100 #b101) ; set to zero-based disp 32
+	(emit-absolute-fixup segment
+			     (make-fixup nil
+					 :code-object
+					 (- (* (tn-offset thing) word-bytes)
+					    other-pointer-type))))))
+    (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 #b100)
+     ;; This is bad. We'd get rid of 32 bit addresses
+     (emit-sib-byte segment #b00 #b100 #b101) ; set to zero-based disp 32
+     (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 qword-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) qword-sc-names)
+       t))
+
+(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)))
+
+(eval-when (compile load eval)
+(defconstant 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)))
+
+(defun conditional-opcode (condition)
+  (cdr (assoc condition conditions :test #'eq))))
+
+
+
+;;;; Utilities.
+
+#-lispworks3
+(defconstant operand-size-prefix-byte #b01100110)
+
+#+lispworks3
+(eval-when (compile load eval)
+  (defconstant operand-size-prefix-byte #b01100110))
+
+(defparameter *default-operand-size* :dword)
+
+(defun maybe-emit-operand-size-prefix (segment size
+				       &optional (default-operand-size *default-operand-size*))
+  (unless (or (eq size :byte) (eq size default-operand-size))
+    (case size
+      (:word (emit-byte segment operand-size-prefix-byte))
+      (:qword (emit-byte segment #b01001000))))) ; REX prefix #x48
+
+(defun operand-size (thing)
+  (typecase thing
+    (tn
+     (case (sc-name (tn-sc thing))
+       (#.qword-sc-names
+	:qword)
+       (#.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 &optional allow-qword)
+  (ecase size
+    (:byte
+     (emit-byte segment value))
+    (:word
+     (emit-word segment value))
+    (:dword
+     (emit-dword segment value))
+    (:qword
+     (if allow-qword
+	 (emit-qword segment value)
+	 ;; most instructions only allow 32 bit immediates
+	 ;; I should turn on an error or warning here
+	 ;; (assert (<= (integer-length value) 32))
+	 (emit-dword segment value)))))
+
+
+
+;;;; Disassembler support stuff.
+
+(deftype reg () '(unsigned-byte 3))  
+#+cross-compiler
+(lisp:deftype reg () '(unsigned-byte 3))
+
+(eval-when (compile eval load)
+
+(defparameter *default-address-size*
+  ;; Actually, :dword is the only one really supported.
+  :qword)
+
+(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))
+(defparameter qword-reg-names
+  #(rax rcx rdx rbx rsp rbp rsi rdi))
+
+(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)
+		 (:qword qword-reg-names))
+	       value)
+	 stream)
+  ;; plus should do some source-var notes
+  )
+
+(defun print-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value
+			(disassem:dstate-get-prop dstate 'width)
+			stream
+			dstate))
+
+(defun print-word-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value
+			(or (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 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 disassem:disassem-state dstate))
+  (print-reg-with-width value *default-address-size* stream dstate))
+
+;;; Value is a list of (BASE-REG OFFSET INDEX-REG INDEX-SCALE)
+(defun print-mem-access (value stream print-size-p dstate)
+  (declare (type list value)
+	   (type stream stream)
+	   (type (member t nil) print-size-p)
+	   (type disassem:disassem-state dstate))
+  (when print-size-p
+    (princ (disassem:dstate-get-prop dstate 'width) stream)
+    (princ '| PTR | stream))
+  (write-char #\[ stream)
+  (let ((firstp t))
+    (macrolet ((pel ((var val) &body body)
+		 ;; Print an element of the address, maybe with
+		 ;; a leading separator.
+		 `(let ((,var ,val))
+		    (when ,var
+		      (unless firstp
+			(write-char #\+ stream))
+		      ,@body
+		      (setq firstp nil)))))
+      (pel (base-reg (first value))
+	(print-addr-reg base-reg stream dstate))
+      (pel (index-reg (third value))
+	(print-addr-reg index-reg stream dstate)
+	(let ((index-scale (fourth value)))
+	  (when (and index-scale (not (= index-scale 1)))
+	    (write-char #\* stream)
+	    (princ index-scale stream))))
+      (let ((offset (second value)))
+	(when (and offset (or firstp (not (zerop offset))))
+	  (unless (or firstp (minusp offset))
+	    (write-char #\+ stream))
+	  (if firstp
+	      (let ((unsigned-offset (if (minusp offset)
+					 (+ #x100000000 offset)
+					 offset)))
+		(disassem:princ16 unsigned-offset stream)
+		(or (nth-value 1
+			       (disassem::note-code-constant-absolute unsigned-offset
+								      dstate))
+		    (disassem:maybe-note-assembler-routine unsigned-offset
+							   stream
+							   dstate)
+		    (let ((offs (- offset disassem::nil-addr)))
+		      (when (typep offs 'disassem::offset)
+			(or (disassem::maybe-note-nil-indexed-symbol-slot-ref offs
+									      dstate)
+			    (disassem::maybe-note-static-function offs dstate))))))
+	      (princ offset stream))))))
+  (write-char #\] stream))
+
+(defun print-imm-data (value stream dstate)
+  (let ((offset (- value disassem::nil-addr)))
+    (if (zerop offset)
+	(format stream "#x~X" value)
+	(format stream "~A" value))
+    (when (typep offset 'disassem::offset)
+      (or (disassem::maybe-note-nil-indexed-object offset dstate)
+	  (let ((unsigned-offset (if (and (numberp value) (minusp value))
+				     (+ value #x100000000)
+				     value)))
+	    (disassem::maybe-note-assembler-routine unsigned-offset stream dstate))
+	  (nth-value 1
+		     (disassem::note-code-constant-absolute offset
+							    dstate))))))
+
+(defun print-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+	   (type stream stream)
+	   (type 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 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 disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-byte-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-label (value stream dstate)
+  (declare (ignore dstate))
+  (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 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 (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)
+			      (disassem:read-signed-suffix 32 dstate)
+			      nil))
+			 (#b01
+			  (disassem:read-signed-suffix 8 dstate))
+			 (#b10
+			  (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 (disassem:read-signed-suffix 32 dstate)) )
+	  ((= mod #b00)
+	   (list r/m))
+	  ((= mod #b01)
+	   (list r/m (disassem:read-signed-suffix 8 dstate)))
+	  (t				; (= mod #b10)
+	   (list r/m (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 (disassem:dstate-get-prop dstate 'width)
+	(if (zerop value)
+	    :byte
+	    (let ((word-width
+		   ;; set by a prefix instruction
+		   (or (disassem:dstate-get-prop dstate 'word-width)
+		       *default-operand-size*)))
+	      (when (not (eql word-width *default-operand-size*))
+		;; reset it
+		(setf (disassem:dstate-get-prop dstate 'word-width)
+		      *default-operand-size*))
+	      word-width))))
+
+(defun offset-next (value dstate)
+  (declare (type integer value)
+	   (type disassem:disassem-state dstate))
+  (+ (disassem:dstate-next-addr dstate) value))
+
+(defun read-address (value dstate)
+  (declare (ignore value))		; always nil anyway
+  (disassem:read-suffix (width-bits *default-address-size*) dstate))
+
+(defun width-bits (width)
+  (ecase width
+    (:byte 8)
+    (:word 16)
+    (:dword 32)
+    (:qword 64)
+    (:float 32)
+    (:double 64)))
+
+); eval-when
+
+
+;;;; Disassembler argument types.
+
+(disassem:define-argument-type accum
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore value)
+			(type stream stream)
+			(type disassem:disassem-state dstate))
+	       (print-reg 0 stream dstate))
+  )
+
+(disassem:define-argument-type word-accum
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore value)
+			(type stream stream)
+			(type disassem:disassem-state dstate))
+	       (print-word-reg 0 stream dstate))
+  )
+
+(disassem:define-argument-type reg
+  :printer #'print-reg)
+
+(disassem:define-argument-type addr-reg
+  :printer #'print-addr-reg)
+
+(disassem:define-argument-type word-reg
+  :printer #'print-word-reg)
+
+(disassem:define-argument-type imm-addr
+  :prefilter #'read-address
+  :printer #'print-label)
+
+(disassem:define-argument-type imm-data
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-suffix
+		  (width-bits (disassem:dstate-get-prop dstate 'width))
+		  dstate))
+  :printer #'print-imm-data
+  )
+
+(disassem:define-argument-type signed-imm-data
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (let ((width (disassem:dstate-get-prop dstate 'width)))
+		   (disassem:read-signed-suffix (width-bits width) dstate)))
+  )
+
+(disassem:define-argument-type signed-imm-byte
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-signed-suffix 8 dstate)))
+
+(disassem:define-argument-type signed-imm-dword
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value))		; always nil anyway
+		 (disassem:read-signed-suffix 32 dstate)))
+
+(disassem:define-argument-type imm-word
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (let ((width
+			(or (disassem:dstate-get-prop dstate 'word-width)
+			    *default-operand-size*)))
+		   (disassem:read-suffix (width-bits width) dstate))))
+
+;;; Needed for the ret imm16 instruction
+(disassem:define-argument-type imm-word-16
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-suffix 16 dstate)))
+
+(disassem:define-argument-type reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-reg/mem)
+(disassem:define-argument-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)
+(disassem:define-argument-type byte-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-byte-reg/mem)
+
+;;;
+;;; added by jrd
+;;;
+(eval-when (compile load eval)
+(defun print-fp-reg (value stream dstate)
+  (declare (ignore dstate))
+  (format stream "~A(~D)" 'st value))
+
+(defun prefilter-fp-reg (value dstate)
+  ;; just return it
+  (declare (ignore dstate))
+  value)
+)
+(disassem:define-argument-type fp-reg
+			       :prefilter #'prefilter-fp-reg
+			       :printer #'print-fp-reg)
+
+(disassem:define-argument-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 (disassem:dstate-get-prop dstate 'word-width)
+			      *default-operand-size*)))
+		     (princ (schar (symbol-name word-width) 0) stream)))))
+
+
+;;;; Disassembler instruction formats.
+
+(eval-when (compile eval)
+  (defun swap-if (direction field1 separator field2)
+    `(:if (,direction :constant 0)
+	  (,field1 ,separator ,field2)
+	  (,field2 ,separator ,field1))))
+
+(disassem:define-instruction-format (byte 8 :default-printer '(:name))
+  (op    :field (byte 8 0))
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+(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
+(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 occuring by default,
+;;; and with an appropiate printer.
+(disassem:define-instruction-format (accum-imm 8
+				     :include 'simple
+				     :default-printer '(:name
+							:tab accum ", " imm))
+  (imm :type 'imm-data))
+
+(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
+(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
+(disassem:define-instruction-format (reg-dir 8 :include 'reg)
+  (op  :field (byte 3 5))
+  (dir :field (byte 1 4)))
+
+(disassem:define-instruction-format (two-bytes 16
+				     :default-printer '(:name))
+  (op :fields (list (byte 8 0) (byte 8 8))))
+
+(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
+(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.
+(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 occuring by default,
+;;; and with an appropiate printer.
+(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
+(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
+(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
+(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))
+
+;;; ----------------------------------------------------------------
+;;; this section added by jrd, for fp instructions.  
+
+;;; 
+;;; regular fp inst to/from registers/memory
+;;;
+(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
+;;;
+(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.
+;;;
+(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))
+
+
+;;; pfw
+;;; fp no operand isns
+;;;
+(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)))
+
+(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))))
+
+(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)))
+
+(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)))
+
+
+;;; ----------------------------------------------------------------
+
+
+;;;; General Data Transfer
+
+(eval-when (eval compile load)
+  (defun toggle-word-width (chunk inst stream dstate)
+    (declare (ignore chunk inst stream))
+    (let ((ww (or (disassem:dstate-get-prop dstate 'word-width)
+		  *default-operand-size*)))
+      (setf (disassem:dstate-get-prop dstate 'word-width)
+	    (ecase ww
+	      (:word :dword)
+	      (:dword :word)
+	      (:qword :dword)))))) ; not sure what this is for
+
+;;; This isn't a really an instruction, but it's easier to deal with it this
+;;; way.  We assume that it's actually used.
+(define-instruction toggle-data-size (segment)
+  (:printer byte ((op operand-size-prefix-byte))
+	    nil				; don't actually print it
+	    :control #'toggle-word-width))
+
+
+(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 ; B0
+					   #b10111) ; B8
+				       (reg-tn-encoding dst))
+		   (emit-sized-immediate segment size src t)) ; allow qword
+		  ((and (accumulator-p dst)
+			(or (fixup-p src)
+			    (and (tn-p src) (eq (sb-name (sc-sb (tn-sc src))) 'constant))
+			    (absolute-ea-p src)))
+		   (assert (eq size :qword))
+		   (emit-byte segment #b10100001) ; #xA1
+		   (etypecase src
+		     (fixup (emit-absolute-fixup segment src t)) ; 64 bit offset
+		     (tn (emit-absolute-fixup segment
+					      (make-fixup nil
+							  :code-object
+							  (- (* (tn-offset src) word-bytes)
+							     other-pointer-type))
+					      t))  ; 64 bit offset
+		     (ea (emit-absolute-ea segment src))))
+		  (t
+		   (emit-byte segment
+			      (if (eq size :byte)
+				  #b10001010
+				  #b10001011)) ; #x8b
+		   (emit-ea segment src (reg-tn-encoding dst) t))))
+	   ((and (accumulator-p src)
+		 (or (fixup-p dst)
+		     (absolute-ea-p dst)))
+	    (assert (eq size :qword))
+	    (emit-byte segment #b10100011) ; #xA3
+	    (etypecase dst
+	      (fixup (emit-absolute-fixup segment dst t))
+	      (ea (emit-absolute-ea 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)
+	    (assert (eq size :qword))
+	    (emit-byte segment #b11000111) ; C7
+	    (emit-ea segment dst #b000)
+	    (emit-absolute-fixup segment src))
+	   (t
+	    (error "Bogus arguments to MOV: ~S ~S" dst src))))))
+
+;; Use this if we don't want indirect for fixup
+(define-instruction mov-imm (segment dst src)
+  (:emitter
+   (assert (qword-reg-p dst))
+   (assert (fixup-p src))
+   (emit-byte segment #b01001000) ; prefix instruction #x48
+   (emit-byte-with-reg segment
+		       #b10111 ; B8 MOV
+		       (reg-tn-encoding dst))
+   (emit-absolute-fixup segment src t))) ; imm64
+
+(defun emit-move-with-extension (segment dst src opcode)
+  (assert (register-p dst))
+  (let ((dst-size (operand-size dst))
+	(src-size (operand-size src)))
+    (ecase dst-size
+      (:word
+       (assert (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)))))
+      (:qword ; this needs to be looked at
+       (ecase src-size
+	 (:byte
+	  (maybe-emit-operand-size-prefix segment :qword)
+	  (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)))
+	 (:dword
+	  ;; I think we don't need a REX prefix here
+	  (emit-byte segment opcode)
+	  (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 movsxd (segment dst src)
+  ;; source size is dword
+  ;; dest size is qword
+  (:printer ext-reg-reg/mem ((op #b01100011) (reg nil :type 'word-reg)))
+  (:emitter
+   (emit-move-with-extension segment dst src #b01100011))) ; 63
+
+(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
+	  ;; This is a problem because push can't take 64-bit immediate
+	  (emit-byte segment #b01101000)
+	  (emit-absolute-fixup segment src))
+	 (t
+	  (let ((size (operand-size src)))
+	    (assert (not (eq size :byte)))
+	    (maybe-emit-operand-size-prefix segment size :qword)
+	    (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)))
+     (assert (not (eq size :byte)))
+     (maybe-emit-operand-size-prefix segment size :qword) ; doesn't need rex prefix
+     (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)))))))
+
+;; load effective address
+;; LEA cannot take 64 bit argument. Sign extension doesn't make sense here.
+(define-instruction lea (segment dst src)
+  (:printer reg-reg/mem ((op #b1000110) (width 1)))
+  (:emitter
+   (assert (qword-reg-p dst))
+   ;; We need to turn on this assertion after changing all lea fixup to mov-imm
+   ;; (assert (not (fixup-p src)))
+   (emit-byte segment #b01001000) ; prefix instruction #x48
+   (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
+   (assert (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)))))
+
+
+;;;; 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 eval)
+  (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)
+     ;; Note that #x40 can't be used now.
+     (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)
+     ;; Note that #x48 can't be used now.
+     (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)))
+     (assert (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 '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)))
+     (assert (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)))
+     (assert (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)))
+
+;;; CDO -- Convert Quad Word to Double Quad Word. RDX:RAX <- sign_xtnd(RAX)
+;;; 
+(define-instruction cdo (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :qword)
+   (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
+   (assert (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 eval)
+  (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 eval)
+  (defun double-shift-inst-printer-list (op)
+    `(#+nil
+      (ext-reg-reg/mem-imm ((op ,(logior op #b100))
+			    (imm nil :type signed-imm-byte)))
+      (ext-reg-reg/mem ((op ,(logior op #b101)))
+	 (:name :tab reg/mem ", " 'cl)))))
+
+(define-instruction shld (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b10100000))
+  (: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 #b10101000))
+  (: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.
+
+(disassem:define-instruction-format (string-op 8
+				     :include 'simple
+				     :default-printer '(:name width)))
+
+(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)))
+     (assert (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)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
+
+;; move data from string to string
+(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)))
+     (assert (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)))
+     (assert (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)))
+     (assert (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))))))
+
+;; Bit Test (BT) instructions
+;; Ignoring the case with a src as a register, we have
+;;
+;;   0F A3 reg/mem  BT
+;;   0F BB reg/mem  BTC
+;;   0F B3 reg/mem
+;;   0F AB reg/mem
+;;
+;; A3 = 10100011
+;; BB = 10111011
+;; B3 = 10110011
+;; AB = 10101011
+;;
+;; So the pattern is 10xxx011
+;;
+;; The instruction format is then (little-endian)
+;;
+;; |reg/mem|10ooo011|00001111
+(disassem:define-instruction-format
+    (bit-test-reg/mem 24
+		      :default-printer '(:name :tab reg/mem ", " reg))
+  (prefix	:field (byte 8 0)	:value #b0001111)
+  (op		:field (byte 3 11))
+  ;;(test		:fields (list (byte 2 14) (byte 3 8)))
+  (reg/mem	:fields (list (byte 2 22) (byte 3 16))
+		:type 'reg/mem)
+  (reg		:field (byte 3 19) :type 'reg)
+  ;; optional fields
+  (imm))
+
+(define-instruction bt (segment src index)
+  (:printer bit-test-reg/mem ((op #b100)))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b100)))
+
+(define-instruction btc (segment src index)
+  (:printer bit-test-reg/mem ((op #b111)))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b111)))
+
+(define-instruction btr (segment src index)
+  (:printer bit-test-reg/mem ((op #b110)))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b110)))
+
+(define-instruction bts (segment src index)
+  (:printer bit-test-reg/mem ((op #b101)))
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b101)))
+
+
+;;;; Control transfer.
+
+(eval-when (compile load eval)
+(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)))
+
+(disassem:define-argument-type condition-code
+  :printer condition-name-vec)
+
+(disassem:define-argument-type displacement
+  :sign-extend t
+  :use-label #'offset-next
+  :printer #'(lambda (value stream dstate)
+	       (let ((unsigned-val (if (and (numberp value) (minusp value))
+				       (+ value #x100000000)
+				       value)))
+		 (disassem:maybe-note-assembler-routine unsigned-val stream dstate))
+	       (print-label value stream dstate)))
+
+(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))
+
+(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))
+
+(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
+			(disassem:read-signed-suffix 32 dstate))))
+
+(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
+			(disassem:read-signed-suffix 32 dstate))))
+
+
+(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)
+      ;; Relative fixup is limited to 32 bits. This may not be enough.
+      (emit-relative-fixup segment where))
+     (t
+      ;; REX is necessary for stuff like "callq *%rdi"
+      (unless (ea-p where)
+	(emit-byte segment #b01001000)) ; REX prefix #x48
+      (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))))
+			 (assert (<= -128 disp 127))
+			 (emit-byte segment disp)))))
+
+;; fix it for 64 bit reg
+(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.
+
+(disassem:define-instruction-format (cond-move 24
+				     :default-printer
+				        '('cmov cond :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)	:value #b00001111)
+  (op      :field (byte 4 12)	:value #b0100)
+  (cond    :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))
+
+(define-instruction cmov (segment cond dst src)
+  (:printer cond-move ())
+  (:emitter
+   (assert (register-p dst))
+   (let ((size (matching-operand-size dst src)))
+     (assert (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.
+
+(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))
+
+(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
+
+(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)))
+
+(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)))
+
+
+;;;; Interrupt instructions.
+
+;;; Single byte instruction with an immediate byte argument.
+(disassem:define-instruction-format (byte-imm 16
+				     :default-printer '(:name :tab code))
+ (op :field (byte 8 0))
+ (code :field (byte 8 8)))
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (system:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type system:system-area-pointer sap)
+             (type (unsigned-byte 8) length)
+             (type (simple-array (unsigned-byte 8) (*)) vector))
+    (cond (length-only
+           (values 0 (1+ length) nil nil))
+          (t
+           (kernel:copy-from-system-area sap (* byte-bits (1+ offset))
+                                         vector (* word-bits
+                                                   vector-data-offset)
+                                         (* length byte-bits))
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (c::read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (c::read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+(defmacro break-cases (breaknum &body cases)
+  (let ((bn-temp (gensym)))
+    (collect ((clauses))
+      (dolist (case cases)
+        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+      `(let ((,bn-temp ,breaknum))
+         (cond ,@(clauses))))))
+
+(defun break-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (disassem:note x dstate))))
+    (case (byte-imm-code chunk dstate)
+      (#.vm:error-trap
+       (nt "Error trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:cerror-trap
+       (nt "Cerror trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:breakpoint-trap
+       (nt "Breakpoint trap"))
+      (#.vm:pending-interrupt-trap
+       (nt "Pending interrupt trap"))
+      (#.vm:halt-trap
+       (nt "Halt trap"))
+      (#.vm:function-end-breakpoint-trap
+       (nt "Function end breakpoint trap"))
+    )))
+
+(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)))
+
+;; read-time-stamp instruction, that counts executed cycles, present
+;; from Pentium onwards
+(define-instruction rdtsc (segment)
+  (:printer two-bytes ((op '(#x0f #x31))))
+  (:emitter
+   (emit-byte segment #x0f)
+   (emit-byte segment #x31)))
+
+(define-instruction cpuid (segment)
+  (:printer two-bytes ((op '(#x0f #xa2))))
+  (:emitter
+   (emit-byte segment #x0f)
+   (emit-byte segment #xa2)))
+
+
+;;;; 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)))
+
+
+
+;;;; Random 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)))
+
+(define-instruction qword (segment qword)
+  (:emitter
+   (emit-qword segment qword)))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 8
+   #'(lambda (segment posn)
+       (emit-qword segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
+
+;;; ----------------------------------------------------------------
+;;; added by jrd.  fp instructions
+;;;
+
+;;;
+;;; 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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fadd)
+  (:emitter
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'faddp)
+  (:emitter
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fsub)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fsubp)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fsubr)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fsubrp)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fmul)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fdiv)
+  (:emitter 
+   (assert (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)))
+	    '(:name :tab fp-reg ", " '|ST(0)|)
+	    :print-name 'fdivr)
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b110)))
+
+;;;
+;;; exchange fr0 with fr(n).  no double 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))
+      (lisp: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)))
+;;;
+;;; Free fp register and pop the stack.
+;;;
+(define-instruction ffreep (segment dest)
+  (:printer floating-point-fp ((op '(#b111 #b000))))
+  (:emitter 
+   (emit-byte segment #b11011111)
+   (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)))
+;;;
+;;; Retore 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)))
+
+;;;
+;;; Compare ST(i) to ST0 and update the flags.
+;;;
+;;; Intel syntax: FCOMI ST, ST(i)
+;;;
+(define-instruction fcomi (segment src)
+  (:printer floating-point-fp ((op '(#b011 #b110))))
+  (:emitter
+   (assert (fp-reg-tn-p src))
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment src #b110)))
+
+;;;
+;;; Unordered comparison
+;;;
+(define-instruction fucom (segment src)
+  (:printer floating-point-fp ((op '(#b101 #b100))))
+  (:emitter
+   (assert (fp-reg-tn-p src))
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+;;;
+;;; Unordered compare ST(i) to ST0 and update the flags.
+;;;
+;;; Intel syntax: FUCOMI ST, ST(i)
+;;;
+(define-instruction fucomi (segment src)
+  (:printer floating-point-fp ((op '(#b011 #b101))))
+  (:emitter
+   (assert (fp-reg-tn-p src))
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment src #b101)))
+
+(define-instruction ftst (segment)
+  (:printer floating-point-no ((op #b00100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100100)))
+
+;;; Compare and move ST(i) to ST0.
+;;;
+;;; Intel syntal: FCMOVcc ST, ST(i)
+;;;
+(define-instruction fcmov (segment cond src)
+  #+nil (:printer floating-point ((op '(#b01? #b???))))
+  (:emitter
+   (assert (fp-reg-tn-p src))
+   (emit-byte segment (ecase cond
+			((:b :e :be :u) #b11011010)
+			((:nb :ne :nbe :nu) #b11011011)))
+   (emit-fp-op segment src (ecase cond
+			     ((:b :nb) #b000)
+			     ((:e :ne) #b000)
+			     ((:be :nbe) #b000)
+			     ((:u nu) #b000)))))
+
+;;;
+;;; 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)))
+
+;;; load constant
+
+(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/compiler/amd64/macros.lisp b/compiler/amd64/macros.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1e4d7f331524dc61887aafbcc3246e522a0f640c
--- /dev/null
+++ b/compiler/amd64/macros.lisp
@@ -0,0 +1,553 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/macros.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the a bunch of handy macros for the amd64.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999.
+;;;
+(in-package :amd64)
+
+
+;;; We can load/store into fp registers through the top of
+;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
+;;; which then changes all the reg numbers. These macros help manage that.
+
+;;; Use this when don't have to load anything. It preserves old tos value
+;;; But probably destroys tn with operation.
+(defmacro with-tn@fp-top((tn) &body body)
+  `(progn
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))
+    ,@body
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))))
+
+;;; Use this to prepare for load of new value from memory. This
+;;; changes the register numbering so the next instruction had better
+;;; be a FP load from memory; a register load from another register
+;;; will probably be loading the wrong register!
+(defmacro with-empty-tn@fp-top((tn) &body body)
+  `(progn
+    (inst fstp ,tn)
+    ,@body
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))))		; save into new dest and restore st(0)
+
+
+;;; Instruction-like macros.
+(defmacro move (dst src)
+  "Move SRC into DST unless they are location=."
+  (once-only ((n-dst dst)
+	      (n-src src))
+    `(unless (location= ,n-dst ,n-src)
+       (inst mov ,n-dst ,n-src))))
+
+(defmacro make-ea-for-object-slot (ptr slot lowtag)
+  `(make-ea :qword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag)))
+
+(defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
+  `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro storew (value ptr &optional (slot 0) (lowtag 0))
+  (once-only ((value value))
+    `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
+
+(defmacro pushw (ptr &optional (slot 0) (lowtag 0))
+  `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro popw (ptr &optional (slot 0) (lowtag 0))
+  `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+
+;;;; Macros to generate useful values.
+
+(defmacro load-symbol (reg symbol)
+  `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
+
+(defmacro load-symbol-value (reg symbol)
+  `(if (= (tn-offset ,reg) rax-offset)
+    ;; only rax can do this in one instruction
+    (inst mov ,reg
+     (make-ea :qword
+      :disp (+ nil-value
+	       (static-symbol-offset ',symbol)
+	       (ash symbol-value-slot word-shift)
+	       (- other-pointer-type))))
+    (progn
+      ;; other registers need 2 instructions
+      (inst mov ,reg
+	    (+ nil-value
+	       (static-symbol-offset ',symbol)
+	       (ash symbol-value-slot word-shift)
+	       (- other-pointer-type)))
+      (inst mov ,reg (make-ea :qword :base ,reg)))))
+      
+
+(defmacro store-symbol-value (reg symbol &optional temp) ; temp is unnecessary for rax
+  `(if (or (= (tn-offset ,reg) rax-offset) (not ,temp))
+    ;; only rax can do this in one instruction
+    (inst mov
+     (make-ea :qword
+      :disp (+ nil-value
+	       (static-symbol-offset ',symbol)
+	       (ash symbol-value-slot word-shift)
+	       (- other-pointer-type)))
+     ,reg)
+    (progn
+      ;; other registers need 2 instructions
+      (inst mov ,temp
+	    (+ nil-value
+	       (static-symbol-offset ',symbol)
+	       (ash symbol-value-slot word-shift)
+	       (- other-pointer-type)))
+      (inst mov (make-ea :qword :base ,temp) ,reg))))
+      
+
+(defun symbol-value-address (symbol)
+  (+ nil-value
+     (static-symbol-offset symbol)
+     (ash symbol-value-slot word-shift)
+     (- other-pointer-type)))
+
+(defmacro load-type (target source &optional (offset 0))
+  "Loads the type bits of a pointer into target independent of
+   byte-ordering issues."
+  (once-only ((n-target target)
+	      (n-source source)
+	      (n-offset offset))
+    (ecase (backend-byte-order *target-backend*)
+      (:little-endian
+       `(inst mov ,n-target
+	      (make-ea :byte :base ,n-source :disp ,n-offset)))
+      (:big-endian
+       `(inst mov ,n-target
+	      (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
+
+(defmacro load-foreign-data-symbol (reg name )
+  #+linkage-table `(inst mov ,reg (make-fixup (extern-alien-name ,name)
+					      :foreign-data))
+  #-linkage-table `(inst lea ,reg (make-fixup (extern-alien-name ,name)
+					      :foreign)))
+
+;; the right one to use
+(defmacro load-foreign-data-symbol2 (reg name temp)
+  #+linkage-table `(progn
+		    (inst mov-imm ,temp (make-fixup (extern-alien-name ,name)
+					 :foreign-data))
+		    (inst mov ,reg (make-ea :qword :base ,temp)))
+  #-linkage-table `(inst lea ,reg (make-fixup (extern-alien-name ,name)
+					      :foreign))
+  )
+
+;;;; Allocation helpers
+
+;;; Two allocation approaches are implemented. A call into C can be
+;;; used where special care can be taken to disable
+;;; interrupts. Alternatively with gencgc inline allocation is possible
+;;; although it isn't interrupt safe.
+
+;;; For GENCGC it is possible to inline object allocation, to permit
+;;; this set the following variable to True.
+(defparameter *maybe-use-inline-allocation* t)
+
+(defun load-size (alloc-tn dst-tn size)
+  (unless (and (tn-p size) (location= alloc-tn size))
+    (inst mov dst-tn size)))
+
+(defun inline-allocation (alloc-tn size temp-tn)
+  (let ((ok (gen-label)))
+    ;;
+    ;; Load the size first so that the size can be in the same
+    ;; register as alloc-tn.
+    (load-size alloc-tn alloc-tn size)
+    ;;
+    (inst mov temp-tn (symbol-value-address '*current-region-free-pointer*))
+    (inst add alloc-tn (make-ea :qword :base temp-tn))
+    (inst mov temp-tn (symbol-value-address '*current-region-end-addr*))
+    (inst cmp alloc-tn (make-ea :qword :base temp-tn))
+    (inst jmp :be OK)
+    ;;
+    ;; Dispatch to the appropriate overflow routine. There is a
+    ;; routine for each destination.
+    (inst mov-imm temp-tn
+	  (make-fixup (extern-alien-name
+		       (ecase (tn-offset alloc-tn)
+			 (#.rax-offset "alloc_overflow_rax")
+			 (#.rcx-offset "alloc_overflow_rcx")
+			 (#.rdx-offset "alloc_overflow_rdx")
+			 (#.rbx-offset "alloc_overflow_rbx")
+			 (#.rsi-offset "alloc_overflow_rsi")
+			 (#.rdi-offset "alloc_overflow_rdi")))
+		      :foreign))
+    (inst call temp-tn)
+    (emit-label ok)
+    (inst mov temp-tn (symbol-value-address '*current-region-free-pointer*))
+    (inst xchg (make-ea :qword :base temp-tn) alloc-tn))
+  (values))
+
+(defun not-inline-allocation (alloc-tn size temp-tn)
+  ;; C call to allocate via dispatch routines. Each destination has a
+  ;; special entry point. The size may be a register or a constant.
+  ;; This is used only if space is more important than speed.
+  (ecase (tn-offset alloc-tn)
+    (#.rax-offset
+     (load-size alloc-tn rax-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rax")
+				       :foreign)))
+    (#.rcx-offset
+     (load-size alloc-tn rcx-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rcx")
+				       :foreign)))
+    (#.rdx-offset
+     (load-size alloc-tn rdx-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rdx")
+				       :foreign)))
+    (#.rbx-offset
+     (load-size alloc-tn rbx-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rbx")
+				       :foreign)))
+    (#.rsi-offset
+     (load-size alloc-tn rsi-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rsi")
+				       :foreign)))
+    (#.rdi-offset
+     (load-size alloc-tn rdi-tn size)
+     (inst mov-imm temp-tn (make-fixup (extern-alien-name "alloc_to_rdi")
+				       :foreign))))
+  (inst call temp-tn)
+  (values))
+
+;;;
+;;; Allocate SIZE bytes from the stack, storing a pointer to the
+;;; allocated memory in ALLOC-TN.
+;;;
+(defun dynamic-extent-allocation (alloc-tn nbytes)
+  (inst sub rsp-tn nbytes)
+  (inst and rsp-tn #xfffffffffffffff0) ; alignment
+  (inst mov alloc-tn rsp-tn)
+  (values))
+
+(defun allocation (alloc-tn size temp-tn &optional inline dynamic-extent)
+  "Allocate an object with a size in bytes given by Size.
+   The size may be an integer or a TN.
+   If Inline is a VOP node-var then it is used to make an appropriate
+   speed vs size decision.  If Dynamic-Extent is true, and otherwise
+   appropriate, allocate from the stack."
+  (cond (dynamic-extent
+	 (dynamic-extent-allocation alloc-tn size))
+	((and *maybe-use-inline-allocation*
+	      (or (null inline)
+		  (policy inline (>= speed space)))
+	      (backend-featurep :gencgc))
+	 (inline-allocation alloc-tn size temp-tn))
+	(t
+	 (not-inline-allocation alloc-tn size temp-tn)))
+  (values))
+
+(defmacro with-fixed-allocation ((result-tn type-code size temp-tn &optional inline)
+				 &rest forms)
+  "Allocate an other-pointer object of fixed Size with a single
+   word header having the specified Type-Code.  The result is placed in
+   Result-TN."
+  `(pseudo-atomic
+    (allocation ,result-tn (pad-data-block ,size) ,temp-tn ,inline)
+    (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,result-tn)
+    (inst lea ,result-tn
+     (make-ea :byte :base ,result-tn :disp other-pointer-type))
+    ,@forms))
+
+
+;;;; Error Code
+
+(eval-when (compile load eval)
+  (defun emit-error-break (vop kind code values)
+    (let ((vector (gensym))
+	  (length (gensym)))
+      `((inst int 3)				; i386 breakpoint instruction
+	;; The return PC points here; note the location for the debugger.
+	(let ((vop ,vop))
+  	  (when vop
+		(note-this-location vop :internal-error)))
+	(inst byte ,kind)			; eg trap_Xyyy
+	(let ((,vector (make-array 8 :element-type '(unsigned-byte 8)
+				   :fill-pointer 0 :adjustable t)))
+	  (write-var-integer (error-number-or-lose ',code) ,vector)
+	  ,@(mapcar #'(lambda (tn)
+			`(let ((tn ,tn))
+			   (write-var-integer
+			    (make-sc-offset (sc-number (tn-sc tn))
+			     ;; tn-offset is zero for constant tns.
+			     (or (tn-offset tn) 0))
+			    ,vector)))
+		    values)
+	  (let ((,length (length ,vector)))
+	    (inst byte ,length)
+	    (dotimes (i ,length)
+	      (inst byte (aref ,vector i)))))))))
+
+(defmacro error-call (vop error-code &rest values)
+  "Cause an error.  ERROR-CODE is the error to cause."
+  (cons 'progn
+	(emit-error-break vop error-trap error-code values)))
+
+
+(defmacro cerror-call (vop label error-code &rest values)
+  "Cause a continuable error.  If the error is continued, execution resumes at
+  LABEL."
+  `(progn
+     ,@(emit-error-break vop cerror-trap error-code values)
+     (inst jmp ,label)))
+
+(defmacro generate-error-code (vop error-code &rest values)
+  "Generate-Error-Code Error-code Value*
+  Emit code for an error with the specified Error-Code and context Values."
+  `(assemble (*elsewhere*)
+     (let ((start-lab (gen-label)))
+       (emit-label start-lab)
+       (error-call ,vop ,error-code ,@values)
+       start-lab)))
+
+(defmacro generate-cerror-code (vop error-code &rest values)
+  "Generate-CError-Code Error-code Value*
+  Emit code for a continuable error with the specified Error-Code and
+  context Values.  If the error is continued, execution resumes after
+  the GENERATE-CERROR-CODE form."
+  (let ((continue (gensym "CONTINUE-LABEL-"))
+	(error (gensym "ERROR-LABEL-")))
+    `(let ((,continue (gen-label))
+	   (,error (gen-label)))
+       (emit-label ,continue)
+       (assemble (*elsewhere*)
+	 (emit-label ,error)
+	 (cerror-call ,vop ,continue ,error-code ,@values))
+       ,error)))
+
+
+
+;;;; PSEUDO-ATOMIC.
+
+(defparameter *enable-pseudo-atomic* nil) ; remember to turn this back on
+
+;;; PSEUDO-ATOMIC -- Internal Interface.
+;;;
+(defmacro pseudo-atomic (&rest forms)
+  (let ((label (gensym "LABEL-")))
+    `(let ((,label (gen-label)))
+      (when *enable-pseudo-atomic*
+	(inst mov (make-ea :byte :disp (+ nil-value
+					  (static-symbol-offset
+					   'lisp::*pseudo-atomic-interrupted*)
+					  (ash symbol-value-slot word-shift)
+					  (- other-pointer-type)))
+	      0)
+	(inst mov (make-ea :byte :disp (+ nil-value
+					  (static-symbol-offset
+					   'lisp::*pseudo-atomic-atomic*)
+					  (ash symbol-value-slot word-shift)
+					  (- other-pointer-type)))
+	      (fixnumize 1)))
+      ,@forms
+      (when *enable-pseudo-atomic*
+	(inst mov (make-ea :byte :disp (+ nil-value
+					  (static-symbol-offset
+					   'lisp::*pseudo-atomic-atomic*)
+					  (ash symbol-value-slot word-shift)
+					  (- other-pointer-type)))
+	      0)
+	(inst cmp (make-ea :byte
+			   :disp (+ nil-value
+				    (static-symbol-offset
+				     'lisp::*pseudo-atomic-interrupted*)
+				    (ash symbol-value-slot word-shift)
+				    (- other-pointer-type)))
+	      0)
+	(inst jmp :eq ,label)
+	(inst break pending-interrupt-trap)
+	(emit-label ,label)))))
+
+
+;;;; Indexed references:
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg)))
+       (:arg-types ,type tagged-num)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; pw was 5
+	 (inst mov value (make-ea :qword :base object :index index :scale 2
+				  :disp (- (* ,offset word-bytes) ,lowtag)))))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2			; pw was 5
+	 (inst mov value (make-ea :qword :base object
+				  :disp (- (* (+ ,offset index) word-bytes)
+					   ,lowtag)))))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4			; was 5
+	 (inst mov (make-ea :qword :base object :index index :scale 2
+			    :disp (- (* ,offset word-bytes) ,lowtag))
+	       value)
+	 (move result value)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs :target result))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; was 5
+	 (inst mov (make-ea :qword :base object
+			    :disp (- (* (+ ,offset index) word-bytes) ,lowtag))
+	       value)
+	 (move result value)))))
+
+(defmacro define-half-reffer (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg)))
+       (:arg-types ,type tagged-num)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; pw was 5
+	;; high 32 bits of doubleword operands are zero
+	;; extended to 64 bits
+	 (inst mov (64-bit-to-32-bit-tn value)
+	       (make-ea :dword :base object :index index
+				  :disp (- (* ,offset word-bytes) ,lowtag)))))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2			; pw was 5
+	 (inst mov (64-bit-to-32-bit-tn value)
+	       (make-ea :dword :base object
+				  :disp (- (+ (* ,offset word-bytes) (* index 4))
+					   ,lowtag)))))))
+
+(defmacro define-half-setter (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4			; was 5
+	 (inst mov (make-ea :dword :base object :index index
+			    :disp (- (* ,offset word-bytes) ,lowtag))
+	       (64-bit-to-32-bit-tn value))
+	 (move result value)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs :target result))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; was 5
+	 (inst mov (make-ea :dword :base object
+			    :disp (- (+ (* index 4) (* ,offset word-bytes)) ,lowtag))
+	       (64-bit-to-32-bit-tn value))
+	 (move result value)))))
+
+(defmacro define-full-conditional-setter (name type offset lowtag scs el-type
+					  &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to :result)
+	      (index :scs (any-reg) :to :result)
+	      (old-value :scs ,scs :target rax)
+	      (new-value :scs ,scs))
+       (:arg-types ,type tagged-num ,el-type ,el-type)
+       (:temporary (:sc ,(first scs) :offset rax-offset
+		    :from (:argument 2) :to :result :target result) rax)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:guard (backend-featurep :i486))
+       (:generator 5
+	 (move rax old-value)
+	 (inst cmpxchg (make-ea :qword :base object :index index :scale 1
+				:disp (- (* ,offset word-bytes) ,lowtag))
+	       new-value)
+	 (move result rax)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to :result)
+	      (old-value :scs ,scs :target rax)
+	      (new-value :scs ,scs))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)) ,el-type ,el-type)
+       (:temporary (:sc ,(first scs) :offset rax-offset
+		    :from (:argument 1) :to :result :target result)  rax)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:guard (backend-featurep :i486))
+       (:generator 4
+	 (move rax old-value)
+	 (inst cmpxchg (make-ea :qword :base object
+				:disp (- (* (+ ,offset index) word-bytes)
+					 ,lowtag))
+	       new-value)
+	 (move result rax)))))
diff --git a/compiler/amd64/memory.lisp b/compiler/amd64/memory.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0556cf485a7bb2f5cd8803679caa806a2909dd5c
--- /dev/null
+++ b/compiler/amd64/memory.lisp
@@ -0,0 +1,185 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/memory.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the x86 definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999.
+;;; 
+
+(in-package :amd64)
+
+;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
+;;; be read or written is a property of the VOP used.  Cell-Setf is similar to
+;;; Cell-Set, but delivers the new value as the result.  Cell-Setf-Function
+;;; takes its arguments as if it were a setf function (new value first, as
+;;; apposed to a setf macro, which takes the new value last).
+;;;
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (loadw value object offset lowtag)))
+;;;
+(define-vop (cell-set)
+  (:args (object :scs (descriptor-reg))
+         (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)))
+;;;
+(define-vop (cell-setf)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg) :target result))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+;;;
+(define-vop (cell-setf-function)
+  (:args (value :scs (descriptor-reg any-reg) :target result)
+	 (object :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+
+;;; Define-Cell-Accessors  --  Interface
+;;;
+;;;    Define accessor VOPs for some cells in an object.  If the operation name
+;;; is NIL, then that operation isn't defined.  If the translate function is
+;;; null, then we don't define a translation.
+;;;
+(defmacro define-cell-accessors (offset lowtag
+					ref-op ref-trans set-op set-trans)
+  `(progn
+     ,@(when ref-op
+	 `((define-vop (,ref-op cell-ref)
+	     (:variant ,offset ,lowtag)
+	     ,@(when ref-trans
+		 `((:translate ,ref-trans))))))
+     ,@(when set-op
+	 `((define-vop (,set-op cell-setf)
+	     (:variant ,offset ,lowtag)
+	     ,@(when set-trans
+		 `((:translate ,set-trans))))))))
+
+(define-vop (cell-set-conditional)
+  (:args (object :scs (descriptor-reg) :to :eval)
+	 (old-value :scs (descriptor-reg any-reg) :target rax)
+	 (new-value :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+		   :from (:argument 1) :to :result :target result)  rax)
+  (:variant-vars offset lowtag)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:guard (backend-featurep :i486))
+  (:generator 4
+    (move rax old-value)
+    (inst cmpxchg (make-ea :qword :base object
+			   :disp (- (* offset word-bytes) lowtag))
+	  new-value)
+    (move result rax)))
+
+;;; X86 special
+(define-vop (cell-xadd)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (any-reg) :target result))
+  (:results (result :scs (any-reg) :from (:argument 1)))
+  (:result-types tagged-num)
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (move result value)
+    (inst xadd (make-ea :qword :base object
+			:disp (- (* offset word-bytes) lowtag))
+	  value)))
+
+;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
+;;; offset is constant at compile time, but varies for different uses.
+;;;
+(define-vop (slot-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (loadw value object (+ base offset) lowtag)))
+;;;
+(define-vop (slot-set)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg immediate)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+     (if (sc-is value immediate)
+	 (let ((val (tn-value value)))
+           (etypecase val
+	     (integer
+	      (inst mov
+		    (make-ea :qword :base object
+			     :disp (- (* (+ base offset) word-bytes) lowtag))
+		    (fixnumize val)))
+	     (symbol
+	      (inst mov
+		    (make-ea :qword :base object
+			     :disp (- (* (+ base offset) word-bytes) lowtag))
+		    (+ nil-value (static-symbol-offset val))))
+	     (character
+	      (inst mov
+		    (make-ea :qword :base object
+			     :disp (- (* (+ base offset) word-bytes) lowtag))
+		    (logior (ash (char-code val) type-bits)
+			    base-char-type)))))
+	 ;; Else, value not immediate.
+	 (storew value object (+ base offset) lowtag))))
+
+(define-vop (slot-set-conditional)
+  (:args (object :scs (descriptor-reg) :to :eval)
+	 (old-value :scs (descriptor-reg any-reg) :target rax)
+	 (new-value :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+		   :from (:argument 1) :to :result :target result)  rax)
+  (:variant-vars base lowtag)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:info offset)
+  (:guard (backend-featurep :i486))
+  (:generator 4
+    (move rax old-value)
+    (inst cmpxchg (make-ea :qword :base object
+			   :disp (- (* (+ base offset) word-bytes) lowtag))
+	  new-value)
+    (move result rax)))
+
+;;; X86 special
+(define-vop (slot-xadd)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (any-reg) :target result))
+  (:results (result :scs (any-reg) :from (:argument 1)))
+  (:result-types tagged-num)
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (move result value)
+    (inst xadd (make-ea :qword :base object
+			:disp (- (* (+ base offset) word-bytes) lowtag))
+	  value)))
diff --git a/compiler/amd64/move.lisp b/compiler/amd64/move.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6a6a678d127c1a81ff0a395580630a0f43c4390f
--- /dev/null
+++ b/compiler/amd64/move.lisp
@@ -0,0 +1,439 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/move.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the AMD64 VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;;
+(in-package :amd64)
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((immediate)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (if (zerop val)
+	   (inst xor y y)
+	 (inst mov y (fixnumize val))))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst mov y (logior (ash (char-code val) type-bits)
+			   base-char-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((immediate) (signed-reg unsigned-reg))
+  (inst mov y (tn-value x)))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst mov y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst mov y (sap-int (tn-value x))))
+
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg any-reg))
+  (inst mov y x))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((control-stack) (any-reg descriptor-reg)
+   (base-char-stack) (base-char-reg)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (inst mov y x))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((any-reg descriptor-reg) (control-stack)
+   (base-char-reg) (base-char-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (inst mov y x))
+
+
+;;;; The Move VOP:
+;;;
+(define-vop (move)
+  (:args (x :scs (any-reg descriptor-reg immediate) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg)
+	       :load-if
+	       (not (or (location= x y)
+			(and (sc-is x any-reg descriptor-reg immediate)
+			     (sc-is y control-stack))))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (if (and (sc-is x immediate)
+	     (sc-is y any-reg descriptor-reg control-stack))
+	(let ((val (tn-value x)))
+	  (etypecase val
+	    (integer
+	     (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+		 (inst xor y y)
+	       (inst mov y (fixnumize val))))
+	    (symbol
+	     (inst mov y (+ nil-value (static-symbol-offset val))))
+	    (character
+	     (inst mov y (logior (ash (char-code val) type-bits)
+				 base-char-type)))))
+      (move y x))))
+
+(define-move-vop move :move
+  (any-reg descriptor-reg immediate)
+  (any-reg descriptor-reg))
+
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type.  This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;;    The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+;;; Note: It is not going to be possible to move a constant directly
+;;; to another frame, except if the destination is a register and in
+;;; this case the loading works out.
+(define-vop (move-argument)
+  (:args (x :scs (any-reg descriptor-reg immediate) :target y
+	    :load-if (not (and (sc-is y any-reg descriptor-reg)
+			       (sc-is x control-stack))))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (if (sc-is x immediate)
+	   (let ((val (tn-value x)))
+	     (etypecase val
+	      (integer
+	       (if (zerop val)
+		   (inst xor y y)
+		 (inst mov y (fixnumize val))))
+	      (symbol
+	       (load-symbol y val))
+	      (character
+	       (inst mov y (logior (ash (char-code val) type-bits)
+				   base-char-type)))))
+	 (move y x)))
+      ((control-stack)
+       (if (sc-is x immediate)
+	   (let ((val (tn-value x)))
+	     (if (= (tn-offset fp) rsp-offset)
+		 ;; C-call
+		 (etypecase val
+	           (integer
+		    (storew (fixnumize val) fp (tn-offset y)))
+		   (symbol
+		    (storew (+ nil-value (static-symbol-offset val))
+			    fp (tn-offset y)))
+		   (character
+		    (storew (logior (ash (char-code val) type-bits)
+				    base-char-type)
+			    fp (tn-offset y))))
+	       ;; Lisp stack
+	       (etypecase val
+		 (integer
+		  (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+		 (symbol
+		  (storew (+ nil-value (static-symbol-offset val))
+			  fp (- (1+ (tn-offset y)))))
+		 (character
+		  (storew (logior (ash (char-code val) type-bits)
+				  base-char-type)
+			  fp (- (1+ (tn-offset y))))))))
+	 (if (= (tn-offset fp) rsp-offset)
+	     ;; C-call
+	     (storew x fp (tn-offset y))
+	   ;; Lisp stack
+	   (storew x fp (- (1+ (tn-offset y))))))))))
+
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
+
+
+
+;;;; ILLEGAL-MOVE
+
+;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
+;;; legally due to a type error.  An error is signalled before this VOP is
+;;; so we don't need to do anything (not that there would be anything sensible
+;;; to do anyway.)
+;;;
+(define-vop (illegal-move)
+  (:args (x) (type))
+  (:results (y))
+  (:ignore y)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 666
+    (error-call vop object-not-type-error x type)))
+
+
+
+;;;; Moves and coercions:
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
+;;; to a tagged bignum or fixnum.
+
+;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
+;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
+;;;
+(define-vop (move-to-word/fixnum)
+  (:args (x :scs (any-reg descriptor-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed-reg unsigned-reg)
+	       :load-if (not (location= x y))))
+  (:arg-types tagged-num)
+  (:note "fixnum untagging")
+  (:generator 1
+    (move y x)
+    (inst sar y 2)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+  (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-word-c)
+  (:args (x :scs (constant)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "constant load")
+  (:generator 1
+    (inst mov y (tn-value x))))
+;;;
+(define-move-vop move-to-word-c :move
+  (constant) (signed-reg unsigned-reg))
+
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg) :target rax))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "integer to untagged word coercion")
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from (:argument 0) :to (:result 0) :target y) rax)
+  (:generator 4
+    (move rax x)
+    (inst test al-tn 3)
+    (inst jmp :z fixnum)
+    (loadw y rax bignum-digits-offset other-pointer-type)
+    (inst jmp done)
+    FIXNUM
+    (inst sar rax 2)
+    (move y rax)
+    DONE))
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; Result is a fixnum, so we can just shift.  We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+;;;
+(define-vop (move-from-word/fixnum)
+  (:args (x :scs (signed-reg unsigned-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg)
+	       :load-if (not (location= x y))))
+  (:result-types tagged-num)
+  (:note "fixnum tagging")
+  (:generator 1
+    (cond ((and (sc-is x signed-reg unsigned-reg)
+		(not (location= x y)))
+	   ;; Uses 7 bytes, but faster on the Pentium
+	   (inst lea y (make-ea :qword :index x :scale 4)))
+	  (t
+	   ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
+	   (move y x)
+	   (inst shl y 2)))))
+;;;
+(define-move-vop move-from-word/fixnum :move
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
+;;; sure people know they may be number consing.
+;;;
+#+nil
+(define-vop (move-from-signed)
+  (:args (x :scs (signed-reg unsigned-reg) :target rax))
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rbx-offset :to (:result 0) :target y)
+	      rbx)
+  (:temporary (:sc unsigned-reg :offset rcx-offset
+		   :from (:argument 0) :to (:result 0)) rcx)
+  (:ignore rcx)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "signed word to integer coercion")
+  (:generator 20
+    (move rax x)
+    (inst call (make-fixup 'move-from-signed :assembly-routine))
+    (move y rbx)))
+;;;
+;;; Faster inline version,
+(define-vop (move-from-signed)
+  (:args (x :scs (signed-reg unsigned-reg) :to :result))
+  (:results (y :scs (any-reg descriptor-reg) :from :argument))
+  (:temporary (:sc any-reg) temp)
+  (:note "signed word to integer coercion")
+  (:node-var node)
+  (:generator 20
+     (assert (not (location= x y)))
+     (let ((bignum (gen-label))
+	   (done (gen-label)))
+       (inst mov y x)
+       (inst shl y 1)
+       (inst jmp :o bignum)
+       (inst shl y 1)
+       (inst jmp :o bignum)
+       (emit-label done)
+
+       (assemble (*elsewhere*)
+          (emit-label bignum)
+	  (with-fixed-allocation
+	      (y bignum-type (+ bignum-digits-offset 1) temp node)
+	    (storew x y bignum-digits-offset other-pointer-type))
+	  (inst jmp done)))))
+;;;
+(define-move-vop move-from-signed :move
+  (signed-reg) (descriptor-reg))
+
+
+;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
+;;; a worst-case cost to make sure people know they may be number consing.
+;;;
+#+nil
+(define-vop (move-from-unsigned)
+  (:args (x :scs (signed-reg unsigned-reg) :target rax))
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax)
+  (:temporary (:sc unsigned-reg :offset rbx-offset :to (:result 0) :target y)
+	      rbx)
+  (:temporary (:sc unsigned-reg :offset rcx-offset
+		   :from (:argument 0) :to (:result 0)) rcx)
+  (:ignore rcx)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (move rax x)
+    (inst call (make-fixup 'move-from-unsigned :assembly-routine))
+    (move y rbx)))
+;;;
+;;; Faster inline version.
+(define-vop (move-from-unsigned)
+  (:args (x :scs (signed-reg unsigned-reg) :to :save))
+  (:temporary (:sc unsigned-reg) alloc)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:node-var node)
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (assert (not (location= x y)))
+    (assert (not (location= x alloc)))
+    (assert (not (location= y alloc)))
+    (let ((bignum (gen-label))
+	  (done (gen-label))
+	  (one-word-bignum (gen-label))
+	  (l1 (gen-label)))
+      (inst mov alloc #xe000000000000000) ; 111000.....
+      (inst test x alloc)
+      (inst jmp :nz bignum)
+      ;; Fixnum.
+      (inst lea y (make-ea :qword :index x :scale 4)) ; Faster but bigger.
+      (emit-label done)
+
+      (assemble (*elsewhere*)
+         (emit-label bignum)
+	 ;; Note: As on the mips port, space for a two word bignum is
+	 ;; always allocated and the header size is set to either one
+	 ;; or two words as appropriate.
+	 (inst jmp :ns one-word-bignum)
+	 ;; Two word bignum.
+	 (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) vm:type-bits)
+			     bignum-type))
+	 (inst jmp l1)
+	 (emit-label one-word-bignum)
+	 (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits)
+			     bignum-type))
+	 (emit-label l1)
+	 (pseudo-atomic
+	  ;; We don't have enough registers. So I'm using y here
+	  ;; We can fix it when we use r8-r15
+	  (inst push y)
+	  (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) y node)
+	  (inst pop y)
+	  (storew y alloc)
+	  (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
+	  (storew x y bignum-digits-offset other-pointer-type))
+	 (inst jmp done)))))
+;;;
+(define-move-vop move-from-unsigned :move
+  (unsigned-reg) (descriptor-reg))
+
+
+;;; Move untagged numbers.
+;;;
+(define-vop (word-move)
+  (:args (x :scs (signed-reg unsigned-reg) :target y
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed-reg unsigned-reg)
+	       :load-if
+	       (not (or (location= x y)
+			(and (sc-is x signed-reg unsigned-reg)
+			     (sc-is y signed-stack unsigned-stack))))))
+  (:effects)
+  (:affected)
+  (:note "word integer move")
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop word-move :move
+  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+  (:args (x :scs (signed-reg unsigned-reg) :target y)
+	 (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed-reg unsigned-reg)
+       (move y x))
+      ((signed-stack unsigned-stack)
+       (if (= (tn-offset fp) rsp-offset)
+	   (storew x fp (tn-offset y))	; c-call
+	   (storew x fp (- (1+ (tn-offset y)))))))))
+
+;;;
+(define-move-vop move-word-argument :move-argument
+  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/amd64/nlx.lisp b/compiler/amd64/nlx.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..42cd5c7acf9e173063142bb9dd0c995304d69225
--- /dev/null
+++ b/compiler/amd64/nlx.lisp
@@ -0,0 +1,264 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/nlx.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of non-local exit for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998.
+;;;
+(in-package :amd64)
+
+;;; MAKE-NLX-SP-TN  --  Interface
+;;;
+;;;    Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(def-vm-support-routine make-nlx-sp-tn (env)
+  (environment-live-tn
+   (make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
+   env))
+
+;;; Make-NLX-Entry-Argument-Start-Location  --  Interface
+;;;
+;;;    Make a TN for the argument count passing location for a
+;;; non-local entry.
+;;;
+(def-vm-support-routine make-nlx-entry-argument-start-location ()
+  (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rbx-offset))
+
+(defun catch-block-ea (tn)
+  (assert (sc-is tn catch-block))
+  (make-ea :qword :base rbp-tn
+	   :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes))))
+
+
+;;; Save and restore dynamic environment.
+;;;
+;;;    These VOPs are used in the reentered function to restore the
+;;; appropriate dynamic environment.  Currently we only save the
+;;; Current-Catch, the eval stack pointer, and the alien stack
+;;; pointer.
+;;;
+;;; We don't need to save/restore the current unwind-protect, since
+;;; unwind-protects are implicitly processed during unwinding.
+;;;
+;;; We don't need to save the BSP, because that is handled automatically.
+
+;;; Make-Dynamic-State-TNs  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(def-vm-support-routine make-dynamic-state-tns ()
+  (make-n-tns 3 *any-primitive-type*))
+
+(define-vop (save-dynamic-state)
+  (:results (catch :scs (descriptor-reg))
+	    (eval :scs (descriptor-reg))
+	    (alien-stack :scs (descriptor-reg)))
+  (:generator 13
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (load-symbol-value eval lisp::*eval-stack-top*)
+    (load-symbol-value alien-stack *alien-stack*)))
+  
+(define-vop (restore-dynamic-state)
+  (:args (catch :scs (descriptor-reg))
+	 (eval :scs (descriptor-reg))
+	 (alien-stack :scs (descriptor-reg)))
+  (:temporary (:sc descriptor-reg) temp)
+  (:generator 10
+    (store-symbol-value catch lisp::*current-catch-block* temp)
+    (store-symbol-value eval lisp::*eval-stack-top* temp)
+    (store-symbol-value alien-stack *alien-stack* temp)))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg control-stack)))
+  (:generator 1
+    (move res rsp-tn)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (load-symbol-value res *binding-stack-pointer*)))
+
+
+;;;; Unwind block hackery:
+
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+
+(define-vop (make-unwind-block)
+  (:args (tn))
+  (:info entry-label)
+  (:temporary (:sc unsigned-reg) temp)
+  (:results (block :scs (any-reg)))
+  (:generator 22
+    (inst lea block (catch-block-ea tn))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block unwind-block-current-uwp-slot)
+    (storew rbp-tn block unwind-block-current-cont-slot)
+    (storew (make-fixup nil :code-object entry-label)
+	    block catch-block-entry-pc-slot)))
+
+;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+;;;
+
+(define-vop (make-catch-block)
+  (:args (tn)
+	 (tag :scs (descriptor-reg any-reg) :to (:result 1)))
+  (:info entry-label)
+  (:results (block :scs (any-reg)))
+  (:temporary (:sc descriptor-reg) temp)
+  (:generator 44
+    (inst lea block (catch-block-ea tn))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block  unwind-block-current-uwp-slot)
+    (storew rbp-tn block  unwind-block-current-cont-slot)
+    (storew (make-fixup nil :code-object entry-label)
+	    block catch-block-entry-pc-slot)
+    (storew tag block catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block*)
+    (storew temp block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block* temp)))
+
+;;; Just set the current unwind-protect to TN's address.  This instantiates an
+;;; unwind block as an unwind-protect.
+;;;
+(define-vop (set-unwind-protect)
+  (:args (tn))
+  (:temporary (:sc unsigned-reg) new-uwp)
+  (:generator 7
+    (inst lea new-uwp (catch-block-ea tn))
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
+
+(define-vop (unlink-catch-block)
+  (:temporary (:sc unsigned-reg) block)
+  (:policy :fast-safe)
+  (:translate %catch-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-catch-block*)
+    (loadw block block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+(define-vop (unlink-unwind-protect)
+  (:temporary (:sc unsigned-reg) block)
+  (:policy :fast-safe)
+  (:translate %unwind-protect-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-unwind-protect-block*)
+    (loadw block block unwind-block-current-uwp-slot)
+    (store-symbol-value block lisp::*current-unwind-protect-block*)))
+
+
+;;;; NLX entry VOPs:
+(define-vop (nlx-entry)
+  ;; Note: we can't list an sc-restriction, 'cause any load vops would
+  ;; be inserted before the return-pc label.
+  (:args (sp)
+	 (start)
+	 (count))
+  (:results (values :more t))
+  (:temporary (:sc descriptor-reg) move-temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (let ((no-values (gen-label)))
+	     (inst mov (tn-ref-tn values) nil-value)
+	     (inst jecxz no-values)
+	     (loadw (tn-ref-tn values) start -1)
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (do ((i 0 (1+ i))
+		  (tn-ref values (tn-ref-across tn-ref)))
+		 ((null tn-ref))
+	       (let ((default-lab (gen-label))
+		     (tn (tn-ref-tn tn-ref)))
+		 (defaults (cons default-lab tn))
+		 
+		 (inst cmp count (fixnumize i))
+		 (inst jmp :le default-lab)
+		 (sc-case tn
+		   ((descriptor-reg any-reg)
+		    (loadw tn start (- (1+ i))))
+		   ((control-stack)
+		    (loadw move-temp start (- (1+ i)))
+		    (inst mov tn move-temp)))))
+	     (let ((defaulting-done (gen-label)))
+	       (emit-label defaulting-done)
+	       (assemble (*elsewhere*)
+		 (dolist (def (defaults))
+		   (emit-label (car def))
+		   (inst mov (cdr def) nil-value))
+		 (inst jmp defaulting-done))))))
+    (inst mov rsp-tn sp)))
+
+(define-vop (nlx-entry-multiple)
+  (:args (top)
+	 (source)
+	 (count :target rcx))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 2)) rcx)
+  (:temporary (:sc unsigned-reg :offset rsi-offset) rsi)
+  (:temporary (:sc unsigned-reg :offset rdi-offset) rdi)
+  (:results (result :scs (any-reg) :from (:argument 0))
+	    (num :scs (any-reg control-stack)))
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+
+    (inst lea rsi (make-ea :qword :base source :disp (- word-bytes)))
+    ;; The 'top' arg contains the %esp value saved at the time the
+    ;; catch block was created and points to where the thrown values
+    ;; should sit.
+    (move rdi top)
+    (move result rdi)
+
+    (inst sub rdi word-bytes)
+    (move rcx count)			; fixnum words == bytes
+    (move num rcx)
+    (inst shr rcx word-shift)		; word count for <rep movs>
+    ;; If we got zero, we be done.
+    (inst jecxz done)
+    ;; Copy them down.
+    (inst std)
+    (inst rep)
+    (inst movs :qword)
+
+    DONE
+    ;; Reset the CSP at last moved arg.
+    (inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes))))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+;;;
+(define-vop (uwp-entry)
+  (:info label)
+  (:save-p :force-to-stack)
+  (:results (block) (start) (count))
+  (:ignore block start count)
+  (:vop-var vop)
+  (:generator 0
+    (emit-label label)
+    (note-this-location vop :non-local-entry)))
diff --git a/compiler/amd64/parms.lisp b/compiler/amd64/parms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..155b7bddbb5c1a7658a8387e0117ab17f0984ccb
--- /dev/null
+++ b/compiler/amd64/parms.lisp
@@ -0,0 +1,337 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/parms.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the amd64.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;;
+
+(in-package :amd64)
+(use-package :c)
+
+;;; ### Note: we simultaneously use ``word'' to mean a 64 bit quantity and
+;;; a 16 bit quantity depending on context.  This is because Intel insists
+;;; on calling 16 bit things words and 32 bit things double-words (or dwords).
+;;; Therefore, in the instruction definition and register specs, we use the
+;;; Intel convention.  But whenever we are talking about stuff the rest of
+;;; the lisp system might be interested in, we use ``word'' to mean the size
+;;; of a descriptor object, which is 64 bits.
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+(setf (backend-name *target-backend*) "AMD64")
+(setf (backend-version *target-backend*) "AMD x86-64")
+(setf (backend-fasl-file-type *target-backend*) "amd64f")
+(setf (backend-fasl-file-implementation *target-backend*)
+      amd64-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) #x18e)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :little-endian)
+
+;;;#+cross-compiler
+;;;(setf (backend-package *target-backend*) :python-x86)
+
+(setf (backend-page-size *target-backend*) 4096)
+); eval-when
+
+
+;;;; Machine Architecture parameters:
+
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+
+	  single-float-bias single-float-exponent-byte
+	  single-float-significand-byte single-float-normal-exponent-min
+	  single-float-normal-exponent-max single-float-hidden-bit
+	  single-float-trapping-nan-bit single-float-digits
+
+	  double-float-bias double-float-exponent-byte
+	  double-float-significand-byte double-float-normal-exponent-min
+	  double-float-normal-exponent-max double-float-hidden-bit
+	  double-float-trapping-nan-bit double-float-digits
+
+	  long-float-bias long-float-exponent-byte
+	  long-float-significand-byte long-float-normal-exponent-min
+	  long-float-normal-exponent-max long-float-hidden-bit
+	  long-float-trapping-nan-bit long-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+	  
+
+(eval-when (compile load eval)
+
+(defconstant word-bits 64
+  "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+  "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+  "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+  "Number of bytes in a word.")
+) ; eval-when
+
+(eval-when (compile load eval)
+(defconstant float-sign-shift 31)
+
+;; These values were taken from the alpha code. The values for
+;; bias and exponent min/max are not the same as shown in the 486 book.
+;; They may be correct for how Python uses them.
+(defconstant single-float-bias 126)	; Intel says 127
+(defconstant single-float-exponent-byte (byte 8 23))
+(defconstant single-float-significand-byte (byte 23 0))
+;; The 486 book shows the exponent range -126 to +127. The Lisp
+;; code that uses these values seems to want already biased numbers.
+(defconstant single-float-normal-exponent-min 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(defconstant double-float-bias 1022)
+(defconstant double-float-exponent-byte (byte 11 20))
+(defconstant double-float-significand-byte (byte 20 0))
+(defconstant double-float-normal-exponent-min 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant long-float-bias 16382)
+(defconstant long-float-exponent-byte (byte 15 0))
+(defconstant long-float-significand-byte (byte 31 0))
+(defconstant long-float-normal-exponent-min 1)
+(defconstant long-float-normal-exponent-max #x7FFE)
+(defconstant long-float-hidden-bit (ash 1 31))		; Actually not hidden
+(defconstant long-float-trapping-nan-bit (ash 1 30))
+
+(defconstant single-float-digits
+  (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+  (+ (byte-size double-float-significand-byte) word-bits 1))
+
+(defconstant long-float-digits
+  (+ (byte-size long-float-significand-byte) word-bits 1))
+
+;;; pfw -- from i486 microprocessor programmers reference manual
+(defconstant float-invalid-trap-bit        (ash 1 0))
+(defconstant float-denormal-trap-bit       (ash 1 1))
+(defconstant float-divide-by-zero-trap-bit (ash 1 2))
+(defconstant float-overflow-trap-bit       (ash 1 3))
+(defconstant float-underflow-trap-bit      (ash 1 4))
+(defconstant float-inexact-trap-bit        (ash 1 5))
+
+(defconstant float-round-to-nearest  0)
+(defconstant float-round-to-negative 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-zero     3)
+
+(defconstant float-precision-24-bit  0)
+(defconstant float-precision-53-bit  2)
+(defconstant float-precision-64-bit  3)
+
+(defconstant float-rounding-mode   (byte 2 10))
+(defconstant float-sticky-bits     (byte 6 16))
+(defconstant float-traps-byte      (byte 6  0))
+(defconstant float-exceptions-byte (byte 6 16))
+(defconstant float-precision-control (byte 2 8))
+(defconstant float-fast-bit 0) ; No fast mode on x86
+); eval-when
+
+
+;;;; Description of the target address space.
+
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start
+	  target-foreign-linkage-space-start
+	  target-foreign-linkage-entry-size))
+
+;;; Where to put the different spaces.
+;;; 
+(defparameter target-read-only-space-start #x10000000)
+(defparameter target-static-space-start    #x28000000)
+(defparameter target-dynamic-space-start   #x48000000)
+(defparameter target-foreign-linkage-space-start #xB0000000)
+(defconstant target-foreign-linkage-entry-size 16) ;In bytes.  Duh.
+
+;;; Given that NIL is the first thing allocated in static space, we
+;;; know its value at compile time:
+;;; 
+(defparameter nil-value (+ target-static-space-start #x13))
+
+
+;;;; Other random constants.
+
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap
+	  single-step-breakpoint-trap
+          object-not-list-trap object-not-instance-trap
+	  trace-table-normal trace-table-call-site
+	  trace-table-function-prologue trace-table-function-epilogue))
+
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror
+  breakpoint
+  function-end-breakpoint
+  single-step-breakpoint)
+
+(defenum (:prefix object-not- :suffix -trap :start 16)
+  list
+  instance)
+
+(defenum (:prefix trace-table-)
+  normal
+  call-site
+  function-prologue
+  function-epilogue)
+
+
+
+;;;; Static symbols.
+
+(export '(static-symbols static-functions))
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols.  That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+;;; pfw X86 doesn't have enough registers to keep these things there.
+;;;     Note these spaces grow from low to high addresses.
+(defvar *allocation-pointer*)
+(defvar *binding-stack-pointer*)
+(defvar *x86-cgc-active-p*)
+(defvar *static-blue-bag* nil)
+
+(defparameter static-symbols
+    '(t
+
+      ;; The C startup code must fill these in.
+      lisp::lisp-environment-list
+      lisp::lisp-command-line-list
+      ext::*batch-mode*
+      lisp::*initial-fdefn-objects*
+
+      ;; Functions that the C code needs to call
+      lisp::%initial-function
+      lisp::maybe-gc
+      kernel::internal-error
+      #+stack-checking kernel::yellow-zone-hit
+      #+stack-checking kernel::red-zone-hit
+      di::handle-breakpoint
+      lisp::fdefinition-object
+
+      ;; Free Pointers.
+      lisp::*read-only-space-free-pointer*
+      lisp::*static-space-free-pointer*
+      lisp::*initial-dynamic-space-free-pointer*
+
+      ;; Things needed for non-local-exit.
+      lisp::*current-catch-block*
+      lisp::*current-unwind-protect-block*
+      *eval-stack-top*
+      *alien-stack*
+
+      ;; Interrupt Handling
+      lisp::*pseudo-atomic-atomic*
+      lisp::*pseudo-atomic-interrupted*
+      unix::*interrupts-enabled*
+      unix::*interrupt-pending*
+      lisp::*free-interrupt-context-index*
+
+      *allocation-pointer*
+      *binding-stack-pointer*
+      *internal-gc-trigger*   ; Not used.
+
+      ;; The FP constants
+      *fp-constant-0d0*
+      *fp-constant-1d0*
+      *fp-constant-0s0*
+      *fp-constant-1s0*
+      ;; Following are all long-floats.
+      *fp-constant-0l0*
+      *fp-constant-1l0*
+      *fp-constant-pi*
+      *fp-constant-l2t*
+      *fp-constant-l2e*
+      *fp-constant-lg2*
+      *fp-constant-ln2*
+
+      ;; Used by gencgc.
+      *scavenge-read-only-space*
+
+      ;; Multi-process support.
+      *control-stacks*
+
+      ;; Make the ..slot-unbound.. symbol static to optimise the
+      ;; common slot unbound check.
+      pcl::..slot-unbound..
+
+      ;; These are filled in the C run-time.
+      lisp::*cmucl-lib*
+      lisp::*cmucl-core-path*
+      
+      ;; Spare symbols.  Rename these when you need to add some static
+      ;; symbols and don't want to do a cross-compile.
+      spare-8
+      spare-7
+      spare-6
+      spare-5
+      spare-4
+      spare-3
+      spare-2
+      spare-1
+      
+      ;; Used by CGC.
+      *x86-cgc-active-p*
+      ;; Foreign linkage stuff
+      lisp::*linkage-table-data*
+      system::*global-table*
+      *current-region-free-pointer*
+      *current-region-end-addr*
+      *static-blue-bag*		; Must be last or change C code
+
+      
+      ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql
+    %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm
+    ))
+
+;;;
+;;; Stuff added by jrd ----
+;;;
+
+
+;;; cf the sparc PARMS.LISP
+(defparameter *assembly-unit-length* 8)
diff --git a/compiler/amd64/pred.lisp b/compiler/amd64/pred.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0ab7a589df20fbe731e2f382b21b000648e2e2ca
--- /dev/null
+++ b/compiler/amd64/pred.lisp
@@ -0,0 +1,80 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/pred.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the x86.
+;;;
+;;; Written by William Lott.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;; 
+
+(in-package :amd64)
+
+
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination.  Dest is the continuation we transfer control to.
+;;;
+(define-vop (branch)
+  (:info dest)
+  (:generator 5
+    (inst jmp dest)))
+
+
+;;;; Conditional VOPs:
+
+;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
+;;; not immediate data.
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg control-stack constant)
+	    :load-if (not (and (sc-is x immediate)
+			       (sc-is y any-reg descriptor-reg
+				      control-stack constant))))
+	 (y :scs (any-reg descriptor-reg immediate)
+	    :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+			       (sc-is y control-stack constant)))))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (cond 
+     ((sc-is y immediate)
+      (let ((val (tn-value y)))
+	(etypecase val
+	  (integer
+	   (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+	       (inst test x x) ; smaller
+	     (inst cmp x (fixnumize val))))
+	  (symbol
+	   (inst cmp x (+ nil-value (static-symbol-offset val))))
+	  (character
+	   (inst cmp x (logior (ash (char-code val) type-bits)
+			       base-char-type))))))
+     ((sc-is x immediate) ; and y not immediate
+      ;; Swap the order to fit the compare instruction.
+      (let ((val (tn-value x)))
+	(etypecase val
+	  (integer
+	   (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+	       (inst test y y) ; smaller
+	     (inst cmp y (fixnumize val))))
+	  (symbol
+	   (inst cmp y (+ nil-value (static-symbol-offset val))))
+	  (character
+	   (inst cmp y (logior (ash (char-code val) type-bits)
+			       base-char-type))))))
+      (t
+       (inst cmp x y)))
+    
+    (inst jmp (if not-p :ne :e) target)))
diff --git a/compiler/amd64/print.lisp b/compiler/amd64/print.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1f894cff087727c66a82e51c16c10e165e965536
--- /dev/null
+++ b/compiler/amd64/print.lisp
@@ -0,0 +1,35 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/print.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the print VOP, which is used while booting the kernel
+;;; core to keep the user entertained.
+;;;
+;;; Written by William Lott.
+;;; Enhancements/debugging by Douglas T. Crosher 1996.
+;;;
+(in-package :amd64)
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg any-reg)))
+  (:temporary (:sc unsigned-reg :offset rax-offset :target result
+		   :from :eval :to :result) rax)
+  (:temporary (:sc unsigned-reg :offset rdi-offset) rdi) ; from/to?
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:generator 100
+    (move rdi object) ;; C arg 1
+    ;; LEA can't be used because it can only do sign-extended 32 bit argument.
+    ;; We need to specify immediate here because we don't want to be indirected
+    (inst mov-imm rax (make-fixup (extern-alien-name "debug_print") :foreign))
+    (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
+    (move result rax)))
diff --git a/compiler/amd64/sap.lisp b/compiler/amd64/sap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..065e93c0cb100d5b624dfdad74ba86eb842bade0
--- /dev/null
+++ b/compiler/amd64/sap.lisp
@@ -0,0 +1,613 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/sap.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the AMD64 VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999.
+;;;
+(in-package :amd64)
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:note "pointer to SAP coercion")
+  (:generator 1
+    (loadw y x sap-pointer-slot other-pointer-type)))
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+
+(define-vop (move-from-sap)
+  (:args (sap :scs (sap-reg) :to :result))
+  (:results (res :scs (descriptor-reg) :from :argument))
+  (:temporary (:sc any-reg) temp)
+  (:note "SAP to pointer coercion") 
+  (:node-var node)
+  (:generator 20
+    (with-fixed-allocation (res sap-type sap-size temp node)
+      (storew sap res sap-pointer-slot other-pointer-type))))
+	   
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
+
+
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
+  (:note "SAP move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+
+
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "SAP argument move")
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (sap-stack
+       (if (= (tn-offset fp) rsp-offset)
+	   (storew x fp (tn-offset y))	; c-call
+	   (storew x fp (- (1+ (tn-offset y)))))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
+
+
+
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+  (:args (sap :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate sap-int)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int sap)))
+
+(define-vop (int-sap)
+  (:args (int :scs (unsigned-reg) :target sap))
+  (:arg-types unsigned-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate int-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+(define-vop (fixnum-sap)
+  (:args (int :scs (any-reg)))
+  (:arg-types tagged-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate fixnum-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+#+nil
+(define-vop (fixnum-sap)
+    (:args (x :scs (any-reg descriptor-reg) :target sap
+	      :load-if (not (location= x sap))))
+  (:arg-types tagged-num)
+  (:results (sap :scs (sap-reg)
+		 :load-if (not (location= x sap))))
+  (:result-types system-area-pointer)
+  (:note "fixnum as sap")
+  (:generator 1
+    (move sap x)))
+
+#+nil
+(define-move-vop fixnum-sap :move
+  (any-reg descriptor-reg) (sap-reg))
+
+#+nil
+(define-vop (fixnum-sap)
+  (:args (arg :scs (any-reg descriptor-reg) :target sap
+	    ; :load-if (not (location= arg sap))
+	    ))
+  (:arg-types tagged-num)
+  (:results (sap :scs (sap-reg)
+		 ; :load-if (not (location= arg sap))
+		 ))
+  (:result-types system-area-pointer)
+  (:translate fixnum-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap arg)))
+
+#+nil
+(define-vop (fixnum-sap)
+  (:args (int :scs (any-reg descriptor-reg) :target sap))
+  (:arg-types fixnum)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate fixnum-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap fixnum)))
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg) :target res
+	      :load-if (not (location= ptr res)))
+	 (offset :scs (signed-reg immediate)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg) :from (:argument 0)
+		 :load-if (not (location= ptr res))))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
+		(not (location= ptr res)))
+	   (sc-case offset
+	     (signed-reg
+	      (inst lea res (make-ea :qword :base ptr :index offset :scale 1)))
+	     (immediate
+	      (inst lea res (make-ea :qword :base ptr
+				     :disp (tn-value offset))))))
+	  (t
+	   (move res ptr)
+	   (sc-case offset
+	     (signed-reg
+	      (inst add res offset))
+	     (immediate
+	      (inst add res (tn-value offset))))))))
+
+(define-vop (pointer-)
+  (:translate sap-)
+  (:args (ptr1 :scs (sap-reg) :target res)
+	 (ptr2 :scs (sap-reg)))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:policy :fast-safe)
+  (:results (res :scs (signed-reg) :from (:argument 0)))
+  (:result-types signed-num)
+  (:generator 1
+    (move res ptr1)
+    (inst sub res ptr2)))
+
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (compile eval)
+
+(defmacro def-system-ref-and-set
+	  (ref-name set-name sc type size &optional signed)
+  (let ((ref-name-c (symbolicate ref-name "-C"))
+	(set-name-c (symbolicate set-name "-C"))
+	(temp-sc (symbolicate size "-REG")))
+    `(progn
+       (define-vop (,ref-name)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (signed-reg)))
+	 (:arg-types system-area-pointer signed-num)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	  (inst ,(cond ((or (eq size :qword)
+			    (and (eq size :dword) (not signed)))
+			'mov)
+		       ((eq size :dword) ; signed
+			'movsxd)
+		       (signed 'movsx) ; word and byte
+		       (t 'movzx))
+		,(if (and (eq size :dword) (not signed))
+		     ;; high 32 bits of doubleword operands are zero
+		     ;; extended to 64 bits
+		     '(64-bit-to-32-bit-tn result)
+		     'result)
+		(make-ea ,size :base sap :index offset))))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 32)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	  (inst ,(cond ((or (eq size :qword)
+			    (and (eq size :dword) (not signed)))
+			'mov)
+		       ((eq size :dword) ; signed
+			'movsxd)
+		       (signed 'movsx) ; word and byte
+		       (t 'movzx))
+		,(if (and (eq size :dword) (not signed))
+		     ;; high 32 bits of doubleword operands are zero
+		     ;; extended to 64 bits
+		     '(64-bit-to-32-bit-tn result)
+		     'result)
+		(make-ea ,size :base sap :disp offset))))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg) :to (:eval 0))
+		(offset :scs (signed-reg) :to (:eval 0))
+		(value :scs (,sc)
+		       :target ,(if (eq size :byte) 'temp 'result)))
+	 (:arg-types system-area-pointer signed-num ,type)
+	 ,@(when (eq size :byte)
+	     `((:temporary (:sc ,temp-sc :offset rax-offset
+				:from (:argument 2) :to (:result 0)
+				:target result)
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	  ,(ecase size
+		   (:qword
+		    '(inst mov (make-ea :qword :base sap :index offset)
+		      value))
+		   (:dword
+		    '(inst mov (make-ea :dword :base sap :index offset)
+		      (64-bit-to-32-bit-tn value)))
+		   (:word
+		    '(inst mov (make-ea :word :base sap :index offset)
+		      (64-bit-to-16-bit-tn value)))
+		   (:byte
+		    '(let ((low-8-bit-tn (64-bit-to-8-bit-tn value))
+			   (ea (make-ea :byte :base sap :index offset)))
+		      (if low-8-bit-tn
+			  (inst mov ea low-8-bit-tn)
+			  ;; We can't access the lower 8 bits so we use
+			  ;; another move.
+			  (progn
+			    (move rax-tn value)
+			    (inst mov ea temp))))))
+	  (move result value)))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg) :to (:eval 0))
+		(value :scs (,sc)
+		       :target ,(if (eq size :byte) 'temp 'result)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 32)) ,type)
+	 (:info offset)
+	 ,@(when (eq size :byte)
+	     `((:temporary (:sc ,temp-sc :offset rax-offset
+				:from (:argument 2) :to (:result 0)
+				:target result)
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	  ,(ecase size
+		   (:qword
+		    '(inst mov (make-ea :qword :base sap :disp offset)
+		      value))
+		   (:dword
+		    '(inst mov (make-ea :dword :base sap :disp offset)
+		      (64-bit-to-32-bit-tn value)))
+		   (:word
+		    '(inst mov (make-ea :word :base sap :disp offset)
+		      (64-bit-to-16-bit-tn value)))
+		   (:byte
+		    '(let ((low-8-bit-tn (64-bit-to-8-bit-tn value))
+			   (ea (make-ea :byte :base sap :disp offset)))
+		      (if low-8-bit-tn
+			  (inst mov ea low-8-bit-tn)
+			  ;; We can't access the lower 8 bits so we use
+			  ;; another move.
+			  (progn
+			    (move rax-tn value)
+			    (inst mov ea temp))))))
+	   (move result value))))))
+
+); eval-when (compile eval)
+
+(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  unsigned-reg positive-fixnum :byte nil)
+(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  signed-reg tagged-num :byte t)
+
+(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  unsigned-reg positive-fixnum :word nil)
+(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  signed-reg tagged-num :word t)
+
+(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  unsigned-reg positive-fixnum :dword nil)
+(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  signed-reg tagged-num :dword t)
+
+(def-system-ref-and-set sap-ref-64 %set-sap-ref-64
+  unsigned-reg unsigned-num :qword nil)
+(def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
+  signed-reg signed-num :qword t)
+
+(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :qword)
+
+
+;;; Sap-Ref-Double
+(define-vop (sap-ref-double)
+  (:translate sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 5
+     (with-empty-tn@fp-top(result)
+        (inst fldd (make-ea :qword :base sap :index offset)))))
+
+(define-vop (sap-ref-double-c)
+  (:translate sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:info offset)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 4
+     (with-empty-tn@fp-top(result)
+        (inst fldd (make-ea :qword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-double)
+  (:translate %set-sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (signed-reg) :to (:eval 0))
+	 (value :scs (double-reg)))
+  (:arg-types system-area-pointer signed-num double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :qword :base sap :index offset))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :qword :base sap :index offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-double-c)
+  (:translate %set-sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (value :scs (double-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float)
+  (:info offset)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 4
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :qword :base sap :disp offset))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :qword :base sap :disp offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+;;; Sap-Ref-Single
+(define-vop (sap-ref-single)
+  (:translate sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+     (with-empty-tn@fp-top(result)
+        (inst fld (make-ea :qword :base sap :index offset)))))
+
+(define-vop (sap-ref-single-c)
+  (:translate sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:info offset)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+     (with-empty-tn@fp-top(result)
+        (inst fld (make-ea :qword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-single)
+  (:translate %set-sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (signed-reg) :to (:eval 0))
+	 (value :scs (single-reg)))
+  (:arg-types system-area-pointer signed-num single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :qword :base sap :index offset))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :qword :base sap :index offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-single-c)
+  (:translate %set-sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (value :scs (single-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
+  (:info offset)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :qword :base sap :disp offset))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :qword :base sap :disp offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+
+;;; Sap-Ref-Long
+(define-vop (sap-ref-long)
+  (:translate sap-ref-long)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (result :scs (#+long-float long-reg #-long-float double-reg)))
+  (:result-types #+long-float long-float #-long-float double-float)
+  (:generator 5
+     (with-empty-tn@fp-top(result)
+        (inst fldl (make-ea :qword :base sap :index offset)))))
+
+(define-vop (sap-ref-long-c)
+  (:translate sap-ref-long)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:info offset)
+  (:results (result :scs (#+long-float long-reg #-long-float double-reg)))
+  (:result-types #+long-float long-float #-long-float double-float)
+  (:generator 4
+     (with-empty-tn@fp-top(result)
+        (inst fldl (make-ea :qword :base sap :disp offset)))))
+
+#+long-float
+(define-vop (%set-sap-ref-long)
+  (:translate %set-sap-ref-long)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (signed-reg) :to (:eval 0))
+	 (value :scs (long-reg)))
+  (:arg-types system-area-pointer signed-num long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float (make-ea :qword :base sap :index offset))
+	   (unless (zerop (tn-offset result))
+	     ;; Value is in ST0 but not result.
+	     (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float (make-ea :qword :base sap :index offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+
+;;; Noise to convert normal lisp data objects into SAPs.
+
+(define-vop (vector-sap)
+  (:translate vector-sap)
+  (:policy :fast-safe)
+  (:args (vector :scs (descriptor-reg) :target sap))
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (move sap vector)
+    (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type))))
diff --git a/compiler/amd64/static-fn.lisp b/compiler/amd64/static-fn.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..cb50c68a6c51a34de9cd072704a927b9fbdbb19b
--- /dev/null
+++ b/compiler/amd64/static-fn.lisp
@@ -0,0 +1,169 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/static-fn.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;;
+(in-package :amd64)
+
+
+(define-vop (static-function-template)
+  (:save-p t)
+  (:policy :safe)
+  (:variant-vars function)
+  (:vop-var vop)
+  (:node-var node)
+  (:temporary (:sc unsigned-reg :offset rbx-offset
+		   :from (:eval 0) :to (:eval 2)) rbx)
+  (:temporary (:sc unsigned-reg :offset rcx-offset
+		   :from (:eval 0) :to (:eval 2)) rcx))
+
+(eval-when (compile load eval)
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+(defun moves (dst src)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car dst) ,(car src))))
+    (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+  (assert (and (<= num-args register-arg-count)
+	       (<= num-results register-arg-count))
+	  (num-args num-results)
+	  "Either too many args (~D) or too many results (~D).  Max = ~D"
+	  num-args num-results register-arg-count)
+  (let ((num-temps (max num-args num-results)))
+    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+      (dotimes (i num-results)
+	(let ((result-name (intern (format nil "RESULT-~D" i))))
+	  (result-names result-name)
+	  (results `(,result-name :scs (any-reg descriptor-reg)))))
+      (dotimes (i num-temps)
+	(let ((temp-name (intern (format nil "TEMP-~D" i))))
+	  (temp-names temp-name)
+	  (temps `(:temporary (:sc descriptor-reg
+			       :offset ,(nth i register-arg-offsets)
+			       :from ,(if (< i num-args)
+					  `(:argument ,i)
+					  '(:eval 1))
+			       :to ,(if (< i num-results)
+					`(:result ,i)
+					'(:eval 1))
+			       ,@(when (< i num-results)
+				   `(:target ,(nth i (result-names)))))
+			      ,temp-name))))
+      (dotimes (i num-args)
+	(let ((arg-name (intern (format nil "ARG-~D" i))))
+	  (arg-names arg-name)
+	  (args `(,arg-name
+		  :scs (any-reg descriptor-reg)
+		  :target ,(nth i (temp-names))))))
+      `(define-vop (,(static-function-template-name num-args num-results)
+		    static-function-template)
+	(:args ,@(args))
+	,@(temps)
+	(:temporary (:sc unsigned-reg) temp) ; from/to?
+	(:results ,@(results))
+	(:generator ,(+ 50 num-args num-results)
+	 ,@(moves (temp-names) (arg-names))
+
+	 ;; If speed not more important than size, duplicate the
+	 ;; effect of the ENTER with discrete instructions.  Takes
+	 ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
+	 (cond ((policy node (>= speed space))
+		(inst mov rbx rsp-tn)
+		;; Save the old-fp
+		(inst push rbp-tn)
+		;; Ensure that at least three slots are available; one
+		;; above, two more needed.
+		(inst sub rsp-tn (fixnumize 2))
+		(inst mov rbp-tn rbx))
+	       (t
+		(inst enter (fixnumize 2))
+		;; The enter instruction pushes RBP and then copies
+		;; RSP into RBP.  We want the new RBP to be the
+		;; original RSP, so we fix it up afterwards.
+		(inst add rbp-tn (fixnumize 1))))
+	 
+	 ,(if (zerop num-args)
+	      '(inst xor rcx rcx)
+	      `(inst mov rcx (fixnumize ,num-args)))
+	 
+	 (note-this-location vop :call-site)
+	 ;; Static-function-offset gives the offset from the start of
+	 ;; the nil object to the static function fdefn and has the
+	 ;; low tag of 1 added.  When the nil symbol value with its
+	 ;; low tag of 3 is added the resulting value points to the
+	 ;; raw address slot of the fdefn (at +4).
+	 ;; We must add a MOV instruction here because indirect call is
+	 ;; limited to 32 bit addresses.
+	 (inst mov temp (+ nil-value (static-function-offset function)))
+	 (inst call (make-ea :qword :base temp))
+	 ,(collect ((bindings) (links))
+		   (do ((temp (temp-names) (cdr temp))
+			(name 'values (gensym))
+			(prev nil name)
+			(i 0 (1+ i)))
+		       ((= i num-results))
+		     (bindings `(,name
+				 (make-tn-ref ,(car temp) nil)))
+		     (when prev
+		       (links `(setf (tn-ref-across ,prev) ,name))))
+		   `(let ,(bindings)
+		     ,@(links)
+		     (default-unknown-values
+			 vop
+			 ,(if (zerop num-results) nil 'values)
+		       ,num-results)))
+	 ,@(moves (result-names) (temp-names)))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(macrolet ((frob (num-args num-res)
+	     (static-function-template-vop (eval num-args) (eval num-res))))
+  (frob 0 1)
+  (frob 1 1)
+  (frob 2 1)
+  (frob 3 1))
+
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+				       policy cost arg-types result-types)
+  `(define-vop (,name
+		,(static-function-template-name (length args)
+						(length results)))
+     (:variant ',name)
+     (:note ,(format nil "static-function ~@(~S~)" name))
+     ,@(when translate
+	 `((:translate ,translate)))
+     ,@(when policy
+	 `((:policy ,policy)))
+     ,@(when cost
+	 `((:generator-cost ,cost)))
+     ,@(when arg-types
+	 `((:arg-types ,@arg-types)))
+     ,@(when result-types
+	 `((:result-types ,@result-types)))))
diff --git a/compiler/amd64/subprim.lisp b/compiler/amd64/subprim.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7466aca2f78bd969a33509f7290ccdafbe5897ea
--- /dev/null
+++ b/compiler/amd64/subprim.lisp
@@ -0,0 +1,93 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/subprim.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+(in-package :amd64)
+
+
+
+;;;; Length
+
+(define-vop (length/list)
+  (:translate length)
+  (:args (object :scs (descriptor-reg control-stack) :target ptr))
+  (:arg-types list)
+  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) ptr)
+  (:results (count :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 40
+    ;; Move OBJECT into a temp we can bash on, and initialize the count.
+    (move ptr object)
+    (inst xor count count)
+    ;; If we are starting with NIL, then it's real easy.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Note: we don't have to test to see if the original argument is a
+    ;; list, because this is a :fast-safe vop.
+    LOOP
+    ;; Get the CDR and boost the count.
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst add count (fixnumize 1))
+    ;; If we hit NIL, then we are done.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Otherwise, check to see if we hit the end of a dotted list.  If
+    ;; not, loop back for more.
+    (move rax ptr)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn list-pointer-type)
+    (inst jmp :e loop)
+    ;; It's dotted all right.  Flame out.
+    (error-call vop object-not-list-error ptr)
+    ;; We be done.
+    DONE))
+
+(define-vop (fast-length/list)
+  (:translate length)
+  (:args (object :scs (descriptor-reg control-stack) :target ptr))
+  (:arg-types list)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) ptr)
+  (:results (count :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:policy :fast)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 30
+    ;; Get a copy of OBJECT in a register we can bash on, and
+    ;; initialize COUNT.
+    (move ptr object)
+    (inst xor count count)
+    ;; If we are starting with NIL, we be done.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Indirect the next cons cell, and boost the count.
+    LOOP
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst add count (fixnumize 1))
+    ;; If we arn't done, go back for more.
+    (inst cmp ptr nil-value)
+    (inst jmp :ne loop)
+    DONE))
+
+
+(define-static-function length (object) :translate length)
+
diff --git a/compiler/amd64/system.lisp b/compiler/amd64/system.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9867f32bd2c8f4654ed4002929c70d92d22595f3
--- /dev/null
+++ b/compiler/amd64/system.lisp
@@ -0,0 +1,608 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/system.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;;
+;;; x86 VM definitions of various system hacking operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998,1999.
+;;;
+
+(in-package :amd64)
+
+
+;;;; Type frobbing VOPs
+
+(define-vop (get-lowtag)
+  (:translate get-lowtag)
+  (:policy :fast-safe)
+  (:args (object :scs (any-reg descriptor-reg control-stack)
+		 :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (move result object)
+    (inst and result lowtag-mask)))
+
+(define-vop (get-type)
+  (:translate get-type)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 0)) rax)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (inst mov rax object)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn other-pointer-type)
+    (inst jmp :e other-ptr)
+    (inst cmp al-tn function-pointer-type)
+    (inst jmp :e function-ptr)
+
+    ;; pick off structures and list pointers
+    (inst test al-tn 1)
+    (inst jmp :ne done)
+
+    ;; pick off fixnums
+    (inst and al-tn 3)
+    (inst jmp :e done)
+
+    ;; must be an other immediate
+    (inst mov rax object)
+    (inst jmp done)
+    
+    FUNCTION-PTR
+    (load-type al-tn object (- vm:function-pointer-type))
+    (inst jmp done)
+    
+    OTHER-PTR
+    (load-type al-tn object (- vm:other-pointer-type))
+    
+    DONE
+    (inst movzx result al-tn)))
+
+(define-vop (function-subtype)
+  (:translate function-subtype)
+  (:policy :fast-safe)
+  (:args (function :scs (descriptor-reg)))
+  (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (load-type temp function (- vm:function-pointer-type))
+    (inst movzx result temp)))
+
+(define-vop (set-function-subtype)
+  (:translate (setf function-subtype))
+  (:policy :fast-safe)
+  (:args (type :scs (unsigned-reg) :target rax)
+	 (function :scs (descriptor-reg)))
+  (:arg-types positive-fixnum *)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
+		   :to (:result 0) :target result)
+	      rax)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (move rax type)
+    (inst mov
+	  (make-ea :byte :base function :disp (- function-pointer-type))
+	  al-tn)
+    (move result rax)))
+
+(define-vop (get-header-data)
+  (:translate get-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 other-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (get-closure-length)
+  (:translate get-closure-length)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 function-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res :to (:result 0))
+	 (data :scs (any-reg) :target rax))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg :offset rax-offset
+		   :from (:argument 1) :to (:result 0)) rax)
+  (:generator 6
+    (move rax data)
+    (inst shl rax (- type-bits 2))
+    (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
+    (storew rax x 0 other-pointer-type)
+    (move res x)))
+
+(define-vop (make-fixnum)
+  (:args (ptr :scs (any-reg descriptor-reg) :target res))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    ;;
+    ;; Some code (the hash table code) depends on this returning a
+    ;; positive number so make sure it does.
+    (move res ptr)
+    (inst shl res 3)
+    (inst shr res 1)))
+
+(define-vop (make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg) :target res)
+	 (type :scs (unsigned-reg immediate)))
+  (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
+  (:generator 2
+    (move res val)
+    (inst shl res (- type-bits 2))
+    (inst or res (sc-case type
+		   (unsigned-reg type)
+		   (immediate (tn-value type))))))
+
+
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate dynamic-space-free-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (load-symbol-value int *allocation-pointer*)))
+
+(define-vop (binding-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate binding-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (load-symbol-value int *binding-stack-pointer*)))
+
+(defknown (setf binding-stack-pointer-sap)
+    (system-area-pointer) system-area-pointer ())
+
+(define-vop (set-binding-stack-pointer-sap)
+  (:args (new-value :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate (setf binding-stack-pointer-sap))
+  (:policy :fast-safe)
+  (:generator 1
+    (store-symbol-value new-value *binding-stack-pointer*)
+    (move int new-value)))
+
+(define-vop (control-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate control-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int rsp-tn)))
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (:translate code-instructions)
+  (:policy :fast-safe)
+  (:args (code :scs (descriptor-reg) :to (:result 0)))
+  (:results (sap :scs (sap-reg) :from (:argument 0)))
+  (:result-types system-area-pointer)
+  (:generator 10
+    (loadw sap code 0 other-pointer-type)
+    (inst shr sap type-bits)
+    (inst lea sap (make-ea :byte :base code :index sap :scale 8
+			   :disp (- other-pointer-type)))))
+
+(define-vop (compute-function)
+  (:args (code :scs (descriptor-reg) :to (:result 0))
+	 (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
+  (:arg-types * positive-fixnum)
+  (:results (func :scs (descriptor-reg) :from (:argument 0)))
+  (:generator 10
+    (loadw func code 0 other-pointer-type)
+    (inst shr func type-bits)
+    (inst lea func
+	  (make-ea :byte :base offset :index func :scale 8
+		   :disp (- function-pointer-type other-pointer-type)))
+    (inst add func code)))
+
+(defknown %function-self (function) function (flushable))
+
+(define-vop (%function-self)
+  (:policy :fast-safe)
+  (:translate %function-self)
+  (:args (function :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg)))
+  (:generator 3
+    (loadw result function function-self-slot function-pointer-type)
+    (inst lea result
+	  (make-ea :byte :base result 
+		   :disp (- function-pointer-type
+			    (* function-code-offset word-bytes))))))
+
+;;; Closure function slot is a pointer to raw code on X86 instead of
+;;; a pointer to the code function object itself. This VOP is used
+;;; to reference the function object given the closure object.
+(def-source-transform %closure-function (closure)
+  `(%function-self ,closure))
+
+(def-source-transform %funcallable-instance-function (fin)
+  `(%function-self ,fin))
+
+(defknown (setf %function-self) (function function) function  (unsafe))
+
+(define-vop (%set-function-self)
+  (:policy :fast-safe)
+  (:translate (setf %function-self))
+  (:args (new-self :scs (descriptor-reg) :target result :to :result)
+	 (function :scs (descriptor-reg) :to :result))
+  (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 3
+    (inst lea temp
+	  (make-ea :byte :base new-self
+		   :disp (- (ash function-code-offset word-shift)
+			    function-pointer-type)))
+    (storew temp function function-self-slot function-pointer-type)
+    (move result new-self)))
+
+;; Would have really liked to use a source-transform for this, but they
+;; don't work with setf functions.
+;; 
+(defknown ((setf %funcallable-instance-function)) (function function) function
+  (unsafe))
+(deftransform (setf %funcallable-instance-function) ((value fin))
+  '(setf (%function-self fin) value))
+
+
+
+;;;; Other random VOPs.
+
+(defknown unix::do-pending-interrupt () (values))
+(define-vop (unix::do-pending-interrupt)
+  (:policy :fast-safe)
+  (:translate unix::do-pending-interrupt)
+  (:generator 1
+    (inst break pending-interrupt-trap)))
+
+(define-vop (halt)
+  (:generator 1
+    (inst break halt-trap)))
+
+(defknown float-wait () (values))
+(define-vop (float-wait)
+  (:policy :fast-safe)
+  (:translate float-wait)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-next-instruction vop :internal-error)
+    (inst wait)))
+
+;;;; Dynamic vop count collection support
+
+(define-vop (count-me)
+  (:args (count-vector :scs (descriptor-reg)))
+  (:info index)
+  (:generator 0
+    (inst inc (make-ea :qword :base count-vector
+		       :disp (- (* (+ vector-data-offset index) word-bytes)
+				other-pointer-type)))))
+
+
+
+(defknown lisp::%scrub-control-stack () (values))
+
+;;; Scrub the control stack.
+;;;
+;;; On the amd64 port the stack grows downwards, and to support grow on
+;;; demand stacks the stack must be decreased as it is scrubbed.
+;;;
+(define-vop (%scrub-control-stack)
+  (:policy :fast-safe)
+  (:translate lisp::%scrub-control-stack)
+  (:args)
+  (:results)
+  (:temporary (:sc unsigned-reg) count)
+  (:temporary (:sc any-reg) stack-save zero)
+  (:generator 25
+    (inst mov stack-save rsp-tn)
+    (inst mov zero 0)
+    (inst push zero)
+    ;; Scrub the stack.
+    SCRUB
+    (inst add rsp-tn 8)
+    (inst mov count 2048)
+    SCRUB-LOOP
+    (inst dec count)
+    (inst push zero)
+    (inst jmp :nz SCRUB-LOOP)
+    ;; Look for a clear stack unit.
+    (inst mov count 2048)
+    LOOK-LOOP
+    (inst sub rsp-tn 8)
+    (inst cmp (make-ea :qword :base rsp-tn) zero)
+    (inst jmp :ne SCRUB)
+    (inst dec count)
+    (inst jmp :nz LOOK-LOOP)
+    ;; Done, restore the stack pointer.
+    (inst mov rsp-tn stack-save)))
+
+
+;;;; Primitive multi-thread support.
+
+(export 'control-stack-fork)
+(defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t)
+  (member t nil))
+
+(define-vop (control-stack-fork)
+  (:policy :fast-safe)
+  (:translate control-stack-fork)
+  (:args (save-stack :scs (descriptor-reg) :to :result)
+	 (inherit :scs (descriptor-reg)))
+  (:arg-types simple-array-unsigned-byte-32 *)
+  (:results (child :scs (descriptor-reg)))
+  (:result-types t)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+  (:save-p t)
+  (:generator 25
+    (inst cmp inherit nil-value)
+    (inst jmp :e FRESH-STACK)
+    
+    ;; Child inherits the stack of the parent.
+    
+    ;; Setup the return context.
+    (inst push (make-fixup nil :code-object return))
+    (inst push rbp-tn)
+    ;; Save the stack.
+    (inst xor index index)
+    ;; First the stack-pointer.
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type))
+	  rsp-tn)
+    (inst inc index)
+    (load-foreign-data-symbol stack "control_stack_end")
+    (inst mov stack (make-ea :qword :base stack))
+    (inst jmp-short LOOP)
+
+    FRESH-STACK
+    ;; Child has a fresh control stack.
+
+    ;; Setup the return context.
+    (inst push (make-fixup nil :code-object return))
+    (load-foreign-data-symbol stack "control_stack_end")
+    (inst mov stack (make-ea :qword :base stack))
+    ;; New FP is the Top of the stack.
+    (inst push stack)
+    ;; Save the stack.
+    (inst xor index index)
+    ;; First save the adjusted stack-pointer.
+    (inst sub stack rbp-tn)
+    (inst add stack rsp-tn)
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type))
+	  stack)
+    ;; Save the current frame, replacing the OCFP and RA by 0.
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* (+ vm:vector-data-offset 1) vm:word-bytes)
+				vm:other-pointer-type))
+	  0)
+    ;; Save 0 for the OCFP.
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* (+ vm:vector-data-offset 2) vm:word-bytes)
+				vm:other-pointer-type))
+	  0)
+    (inst add index 3)
+    ;; Copy the remainder of the frame, skiping the OCFP and RA which
+    ;; are saved above.
+    (inst lea stack (make-ea :byte :base rbp-tn :disp -8))
+
+    LOOP
+    (inst cmp stack rsp-tn)
+    (inst jmp :le stack-save-done)
+    (inst sub stack 4)
+    (inst mov temp (make-ea :qword :base stack))
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type))
+	  temp)
+    (inst inc index)
+    (inst jmp-short LOOP)
+    
+    RETURN
+    ;; Stack already clean if it reaches here. Parent returns NIL.
+    (inst mov child nil-value)
+    (inst jmp-short DONE)
+    
+    STACK-SAVE-DONE
+    ;; Cleanup the stack
+    (inst add rsp-tn 8)
+    ;; Child returns T.
+    (load-symbol child t)
+    DONE))
+
+(export 'control-stack-resume)
+(defknown control-stack-resume ((simple-array (unsigned-byte 32) (*))
+				(simple-array (unsigned-byte 32) (*)))
+  (values))
+
+(define-vop (control-stack-resume)
+  (:policy :fast-safe)
+  (:translate control-stack-resume)
+  (:args (save-stack :scs (descriptor-reg) :to :result)
+	 (new-stack :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+  (:save-p t)
+  (:generator 25
+    ;; Setup the return context.
+    (inst push (make-fixup nil :code-object RETURN))
+    (inst push rbp-tn)
+    ;; Save the stack.
+    (inst xor index index)
+    ;; First the stack-pointer.
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type))
+	  rsp-tn)
+    (inst inc index)
+    (load-foreign-data-symbol stack "control_stack_end")
+    (inst mov stack (make-ea :qword :base stack))
+    LOOP
+    (inst cmp stack rsp-tn)
+    (inst jmp :le STACK-SAVE-DONE)
+    (inst sub stack 4)
+    (inst mov temp (make-ea :qword :base stack))
+    (inst mov (make-ea :qword :base save-stack :index index :scale 4
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type))
+	  temp)
+    (inst inc index)
+    (inst jmp-short LOOP)
+
+    STACK-SAVE-DONE
+    ;; Cleanup the stack
+    (inst add rsp-tn 8)
+
+    ;; Restore the new-stack.
+    (inst xor index index)
+    ;; First the stack-pointer.
+    (inst mov rsp-tn
+	  (make-ea :qword :base new-stack :index index :scale 4
+		   :disp (- (* vm:vector-data-offset vm:word-bytes)
+			    vm:other-pointer-type)))
+    (inst inc index)
+    (load-foreign-data-symbol stack "control_stack_end")
+    (inst mov stack (make-ea :qword :base stack))
+    LOOP2
+    (inst cmp stack rsp-tn)
+    (inst jmp :le STACK-RESTORE-DONE)
+    (inst sub stack 4)
+    (inst mov temp (make-ea :qword :base new-stack :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))
+    (inst mov (make-ea :qword :base stack) temp)
+    (inst inc index)
+    (inst jmp-short LOOP2)
+    STACK-RESTORE-DONE
+    ;; Pop the frame pointer, and resume at the return address.
+    (inst pop rbp-tn)
+    (inst ret)
+    
+    ;; Original thread resumes, stack has been cleaned up.
+    RETURN))
+
+
+(export 'control-stack-return)
+(defknown control-stack-return ((simple-array (unsigned-byte 32) (*)))
+  (values))
+
+(define-vop (control-stack-return)
+  (:policy :fast-safe)
+  (:translate control-stack-return)
+  (:args (new-stack :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-unsigned-byte-32)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+  (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+  (:save-p t)
+  (:generator 25
+    ;; Restore the new-stack.
+    (inst xor index index)
+    ;; First the stack-pointer.
+    (inst mov rsp-tn
+	  (make-ea :qword :base new-stack :index index :scale 4
+		   :disp (- (* vm:vector-data-offset vm:word-bytes)
+			    vm:other-pointer-type)))
+    (inst inc index)
+    (load-foreign-data-symbol stack "control_stack_end")
+    (inst mov stack (make-ea :qword :base stack))
+    LOOP
+    (inst cmp stack rsp-tn)
+    (inst jmp :le STACK-RESTORE-DONE)
+    (inst sub stack 4)
+    (inst mov temp (make-ea :qword :base new-stack :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))
+    (inst mov (make-ea :qword :base stack) temp)
+    (inst inc index)
+    (inst jmp-short LOOP)
+    STACK-RESTORE-DONE
+    ;; Pop the frame pointer, and resume at the return address.
+    (inst pop rbp-tn)
+    (inst ret)))
+
+
+;; the RDTSC instruction (present on Pentium processors and
+;; successors) allows you to access the time-stamp counter, a 64-bit
+;; model-specific register that counts executed cycles. The
+;; instruction returns the low cycle count in EAX and high cycle count
+;; in EDX.
+;;
+;; In order to obtain more significant results on out-of-order
+;; processors (such as the Pentium II and later), we issue a
+;; serializing CPUID instruction before reading the cycle counter.
+;; This instruction is used for its side effect of emptying the
+;; processor pipeline, to ensure that the RDTSC instruction is
+;; executed once all pending instructions have been completed.
+;;
+;; Note that cache effects mean that the cycle count can vary for
+;; different executions of the same code (it counts cycles, not
+;; retired instructions). Furthermore, the results are per-processor
+;; and not per-process, so are unreliable on multiprocessor machines
+;; where processes can migrate between processors.
+;;
+;; This method of obtaining a cycle count has the advantage of being
+;; very fast (around 20 cycles), and of not requiring a system call.
+;; However, you need to know your processor's clock speed to translate
+;; this into real execution time.
+
+(defknown read-cycle-counter () (values (unsigned-byte 32) (unsigned-byte 32)) ())
+
+(define-vop (read-cycle-counter)
+  (:translate read-cycle-counter)
+  (:guard (backend-featurep :pentium))
+  (:args )
+  (:policy :fast-safe)
+  (:results (lo :scs (unsigned-reg))
+            (hi :scs (unsigned-reg)))
+  (:result-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset rax-offset :target lo) rax)
+  (:temporary (:sc unsigned-reg :offset rdx-offset :target hi) rdx)
+  (:generator 1
+     (inst cpuid)
+     (inst rdtsc)
+     (move hi rdx)
+     (move lo rax)))
+
+#+pentium
+(defun read-cycle-counter ()
+  (read-cycle-counter))
diff --git a/compiler/amd64/type-vops.lisp b/compiler/amd64/type-vops.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..50960ffcd24bc1ec2944ecb1078fa2596527d03f
--- /dev/null
+++ b/compiler/amd64/type-vops.lisp
@@ -0,0 +1,761 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the AMD64.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski, Spring-95.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998.
+;;;
+(in-package :amd64)
+
+
+
+;;;; Test generation utilities.
+
+(eval-when (compile eval)
+
+(defparameter immediate-types
+  (list unbound-marker-type base-char-type))
+
+
+(defparameter function-header-types
+  (list funcallable-instance-header-type dylan-function-header-type
+	byte-code-function-type byte-code-closure-type
+	function-header-type closure-function-header-type
+	closure-header-type))
+
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-type other-immediate-0-type)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
+
+(defmacro test-type (value target not-p &rest type-codes)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-type type-codes)
+		       (member odd-fixnum-type type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p (if (intersection headers function-header-types)
+			 (if (subsetp headers function-header-types)
+			     t
+			     (error "Can't test for mix of function subtypes ~
+				     and normal header types."))
+			 nil)))
+    (unless type-codes
+      (error "Must supply at least one type for test-type."))
+    (cond
+     (fixnump
+      (when (remove-if #'(lambda (x)
+			   (or (= x even-fixnum-type)
+			       (= x odd-fixnum-type)))
+		       lowtags)
+	(error "Can't mix fixnum testing with other lowtags."))
+      (when function-p
+	(error "Can't mix fixnum testing with function subtype testing."))
+      (when immediates
+	(error "Can't mix fixnum testing with other immediates."))
+      (if headers
+	  `(%test-fixnum-and-headers ,value ,target ,not-p
+				     ',(canonicalize-headers headers))
+	  `(%test-fixnum ,value ,target ,not-p)))
+     (immediates
+      (when headers
+	(error "Can't mix testing of immediates with testing of headers."))
+      (when lowtags
+	(error "Can't mix testing of immediates with testing of lowtags."))
+      (when (cdr immediates)
+	(error "Can't test multiple immediates at the same time."))
+      `(%test-immediate ,value ,target ,not-p ,(car immediates)))
+     (lowtags
+      (when (cdr lowtags)
+	(error "Can't test multiple lowtags at the same time."))
+      (if headers
+	  `(%test-lowtag-and-headers
+	    ,value ,target ,not-p ,(car lowtags)
+	    ,function-p ',(canonicalize-headers headers))
+	  `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+     (headers
+      `(%test-headers ,value ,target ,not-p ,function-p
+		      ',(canonicalize-headers headers)))
+     (t
+      (error "Nothing to test?")))))
+
+
+); eval-when (compile eval)
+
+;;; Emit the most compact form of the test immediate instruction,
+;;; using an 8 bit test when the immediate is only 8 bits and the
+;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
+;;; control-stack.
+;;;
+(defun generate-fixnum-test (value)
+  (let ((offset (tn-offset value)))
+    (cond ((and (sc-is value any-reg descriptor-reg)
+		(or (= offset rax-offset) (= offset rbx-offset)
+		    (= offset rcx-offset) (= offset rdx-offset)))
+	   (inst test (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'byte-reg *backend*)
+				      :offset offset)
+		 3))
+	  ((sc-is value control-stack)
+	   (inst test (make-ea :byte :base rbp-tn
+			       :disp (- (* (1+ offset) vm:word-bytes)))
+		 3))
+	  (t
+	   (inst test value 3)))))
+
+(defun %test-fixnum (value target not-p)
+  (generate-fixnum-test value)
+  (inst jmp (if not-p :nz :z) target))
+
+(defun %test-fixnum-and-headers (value target not-p headers)
+  (let ((drop-through (gen-label)))
+    (generate-fixnum-test value)
+    (inst jmp :z (if not-p drop-through target))
+    (%test-headers value target not-p nil headers drop-through)))
+
+(defun %test-immediate (value target not-p immediate)
+  ;; Code a single instruction byte test if possible.
+  (let ((offset (tn-offset value)))
+    (cond ((and (sc-is value any-reg descriptor-reg)
+		(or (= offset rax-offset) (= offset rbx-offset)
+		    (= offset rcx-offset) (= offset rdx-offset)))
+	   (inst cmp (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'byte-reg *backend*)
+				     :offset offset)
+		 immediate))
+	  (t
+	   (move rax-tn value)
+	   (inst cmp al-tn immediate))))
+  (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
+  (unless al-loaded
+    (move rax-tn value)
+    (inst and al-tn lowtag-mask))
+  (inst cmp al-tn lowtag)
+  (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value (if not-p drop-through target) nil lowtag)
+    (%test-headers value target not-p function-p headers drop-through t)))
+
+
+(defun %test-headers (value target not-p function-p headers
+			    &optional (drop-through (gen-label)) al-loaded)
+  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+    (multiple-value-bind
+	(equal less-or-equal when-true when-false)
+	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+	;; it's true and when we know it's false respectively.
+	(if not-p
+	    (values :ne :a drop-through target)
+	    (values :e :na target drop-through))
+      (%test-lowtag value when-false t lowtag al-loaded)
+      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (do ((remaining headers (cdr remaining)))
+	  ((null remaining))
+	(let ((header (car remaining))
+	      (last (null (cdr remaining))))
+	  (cond
+	   ((atom header)
+	    (inst cmp al-tn header)
+	    (if last
+		(inst jmp equal target)
+		(inst jmp :e when-true)))
+	   (t
+	     (let ((start (car header))
+		   (end (cdr header)))
+	       (unless (= start bignum-type)
+		 (inst cmp al-tn start)
+		 (inst jmp :b when-false)) ; was :l
+	       (inst cmp al-tn end)
+	       (if last
+		   (inst jmp less-or-equal target)
+		   (inst jmp :be when-true))))))) ; was :le
+      (emit-label drop-through))))
+
+;; pw -- based on RISC version. Not sure extra hair is needed yet.
+;; difference is that this one uses SUB which overwrites operand
+;; both cmp and sub take 2 cycles so maybe its a wash
+#+nil
+(defun %test-headers (value target not-p function-p headers
+			    &optional (drop-through (gen-label)) al-loaded)
+  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+    (multiple-value-bind
+	(equal less-or-equal when-true when-false)
+	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+	;; it's true and when we know it's false respectively.
+	(if not-p
+	    (values :ne :a drop-through target)
+	    (values :e :na target drop-through))
+      (%test-lowtag value when-false t lowtag al-loaded)
+      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (let ((delta 0))
+	(do ((remaining headers (cdr remaining)))
+	    ((null remaining))
+	  (let ((header (car remaining))
+		(last (null (cdr remaining))))
+	    (cond
+	      ((atom header)
+	       (inst sub al-tn (- header delta))
+	       (setf delta header)
+	       (if last
+		   (inst jmp equal target)
+		   (inst jmp :e when-true)))
+	      (t
+	       (let ((start (car header))
+		     (end (cdr header)))
+		 (unless (= start bignum-type)
+		   (inst sub al-tn (- start delta))
+		   (setf delta start)
+		   (inst jmp :l when-false))
+		 (inst sub al-tn (- end delta))
+		 (setf delta end)
+		 (if last
+		     (inst jmp less-or-equal target)
+		     (inst jmp :le when-true))))))))
+      (emit-label drop-through))))
+
+
+;;;; Type checking and testing:
+
+(define-vop (check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 0)) rax)
+  (:ignore rax)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
+  (:ignore rax)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+;;; Simpler VOP that don't need a temporary register.
+(define-vop (simple-check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)
+		    :load-if (not (and (sc-is value any-reg descriptor-reg)
+				       (sc-is result control-stack)))))
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (simple-type-predicate)
+  (:args (value :scs (any-reg descriptor-reg control-stack)))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value err-lab t ,@type-codes)
+		   (move result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+(defmacro def-simple-type-vops (pred-name check-name ptype error-code
+					  &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name simple-type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name simple-check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value err-lab t ,@type-codes)
+		   (move result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (compile eval)
+
+(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+  even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+  list-pointer-type)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+  instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+  object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex object-not-complex-error
+  complex-type complex-single-float-type complex-double-float-type
+  #+long-float complex-long-float-type)
+
+(def-type-vops complex-rational-p check-complex-rational nil
+  object-not-complex-rational-error complex-type)
+
+(def-type-vops complex-float-p check-complex-float nil
+  object-not-complex-float-error
+  complex-single-float-type complex-double-float-type
+  #+long-float complex-long-float-type)
+
+(def-type-vops complex-single-float-p check-complex-single-float
+  complex-single-float object-not-complex-single-float-error
+  complex-single-float-type)
+
+(def-type-vops complex-double-float-p check-complex-double-float
+  complex-double-float object-not-complex-double-float-error
+  complex-double-float-type)
+
+#+long-float
+(def-type-vops complex-long-float-p check-complex-long-float
+  complex-long-float object-not-complex-long-float-error
+  complex-long-float-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error double-float-type)
+
+#+long-float
+(def-type-vops long-float-p check-long-float long-float
+  object-not-long-float-error long-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-signed-byte-8-p
+  check-simple-array-signed-byte-8
+  simple-array-signed-byte-8
+  object-not-simple-array-signed-byte-8-error
+  simple-array-signed-byte-8-type)
+
+(def-type-vops simple-array-signed-byte-16-p
+  check-simple-array-signed-byte-16
+  simple-array-signed-byte-16
+  object-not-simple-array-signed-byte-16-error
+  simple-array-signed-byte-16-type)
+
+(def-type-vops simple-array-signed-byte-30-p
+  check-simple-array-signed-byte-30
+  simple-array-signed-byte-30
+  object-not-simple-array-signed-byte-30-error
+  simple-array-signed-byte-30-type)
+
+(def-type-vops simple-array-signed-byte-32-p
+  check-simple-array-signed-byte-32
+  simple-array-signed-byte-32
+  object-not-simple-array-signed-byte-32-error
+  simple-array-signed-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  simple-array-double-float-type)
+
+#+long-float
+(def-type-vops simple-array-long-float-p check-simple-array-long-float
+  simple-array-long-float object-not-simple-array-long-float-error
+  simple-array-long-float-type)
+
+(def-type-vops simple-array-complex-single-float-p
+  check-simple-array-complex-single-float
+  simple-array-complex-single-float
+  object-not-simple-array-complex-single-float-error
+  simple-array-complex-single-float-type)
+
+(def-type-vops simple-array-complex-double-float-p
+  check-simple-array-complex-double-float
+  simple-array-complex-double-float
+  object-not-simple-array-complex-double-float-error
+  simple-array-complex-double-float-type)
+
+#+long-float
+(def-type-vops simple-array-complex-long-float-p
+  check-simple-array-complex-long-float
+  simple-array-complex-long-float
+  object-not-simple-array-complex-long-float-error
+  simple-array-complex-long-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  #-gencgc 0 #+gencgc scavenger-hook-type)
+
+(def-type-vops code-component-p nil nil nil
+  code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+  fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  simple-array-type complex-string-type complex-bit-vector-type
+  complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+  object-not-function-or-symbol-error
+  function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  simple-string-type complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  simple-string-type simple-bit-vector-type simple-vector-type
+  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+  simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
+  simple-array-complex-single-float-type
+  simple-array-complex-double-float-type
+  #+long-float simple-array-complex-long-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
+  simple-array-complex-single-float-type
+  simple-array-complex-double-float-type
+  #+long-float simple-array-complex-long-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+  simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
+  simple-array-complex-single-float-type
+  simple-array-complex-double-float-type
+  #+long-float simple-array-complex-long-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type
+  complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  even-fixnum-type odd-fixnum-type bignum-type ratio-type
+  single-float-type double-float-type #+long-float long-float-type complex-type
+  complex-single-float-type complex-double-float-type
+  #+long-float complex-long-float-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  single-float-type double-float-type #+long-float long-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type
+  single-float-type double-float-type #+long-float long-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+;; need to look at this for large fixnum
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (multiple-value-bind
+	(yep nope)
+	(if not-p
+	    (values not-target target)
+	    (values target not-target))
+      (generate-fixnum-test value)
+      (inst jmp :e yep)
+      (move rax-tn value)
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      (loadw rax-tn value 0 other-pointer-type)
+      (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp (if not-p :ne :e) target))
+    NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((nope (generate-error-code vop
+				     object-not-signed-byte-32-error
+				     value)))
+      (generate-fixnum-test value)
+      (inst jmp :e yep)
+      (move rax-tn value)
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      (loadw rax-tn value 0 other-pointer-type)
+      (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp :ne nope))
+    YEP
+    (move result value)))
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+;; Need to look at this for big fixnums
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label))
+	  (single-word (gen-label))
+	  (fixnum (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	;; Is it a fixnum?
+	(generate-fixnum-test value)
+	(move rax-tn value)
+	(inst jmp :e fixnum)
+
+	;; If not, is it an other pointer?
+	(inst and al-tn lowtag-mask)
+	(inst cmp al-tn other-pointer-type)
+	(inst jmp :ne nope)
+	;; Get the header.
+	(loadw rax-tn value 0 other-pointer-type)
+	;; Is it one?
+	(inst cmp rax-tn (+ (ash 1 type-bits) bignum-type))
+	(inst jmp :e single-word)
+	;; If it's other than two, we can't be an (unsigned-byte 32)
+	(inst cmp rax-tn (+ (ash 2 type-bits) bignum-type))
+	(inst jmp :ne nope)
+	;; Get the second digit.
+	(loadw rax-tn value (1+ bignum-digits-offset) other-pointer-type)
+	;; All zeros, its an (unsigned-byte 32).
+	(inst or rax-tn rax-tn)
+	(inst jmp :z yep)
+	(inst jmp nope)
+	
+	(emit-label single-word)
+	;; Get the single digit.
+	(loadw rax-tn value bignum-digits-offset other-pointer-type)
+
+	;; positive implies (unsigned-byte 32).
+	(emit-label fixnum)
+	(inst or rax-tn rax-tn)
+	(inst jmp (if not-p :s :ns) target)
+
+	(emit-label not-target)))))
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((nope
+	   (generate-error-code vop object-not-unsigned-byte-32-error value))
+	  (yep (gen-label))
+	  (fixnum (gen-label))
+	  (single-word (gen-label)))
+
+      ;; Is it a fixnum?
+      (generate-fixnum-test value)
+      (move rax-tn value)
+      (inst jmp :e fixnum)
+
+      ;; If not, is it an other pointer?
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      ;; Get the header.
+      (loadw rax-tn value 0 other-pointer-type)
+      ;; Is it one?
+      (inst cmp rax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp :e single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst cmp rax-tn (+ (ash 2 type-bits) bignum-type))
+      (inst jmp :ne nope)
+      ;; Get the second digit.
+      (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst or rax-tn rax-tn)
+      (inst jmp :z yep)
+      (inst jmp nope)
+	
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw rax-tn value bignum-digits-offset other-pointer-type)
+
+      ;; positive implies (unsigned-byte 32).
+      (emit-label fixnum)
+      (inst or rax-tn rax-tn)
+      (inst jmp :s nope)
+
+      (emit-label yep)
+      (move result value))))
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (let ((is-symbol-label (if not-p drop-thru target)))
+      (inst cmp value nil-value)
+      (inst jmp :e is-symbol-label)
+      (test-type value target not-p symbol-header-type))
+    DROP-THRU))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (let ((error (generate-error-code vop object-not-symbol-error value)))
+      (inst cmp value nil-value)
+      (inst jmp :e drop-thru)
+      (test-type value error t symbol-header-type))
+    DROP-THRU
+    (move result value)))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (let ((is-not-cons-label (if not-p target drop-thru)))
+      (inst cmp value nil-value)
+      (inst jmp :e is-not-cons-label)
+      (test-type value target not-p list-pointer-type))
+    DROP-THRU))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst cmp value nil-value)
+      (inst jmp :e error)
+      (test-type value error t list-pointer-type)
+      (move result value))))
diff --git a/compiler/amd64/values.lisp b/compiler/amd64/values.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3808bdd50a68d0d3bd195db90912ef5ec9b20df5
--- /dev/null
+++ b/compiler/amd64/values.lisp
@@ -0,0 +1,135 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/values.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; %more-arg-values by Douglas Thomas Crosher, March 1996.
+;;; Enhancements/debugging by Douglas T. Crosher 1996.
+
+(in-package :amd64)
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move rsp-tn ptr)))
+
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results.  It is assumed that the Vals are wired to the standard
+;;; argument locations.  Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random.  We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+;;;
+(define-vop (push-values)
+  (:args (vals :more t))
+  (:temporary (:sc unsigned-reg :to (:result 0) :target start) temp)
+  (:results (start) (count))
+  (:info nvals)
+  (:generator 20
+    (move temp rsp-tn)			; WARN pointing 1 below
+    (do ((val vals (tn-ref-across val)))
+	((null val))
+      (inst push (tn-ref-tn val)))
+    (move start temp)
+    (inst mov count (fixnumize nvals))))
+
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+;;;
+(define-vop (values-list)
+  (:args (arg :scs (descriptor-reg) :target list))
+  (:arg-types list)
+  (:policy :fast-safe)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
+  (:temporary (:sc descriptor-reg :to (:result 1)) nil-temp)
+  (:temporary (:sc unsigned-reg :offset rax-offset :to (:result 1)) rax)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (move list arg)
+    (move start rsp-tn)			; WARN pointing 1 below
+    (inst mov nil-temp nil-value)
+
+    LOOP
+    (inst cmp list nil-temp)
+    (inst jmp :e done)
+    (pushw list cons-car-slot list-pointer-type)
+    (loadw list list cons-cdr-slot list-pointer-type)
+    (inst mov rax list)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn list-pointer-type)
+    (inst jmp :e loop)
+    (error-call vop bogus-argument-to-values-list-error list)
+
+    DONE
+    (inst mov count start)		; start is high address
+    (inst sub count rsp-tn)))		; stackp is low address
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+;;; Accepts a context as produced by more-arg-context; points to the first
+;;; value on the stack, not 4 bytes above as in other contexts.
+;;;
+;;; Return a context that is 4 bytes above the first value, suitable for
+;;; defining a new stack frame.
+;;;
+;;;
+(define-vop (%more-arg-values)
+  (:args (context :scs (descriptor-reg any-reg) :target src)
+         (skip :scs (any-reg immediate))
+         (num :scs (any-reg) :target count))
+  (:arg-types * positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg :offset rsi-offset :from (:argument 0)) src)
+  (:temporary (:sc descriptor-reg :offset rax-offset) temp)
+  (:temporary (:sc unsigned-reg :offset rcx-offset) temp1)
+  (:results (start :scs (any-reg))
+            (count :scs (any-reg)))
+  (:generator 20
+    (sc-case skip
+      (immediate
+       (cond ((zerop (tn-value skip))
+	      (move src context)
+	      (move count num))
+	     (t
+	      (inst lea src (make-ea :qword :base context
+				     :disp (- (* (tn-value skip) word-bytes))))
+	      (move count num)
+	      (inst sub count (* (tn-value skip) word-bytes)))))
+      
+      (any-reg
+       (move src context)
+       (inst sub src skip)
+       (move count num)
+       (inst sub count skip)))
+    
+    (move temp1 count)
+    (inst mov start rsp-tn)
+    (inst jecxz done)  ; check for 0 count?
+    
+    (inst shr temp1 word-shift) ; convert the fixnum to a count.
+    
+    (inst std) ; move down the stack as more value are copied to the bottom.
+    LOOP
+    (inst lods temp)
+    (inst push temp)
+    (inst loop loop)
+    
+    DONE))
+ 
diff --git a/compiler/amd64/vm.lisp b/compiler/amd64/vm.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2066c7a29f0e2ddd9a49f2c54485b9b0eb866024
--- /dev/null
+++ b/compiler/amd64/vm.lisp
@@ -0,0 +1,501 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/vm.lisp,v 1.1 2004/05/24 22:35:01 cwang Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition noise for amd64.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996, 1997, 1998.
+;;;
+
+(in-package :amd64)
+
+
+;;;; Register specs
+
+(eval-when (compile eval)
+
+(defmacro defreg (name offset size)
+  (let ((offset-sym (symbolicate name "-OFFSET"))
+	(names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+    `(progn
+       (eval-when (compile eval load)
+	 (defconstant ,offset-sym ,offset))
+       (setf (svref ,names-vector ,offset-sym) ,(symbol-name name)))))
+
+(defmacro defregset (name &rest regs)
+  `(eval-when (compile eval load)
+     (defconstant ,name
+       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
+
+); eval-when 
+
+;;; 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.
+;;; 
+(eval-when (compile load eval)
+  (defvar *byte-register-names* (make-array 8 :initial-element nil)))
+;;;
+(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.
+;;;
+(eval-when (compile load eval)
+  (defvar *word-register-names* (make-array 16 :initial-element nil)))
+;;;
+(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.
+;;;
+(eval-when (compile load eval)
+  (defvar *dword-register-names* (make-array 16 :initial-element nil)))
+;;;
+(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)
+
+;;; Quad Word registers.
+;;;
+(eval-when (compile load eval)
+  (defvar *qword-register-names* (make-array 16 :initial-element nil)))
+;;;
+(defreg rax 0 :qword)
+(defreg rcx 2 :qword)
+(defreg rdx 4 :qword)
+(defreg rbx 6 :qword)
+(defreg rsp 8 :qword)
+(defreg rbp 10 :qword)
+(defreg rsi 12 :qword)
+(defreg rdi 14 :qword)
+;;;
+(defregset qword-regs rax rcx rdx rbx rsi rdi)
+
+;;; added by jrd
+(eval-when (compile load eval)
+  (defvar *float-register-names* (make-array 8 :initial-element nil)))
+(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)
+
+
+;;;; 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, dwords or qwords to take two.  We
+;;; don't need to tell the difference between words, dwords, and qwords, because
+;;; you can't put two words in a dword.
+
+(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.
+;;; (define-storage-base float-registers :finite :size 1)
+(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.
+
+;;;
+;;; 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 `(defconstant ,constant-name ,index))
+	  (forms `(export ',constant-name))
+	  (incf index))))
+    `(progn
+       ,@(forms))))
+
+(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)
+  (base-char-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.
+
+  ;; We don't have to distinguish between descriptor and
+  ;; non-descriptor registers, because of the conservative GC.
+  ;; Therefore, we only use different scs 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 #.qword-regs
+	   :element-size 2
+;	   :reserve-locations (#.rax-offset)
+	   :constant-scs (immediate)
+	   :save-p t
+	   :alternate-scs (control-stack))
+
+  ;; Pointer descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+		  :locations #.qword-regs
+		  :element-size 2
+;		  :reserve-locations (#.rax-offset)
+		  :constant-scs (constant immediate)
+		  :save-p t
+		  :alternate-scs (control-stack))
+
+  ;; Non-Descriptor characters
+  (base-char-reg registers
+		 :locations #.byte-regs
+		 :reserve-locations (#.ah-offset #.al-offset)
+		 :constant-scs (immediate)
+		 :save-p t
+		 :alternate-scs (base-char-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+  (sap-reg registers
+	   :locations #.qword-regs
+	   :element-size 2
+;	   :reserve-locations (#.rax-offset)
+	   :constant-scs (immediate)
+	   :save-p t
+	   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+	      :locations #.qword-regs
+	      :element-size 2
+;	      :reserve-locations (#.rax-offset)
+	      :constant-scs (immediate)
+	      :save-p t
+	      :alternate-scs (signed-stack))
+  (unsigned-reg registers
+		:locations #.qword-regs
+		:element-size 2
+;		:reserve-locations (#.rax-offset)
+		:constant-scs (immediate)
+		:save-p t
+		:alternate-scs (unsigned-stack))
+
+  ;; Random objects that must not be seen by GC.  Used only as temporaries.
+  (dword-reg registers
+	     :locations #.dword-regs
+	     :element-size 2
+	     )
+  (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)
+	    )
+
+  ;; **** Things 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 vm:catch-block-size)
+  )
+
+(eval-when (compile load eval)
+
+(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack))
+(defconstant word-sc-names '(word-reg))
+(defconstant dword-sc-names '(dword-reg))
+(defconstant qword-sc-names
+  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
+    signed-stack unsigned-stack sap-stack single-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.
+(defconstant float-sc-names '(single-reg))
+(defconstant double-sc-names '(double-reg double-stack))
+)
+
+
+
+;;;; Random TNs for the various registers.
+
+(eval-when (compile eval)
+  (defmacro def-random-reg-tns (sc-name &rest reg-names)
+    (collect ((forms))
+      (dolist (reg-name reg-names)
+	(let ((reg-tn-name (symbolicate reg-name "-TN"))
+	      (reg-offset-name (symbolicate reg-name "-OFFSET")))
+	  ;;(forms `(export ',reg-tn-name))
+	  (forms `(defparameter ,reg-tn-name
+		    (make-random-tn :kind :normal
+				    :sc (sc-or-lose ',sc-name)
+				    :offset ,reg-offset-name)))))
+      `(progn ,@(forms)))))
+
+(def-random-reg-tns unsigned-reg rax rbx rcx rdx rbp rsp rdi rsi)
+(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
+(def-random-reg-tns word-reg ax bx cx dx bp sp di si)
+(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh)
+
+;; added by jrd
+(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+;; 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.
+
+
+;;; Immediate-Constant-SC
+;;;
+;;; 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 fixnum system-area-pointer character)
+     (sc-number-or-lose 'immediate *backend*))
+    (bignum
+     ;; during cross compilation, a fixnum in 64-bit may be a bignum in 32-bit
+     (when (<= target-most-negative-fixnum value target-most-positive-fixnum)
+       (sc-number-or-lose 'immediate *backend*)))
+    (symbol
+     (when (static-symbol-p value)
+       (sc-number-or-lose 'immediate *backend*)))
+    (single-float
+     (when (or (eql value 0f0) (eql value 1f0))
+       (sc-number-or-lose 'fp-constant *backend*)))
+    (double-float
+     (when (or (eql value 0d0) (eql value 1d0))
+       (sc-number-or-lose 'fp-constant *backend*)))
+    #+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 *backend*)))))
+
+
+;;;; Function Call Parameters
+
+;;; Offsets of special stack frame locations
+(defconstant ocfp-save-offset 0)
+(defconstant return-pc-save-offset 1)
+(defconstant code-save-offset 2)
+
+;;; names of these things seem to have changed.  these aliases by jrd
+(defconstant lra-save-offset return-pc-save-offset)
+
+(defconstant cfp-offset rbp-offset)	; pfw - needed by stuff in /code
+					; related to sigcontext stuff
+
+;;; The number of arguments/return values passed in registers.
+;;;
+(defconstant register-arg-count 3)
+
+;;; Names, Offsets, and TNs to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(rdx rdi rsi))
+(defregset register-arg-offsets rdx rdi rsi)
+(defparameter register-arg-tns (list rdx-tn rdi-tn rsi-tn))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(export 'single-value-return-byte-offset)
+(defconstant single-value-return-byte-offset 2)
+
+
+;;; LOCATION-PRINT-NAME  --  Interface
+;;;
+;;;    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*)
+			      ((member sc-name qword-sc-names)
+			       *qword-register-names*))))
+	 (or (and name-vec
+		  (< -1 offset (length name-vec))
+		  (svref name-vec offset))
+	     (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name))))
+      (float-registers (format nil "FR~D" offset))
+      (stack (format nil "S~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed")
+      (noise (symbol-name (sc-name sc))))))
+
+;; low 8-bit registers
+(defun 64-bit-to-8-bit-tn (tn)
+  (case (tn-offset tn)
+    (#.rax-offset al-tn)
+    (#.rbx-offset bl-tn)
+    (#.rcx-offset cl-tn)
+    (#.rdx-offset dl-tn)))
+
+(defun 64-bit-to-16-bit-tn (tn)
+  (ecase (tn-offset tn)
+    (#.rax-offset ax-tn)
+    (#.rbx-offset bx-tn)
+    (#.rcx-offset cx-tn)
+    (#.rdx-offset dx-tn)
+    (#.rsi-offset si-tn)
+    (#.rdi-offset di-tn)
+    (#.rbp-offset bp-tn)
+    (#.rsp-offset sp-tn)))
+
+(defun 64-bit-to-32-bit-tn (qword-tn)
+  (ecase (tn-offset qword-tn)
+    (#.rax-offset eax-tn)
+    (#.rbx-offset ebx-tn)
+    (#.rcx-offset ecx-tn)
+    (#.rdx-offset edx-tn)
+    (#.rsi-offset esi-tn)
+    (#.rdi-offset edi-tn)))