CMUCL commit: amd64-dd-branch src (21 files)

Raymond Toy rtoy at common-lisp.net
Mon Nov 2 15:29:47 CET 2009


    Date: Monday, November 2, 2009 @ 09:29:47
  Author: rtoy
    Path: /project/cmucl/cvsroot/src
     Tag: amd64-dd-branch

Modified: code/pred.lisp code/sap.lisp code/unix-glibc2.lisp
          compiler/amd64/float.lisp compiler/amd64/parms.lisp
          compiler/amd64/type-vops.lisp compiler/amd64/vm.lisp
          compiler/float-tran.lisp lisp/Config.amd64 lisp/Linux-os.c
          lisp/Linux-os.h lisp/amd64-arch.c lisp/amd64-assem.S
          lisp/amd64-lispregs.h lisp/backtrace.c lisp/gencgc.c lisp/gencgc.h
          lisp/globals.h lisp/interrupt.c tools/clean-target.sh
          tools/cross-scripts/cross-x86-amd64.lisp

(Oops.  Previous checkin went to wrong branch.  Here is the commit
log, again.)

This large checkin brings the amd64 port up-to-date with the current
sources.  No real attempt has been made to make it work, but the
cross-compile does create a kernel.core, and the C code compiles (on
openSuSE 10.3).  The resulting kernel.core does not yet work.

Use cross-x86-amd64.lisp as the cross-compile script.  This is
intended to be cross-compiled using the 20a release for Linux, and
only supports x87.  The sse2 support has not be ported yet.

tools/cross-scripts/cross-x86-amd64.lisp:
o Update cross-compile with some missing constants, and frob new
  symbols.

tools/clean-target.sh:
o Remove amd64f files too.

code/pred.lisp:
o Define predicates for double-doubles for bootstrapping to work
  around recursive known function problems with these predicates.

code/sap.lisp:
o Define int-sap with (unsigned-byte 64) type declaration.  (May not
  be needed?)

code/unix-glibc2.lisp:
o Build fails defining map_failed to (int-sap -1).  Just hard-wire to
  0 for now so we can build.

compiler/float-tran.lisp:
o Add missing conditional for %complex-double-double-float.

compiler/amd64/float.lisp:
o Merge double-double support for amd64.  Not really tested yet.

compiler/amd64/parms.lisp:
o Update to match x86 build.  In particular, get the space address
  correct and update the static symbols.

compiler/amd64/type-vops.lisp:
o DYLAN-FUNCTION-HEADER-TYPE no longer exists.

compiler/amd64/vm.lisp:
o Add double-double storage classes and register definitions.

lisp/Config.amd64:
o Bring in line with Config.x86 and friends.

lisp/Linux-os.c:
o Bring amd64 code up-to-date with x86/linux code.

lisp/Linux-os.h
o Need to include sys/ucontext.h to get ucontext defined.  (Why?)
o Also define __USE_GNU so we get the register offsets in the ucontext
  defined.  (Why?)

lisp/amd64-arch.c:
o Change struct sigcontext to os_context_t.
o Use SC_PC instead of context->sc_pc.
o Merge some changes in from x86 version, like SC_EFLAGS.  May need
  more work.

lisp/amd64-assem.s:
o Use rbx instead of ebx for jmp.

lisp/amd64-lispregs.h:
o Define SC_REG, SC_PC, SC_SP using the new x86 style.

lisp/backtrace.c:
o Remove inline assembly for now until I figure out what the amd64
  version should be.

lisp/gencgc.c:
o Conditionalize out weak hash table support for now.

lisp/gencgc.h:
o Set PAGE_SIZE for amd64.  (Is 4096 right?)

lisp/globals.h:
o Export current_dynamic_space_free_pointer and
  current_auto_gc_trigger like for x86.


------------------------------------------+
 code/pred.lisp                           |   35 +
 code/sap.lisp                            |    8 
 code/unix-glibc2.lisp                    |    4 
 compiler/amd64/float.lisp                |  830 +++++++++++++++++++++++++++--
 compiler/amd64/parms.lisp                |   78 +-
 compiler/amd64/type-vops.lisp            |    4 
 compiler/amd64/vm.lisp                   |   23 
 compiler/float-tran.lisp                 |    4 
 lisp/Config.amd64                        |   43 +
 lisp/Linux-os.c                          |   79 ++
 lisp/Linux-os.h                          |    5 
 lisp/amd64-arch.c                        |   83 +-
 lisp/amd64-assem.S                       |    4 
 lisp/amd64-lispregs.h                    |    8 
 lisp/backtrace.c                         |   10 
 lisp/gencgc.c                            |    9 
 lisp/gencgc.h                            |    4 
 lisp/globals.h                           |    4 
 lisp/interrupt.c                         |    4 
 tools/clean-target.sh                    |    1 
 tools/cross-scripts/cross-x86-amd64.lisp |   75 +-
 21 files changed, 1122 insertions(+), 193 deletions(-)


Index: src/code/pred.lisp
diff -u src/code/pred.lisp:1.60 src/code/pred.lisp:1.60.24.1
--- src/code/pred.lisp:1.60	Fri Jun 30 14:41:22 2006
+++ src/code/pred.lisp	Mon Nov  2 09:29:46 2009
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/pred.lisp,v 1.60 2006-06-30 18:41:22 rtoy Rel $")
+  "$Header: /project/cmucl/cvsroot/src/code/pred.lisp,v 1.60.24.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -127,6 +127,39 @@
 		    primitive-predicates))))
   (frob))
 
+;;; FIXME: The next four functions are for bootstrapping double-double
+;;; for AMD64.  This works around the recursive known function problem
+;;; when compiling the predicate functions for double-double.  This
+;;; should be eventually removed when double-double float support for
+;;; the compiler is working.
+(defun double-double-float-p (x)
+  (let* ((addr (kernel:get-lisp-obj-address x))
+	 (ptr (logandc2 addr #x7)))
+    (when (= 1 (logand addr 1))
+      (= 26 (ldb (byte 8 0)
+		 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun complex-double-double-float-p (x)
+  (let* ((addr (kernel:get-lisp-obj-address x))
+	 (ptr (logandc2 addr #x7)))
+    (when (= 1 (logand addr 1))
+      (= 42 (ldb (byte 8 0)
+		 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun simple-array-double-double-float-p (x)
+  (let* ((addr (kernel:get-lisp-obj-address x))
+	 (ptr (logandc2 addr #x7)))
+    (when (= 1 (logand addr 1))
+      (= 106 (ldb (byte 8 0)
+		  (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun simple-array-complex-double-double-float-p (x)
+  (let* ((addr (kernel:get-lisp-obj-address x))
+	 (ptr (logandc2 addr #x7)))
+    (when (= 1 (logand addr 1))
+      (= 118 (ldb (byte 8 0)
+		  (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
 
 ;;;; TYPE-OF -- public.
 ;;;
Index: src/code/sap.lisp
diff -u src/code/sap.lisp:1.19 src/code/sap.lisp:1.19.22.1
--- src/code/sap.lisp:1.19	Thu Jan  3 06:41:52 2008
+++ src/code/sap.lisp	Mon Nov  2 09:29:46 2009
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/sap.lisp,v 1.19 2008-01-03 11:41:52 cshapiro Rel $")
+  "$Header: /project/cmucl/cvsroot/src/code/sap.lisp,v 1.19.22.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -77,10 +77,16 @@
   (declare (type system-area-pointer sap))
   (sap-int sap))
 
+#-amd64
 (defun int-sap (int)
   "Converts an integer into a System Area Pointer."
   (declare (type (unsigned-byte #-alpha #.vm:word-bits #+alpha 64) int))
   (int-sap int))
+#+amd64
+(defun int-sap (int)
+  "Converts an integer into a System Area Pointer."
+  (declare (type (unsigned-byte 64) int))
+  (int-sap int))
 
 (defun sap-ref-8 (sap offset)
   "Returns the 8-bit byte at OFFSET bytes from SAP."
Index: src/code/unix-glibc2.lisp
diff -u src/code/unix-glibc2.lisp:1.49 src/code/unix-glibc2.lisp:1.49.2.1
--- src/code/unix-glibc2.lisp:1.49	Thu Oct 15 10:07:35 2009
+++ src/code/unix-glibc2.lisp	Mon Nov  2 09:29:46 2009
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.49 2009-10-15 14:07:35 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.49.2.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -265,7 +265,7 @@
 (defconstant ms_invalidate 2)
 
 ;; The return value from mmap that means mmap failed.
-(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
+(defconstant map_failed (int-sap #+amd64 0 #-amd64 (1- (ash 1 vm:word-bits))))
 
 (defun unix-mmap (addr length prot flags fd offset)
   (declare (type (or null system-area-pointer) addr)
Index: src/compiler/amd64/float.lisp
diff -u src/compiler/amd64/float.lisp:1.2 src/compiler/amd64/float.lisp:1.2.36.1
--- src/compiler/amd64/float.lisp:1.2	Wed Jul 14 16:57:31 2004
+++ src/compiler/amd64/float.lisp	Mon Nov  2 09:29:46 2009
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group at cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.2 2004-07-14 20:57:31 cwang Rel $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.2.36.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -61,7 +61,20 @@
     (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)))
+    (ea-for-xf-desc tn vm:complex-long-float-imag-slot))
+  #+double-double
+  (defun ea-for-cddf-real-hi-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-real-hi-slot))
+  #+double-double
+  (defun ea-for-cddf-real-lo-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-real-lo-slot))
+  #+double-double
+  (defun ea-for-cddf-imag-hi-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-imag-hi-slot))
+  #+double-double
+  (defun ea-for-cddf-imag-lo-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-imag-lo-slot))
+  )
 
 (macrolet ((ea-for-xf-stack (tn kind)
 	     `(make-ea
@@ -86,7 +99,13 @@
 				   (:single 1)
 				   (:double 2)
 				   (:long 3))
-				 (ecase ,slot (:real 1) (:imag 2))))
+				 (ecase ,slot
+				   (:real 1)
+				   (:imag 2)
+				   (:real-hi 1)
+				   (:real-lo 2)
+				   (:imag-hi 3)
+				   (:imag-lo 4))))
 			 vm:word-bytes)))))
   (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
     (ea-for-cxf-stack tn :single :real base))
@@ -103,7 +122,21 @@
     (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)))
+    (ea-for-cxf-stack tn :long :imag base))
+
+  #+double-double
+  (defun ea-for-cddf-real-hi-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :real-hi base))
+  #+double-double
+  (defun ea-for-cddf-real-lo-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :real-lo base))
+  #+double-double
+  (defun ea-for-cddf-imag-hi-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :imag-hi base))
+  #+double-double
+  (defun ea-for-cddf-imag-lo-stack (tn &optional (base rbp-tn))
+    (ea-for-cxf-stack tn :double :imag-lo 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
@@ -236,6 +269,21 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
 		  :offset (1+ (tn-offset x))))
 
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 1 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 3 (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))
@@ -308,6 +356,49 @@
     (store-long-float (ea-for-clf-imag-stack y))
     (inst fxch imag-tn)))
 
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+  ((complex-double-double-stack) (complex-double-double-reg))
+  (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+    (with-empty-tn at fp-top(real-tn)
+      (inst fldd (ea-for-cddf-real-hi-stack x))))
+  (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+    (with-empty-tn at fp-top(real-tn)
+      (inst fldd (ea-for-cddf-real-lo-stack x))))
+  (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+    (with-empty-tn at fp-top(imag-tn)
+      (inst fldd (ea-for-cddf-imag-hi-stack x))))
+  (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+    (with-empty-tn at fp-top(imag-tn)
+      (inst fldd (ea-for-cddf-imag-lo-stack x)))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+  ((complex-double-double-reg) (complex-double-double-stack))
+  ;; FIXME: These may not be right!!!!
+  (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cddf-real-hi-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cddf-real-hi-stack y))
+	   (inst fxch real-tn))))
+  (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cddf-real-lo-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cddf-real-lo-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cddf-imag-hi-stack y))
+    (inst fxch imag-tn))
+  (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cddf-imag-lo-stack y))
+    (inst fxch imag-tn)))
+)
 
 ;;;; Move VOPs:
 
@@ -546,11 +637,12 @@
 (define-vop (move-from-complex-long)
   (:args (x :scs (complex-long-reg) :to :save))
   (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg :offset r11-offset) temp)
   (: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)
+			       vm:complex-long-float-size temp node)
        (let ((real-tn (complex-long-reg-real-tn x)))
 	 (with-tn at fp-top(real-tn)
 	   (store-long-float (ea-for-clf-real-desc y))))
@@ -561,6 +653,32 @@
 (define-move-vop move-from-complex-long :move
   (complex-long-reg) (descriptor-reg))
 
+#+double-double
+(define-vop (move-from-complex-double-double)
+  (:args (x :scs (complex-double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg :offset r11-offset) temp)
+  (:node-var node)
+  (:note "complex double-double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm::complex-double-double-float-type
+			       vm::complex-double-double-float-size temp node)
+       (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	 (with-tn at fp-top(real-tn)
+	   (inst fstd (ea-for-cddf-real-hi-desc y))))
+       (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	 (with-tn at fp-top(real-tn)
+	   (inst fstd (ea-for-cddf-real-lo-desc y))))
+       (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	 (with-tn at fp-top(imag-tn)
+	   (inst fstd (ea-for-cddf-imag-hi-desc y))))
+       (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	 (with-tn at fp-top(imag-tn)
+	   (inst fstd (ea-for-cddf-imag-lo-desc y)))))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+  (complex-double-double-reg) (descriptor-reg))
 ;;;
 ;;; Move from a descriptor to a complex float register
 ;;;
@@ -728,14 +846,93 @@
   (frob move-complex-long-float-argument
 	complex-long-reg complex-long-stack :long))
 
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+  (:args (x :scs (complex-double-double-reg) :target y)
+	 (fp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+  (:results (y))
+  (:note "complex double-double-float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	       (y-real (complex-double-double-reg-real-hi-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-real (complex-double-double-reg-real-lo-tn x))
+	       (y-real (complex-double-double-reg-real-lo-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-double-reg-imag-hi-tn x))
+	       (y-imag (complex-double-double-reg-imag-hi-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))
+	 (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	       (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))))
+      (complex-double-double-stack
+       (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	 (cond ((zerop (tn-offset real-tn))
+		(inst fstd (ea-for-cddf-real-hi-stack y fp)))
+	       (t
+		(inst fxch real-tn)
+		(inst fstd (ea-for-cddf-real-hi-stack y fp))
+		(inst fxch real-tn))))
+       (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	 (cond ((zerop (tn-offset real-tn))
+		(inst fstd (ea-for-cddf-real-lo-stack y fp)))
+	       (t
+		(inst fxch real-tn)
+		(inst fstd (ea-for-cddf-real-lo-stack y fp))
+		(inst fxch real-tn))))
+       (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	 (inst fxch imag-tn)
+	 (inst fstd (ea-for-cddf-imag-hi-stack y fp))
+	 (inst fxch imag-tn))
+       (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	 (inst fxch imag-tn)
+	 (inst fstd (ea-for-cddf-imag-lo-stack y fp))
+	 (inst fxch imag-tn))))
+    ))
+
+#+double-double
+(define-move-vop move-complex-double-double-float-argument :move-argument
+  (complex-double-double-reg descriptor-reg) (complex-double-double-reg))
+
 (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)
+   #+double-double double-double-reg
+   complex-single-reg complex-double-reg #+long-float complex-long-reg
+   #+double-double complex-double-double-reg)
   (descriptor-reg))
 
 
 ;;;; Arithmetic VOPs:
 
+
+;; Save the top-of-stack to memory and reload it.  This ensures that
+;; the stack top has the desired precision.
+(defmacro save-and-reload-tos (tmp)
+  `(progn
+     (inst fstp ,tmp)
+     (inst fld ,tmp)))
+
 ;;; dtc: The floating point arithmetic vops.
 ;;; 
 ;;; Note: Although these can accept x and y on the stack or pointed to
@@ -1210,6 +1407,12 @@
 	(= (long-float-high-bits x) (long-float-high-bits y))
 	(= (long-float-exp-bits x) (long-float-exp-bits y))))
 
+#+double-double
+(deftransform eql ((x y) (double-double-float double-double-float))
+  '(and (eql (double-double-hi x) (double-double-hi y))
+	(eql (double-double-lo x) (double-double-lo y))))
+
+
 (define-vop (=/float)
   (:args (x) (y))
   (:temporary (:sc word-reg :offset rax-offset :from :eval) temp)
@@ -1507,6 +1710,7 @@
   (:save-p :compute-only)
   (:note "inline float comparison")
   (:ignore temp y)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 2
      (note-this-location vop :internal-error)
      (cond
@@ -1532,12 +1736,14 @@
 		  (:translate ,translate)
 		  (:args (x :scs (single-reg)))
 		  (:arg-types single-float (:constant (single-float 0f0 0f0)))
+		  (:guard (not (backend-featurep :sse2)))
 		  (: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)))
+		  (:guard (not (backend-featurep :sse2)))
 		  (:variant ,test))
 		#+long-float
 		(define-vop (,(symbolicate translate "0/LONG-FLOAT")
@@ -1669,11 +1875,41 @@
 		     (with-empty-tn at fp-top(y)
 		       (note-this-location vop :internal-error)
 		       (inst fild x))))))))
+  #+(or)
   (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))
 
+(define-vop (%single-float/signed)
+  (:args (x :scs (signed-stack signed-reg) :target temp))
+  (:temporary (:sc signed-stack) temp)
+  (:temporary (:sc single-stack) sf-temp)
+  (:results (y :scs (single-reg)))
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:policy :fast-safe)
+  (:note "inline float coercion")
+  (:translate %single-float)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (sc-case x
+      (signed-reg
+       (inst mov temp x)
+       (with-empty-tn at fp-top(y)
+	 (note-this-location vop :internal-error)
+	 (inst fild temp)
+	 (inst fstp sf-temp)
+	 (inst fld sf-temp)))
+      (signed-stack
+       (with-empty-tn at fp-top(y)
+	 (note-this-location vop :internal-error)
+	 (inst fild x)
+	 (inst fstp sf-temp)
+	 (inst fld sf-temp))))))
+
+#-sse2
 (macrolet ((frob (name translate to-sc to-type)
 	     `(define-vop (,name)
 		(:args (x :scs (unsigned-reg)))
@@ -1697,6 +1933,27 @@
   #+long-float
   (frob %long-float/unsigned %long-float long-reg long-float))
 
+;;#+(or)
+(define-vop (%single-float/unsigned)
+  (:args (x :scs (unsigned-reg)))
+  (:results (y :scs (single-reg)))
+  (:arg-types unsigned-num)
+  (:result-types single-float)
+  (:policy :fast-safe)
+  (:note "inline float coercion")
+  (:translate %single-float)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 6
+    (inst push 0)
+    (inst push x)
+    (with-empty-tn at fp-top(y)
+      (note-this-location vop :internal-error)
+      (inst fildl (make-ea :dword :base rsp-tn))
+      (inst fstp (make-ea :dword :base rsp-tn))
+      (inst fld (make-ea :dword :base rsp-tn)))
+    (inst add rsp-tn 8)))
+
 ;;; 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)
@@ -1727,6 +1984,7 @@
 		    (inst fst  y)
 		    (inst fxch x))))))))
   
+  #+(or)
   (frob %single-float/double-float %single-float double-reg
 	double-float single-reg single-float)
   #+long-float
@@ -1744,7 +2002,54 @@
   (frob %long-float/double-float %long-float double-reg double-float
 	long-reg long-float))
 
+(define-vop (%single-float/double-float)
+  (:args (x :scs (double-reg) :target y))
+  (:results (y :scs (single-reg)))
+  (:arg-types double-float)
+  (:result-types single-float)
+  (:policy :fast-safe)
+  (:note "inline float coercion")
+  (:translate %single-float)
+  (:temporary (:sc single-stack) sf-temp)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 2
+    (note-this-location vop :internal-error)
+    (cond
+      ((zerop (tn-offset x))
+       (cond
+	 ((zerop (tn-offset y))
+	  ;; x is in ST0, y is also in ST0
+	  (inst fstp sf-temp)
+	  (inst fld sf-temp))
+	 (t
+	  ;; x is in ST0, y is in another reg. not ST0
+	  ;; Save st0 (x) to memory, swap, reload, then swap back.
+	  (inst fst sf-temp)
+	  (inst fxch y)
+	  (fp-pop)
+	  (inst fld sf-temp)
+	  (inst fxch y))))
+      ((zerop (tn-offset y))
+       ;; y is in ST0, x is in another reg. not ST0
+       ;; Swap, save x to memory, reload, swap back
+       (inst fxch x)
+       (inst fstp sf-temp)
+       (inst fld sf-temp)
+       (inst fxch x))
+      (t
+       ;; Neither x or y are in ST0, and they are not in
+       ;; the same reg.
 
+       ;; Get x to st0.  Store it away.  Swap back.  Get y to st0,
+       ;; load.  Swap back.
+       (inst fxch x)
+       (inst fst sf-temp)
+       (inst fxch x)
+       (inst fxch y)
+       (fp-pop)
+       (inst fld sf-temp)
+       (inst fxch y)))))
 
 (macrolet ((frob (trans from-sc from-type round-p)
 	     `(define-vop (,(symbolicate trans "/" from-type))
@@ -1809,6 +2114,7 @@
 	       (:note "inline float truncate")
 	       (:vop-var vop)
 	       (:save-p :compute-only)
+	       (:guard (not (backend-featurep :sse2)))
 	       (:generator 5
 		,@(unless round-p
 		   '((note-this-location vop :internal-error)
@@ -2078,55 +2384,53 @@
 
 ;;;; 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)
+(deftype float-modes () '(unsigned-byte 24))
+(defknown x87-floating-point-modes () float-modes (flushable))
+(defknown ((setf x87-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)
+(define-vop (x87-floating-point-modes)
   (:results (res :scs (unsigned-reg)))
   (:result-types unsigned-num)
-  (:translate floating-point-modes)
+  (:translate x87-floating-point-modes)
   (:policy :fast-safe)
-  (:temporary (:sc unsigned-reg :offset rax-offset :target res
-		   :to :result) rax)
+  (:temporary (:sc unsigned-stack) cw-stack)
+  (:temporary (:sc unsigned-reg :offset eax-offset) sw-reg)
   (: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)))
+   (inst fnstsw)
+   (inst fnstcw cw-stack)
+   (inst and sw-reg #xff)  ; mask exception flags
+   (inst shl sw-reg 16)
+   (inst byte #x66)  ; operand size prefix
+   (inst or sw-reg cw-stack)
+   (inst xor sw-reg #x3f)  ; invert exception mask
+   (move res sw-reg)))
 
-(define-vop (set-floating-point-modes)
+(define-vop (set-x87-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))
+  (:translate (setf x87-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
+  (:temporary (:sc unsigned-stack) cw-stack)
+  (:temporary (:sc byte-reg :offset al-offset) sw-reg)
+  (:temporary (:sc unsigned-reg :offset ecx-offset) old)
+  (:generator 6
+   (inst mov cw-stack new)
+   (inst xor cw-stack #x3f)  ; invert exception mask
+   (inst fnstsw)
+   (inst fldcw cw-stack)  ; always update the control word
+   (inst mov old new)
+   (inst shr old 16)
+   (inst cmp cl-tn sw-reg)  ; compare exception flags
+   (inst jmp :z DONE)  ; skip updating the status word
+   (inst sub rsp-tn 28)
+   (inst fstenv (make-ea :dword :base rsp-tn))
+   (inst mov (make-ea :byte :base rsp-tn :disp 4) cl-tn)
+   (inst fldenv (make-ea :dword :base rsp-tn))
+   (inst add rsp-tn 28)
+   DONE
    (move res new)))
 
 
@@ -2169,7 +2473,9 @@
 
   ;; Quick versions of fsin and fcos that require the argument to be
   ;; within range 2^63.
+  #-sse2
   (frob fsin-quick %sin-quick fsin)
+  #-sse2
   (frob fcos-quick %cos-quick fcos)
   ;;
   (frob fsqrt %sqrt fsqrt))
@@ -2191,6 +2497,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:ignore fr0)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
     (note-this-location vop :internal-error)
     (case (tn-offset x)
@@ -2476,6 +2783,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:ignore temp)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      (unless (zerop (tn-offset x))
@@ -2532,6 +2840,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:ignore temp fr0)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      (unless (zerop (tn-offset x))
@@ -2587,6 +2896,7 @@
   (:note "inline log function")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      (sc-case x
@@ -2638,6 +2948,7 @@
   (:note "inline log10 function")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      (sc-case x
@@ -2692,6 +3003,7 @@
   (:note "inline pow function")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      ;; Setup x in fr0 and y in fr1
@@ -2806,6 +3118,7 @@
   (:policy :fast-safe)
   (:note "inline scalbn function")
   (:ignore fr0)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      ;; Setup x in fr0 and y in fr1
      (sc-case x
@@ -2873,6 +3186,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:ignore fr0)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      ;; Setup x in fr0 and y in fr1
@@ -2974,7 +3288,8 @@
   (:arg-types double-float)
   (:result-types double-float)
   (:policy :fast-safe)
-  (:guard (not (backend-featurep :pentium)))
+  (:guard (or (not (backend-featurep :pentium))
+	      (not (backend-featurep :sse2))))
   (:note "inline log1p function")
   (:ignore temp)
   (:generator 5
@@ -3028,7 +3343,8 @@
   (:arg-types double-float)
   (:result-types double-float)
   (:policy :fast-safe)
-  (:guard (backend-featurep :pentium))
+  (:guard (and (backend-featurep :pentium)
+	       (not (backend-featurep :sse2))))
   (:note "inline log1p with limited x range function")
   (:vop-var vop)
   (:save-p :compute-only)
@@ -3083,6 +3399,7 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:ignore fr0)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      (sc-case x
@@ -3129,6 +3446,7 @@
   (:note "inline atan function")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      ;; Setup x in fr1 and 1.0 in fr0
@@ -3176,6 +3494,7 @@
   (:note "inline atan2 function")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:guard (not (backend-featurep :sse2)))
   (:generator 5
      (note-this-location vop :internal-error)
      ;; Setup x in fr1 and y in fr0
@@ -4645,3 +4964,424 @@
   (:note "inline dummy FP register bias")
   (:ignore x)
   (:generator 0))
+
+;;; Support for double-double floats
+
+#+double-double
+(progn
+
+(defun double-double-reg-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+
+(defun double-double-reg-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(define-move-function (load-double-double 4) (vop x y)
+  ((double-double-stack) (double-double-reg))
+  (let ((real-tn (double-double-reg-hi-tn y)))
+    (with-empty-tn at fp-top(real-tn)
+      (inst fldd (ea-for-cdf-real-stack x))))
+  (let ((imag-tn (double-double-reg-lo-tn y)))
+    (with-empty-tn at fp-top(imag-tn)
+      (inst fldd (ea-for-cdf-imag-stack x)))))
+
+(define-move-function (store-double-double 4) (vop x y)
+  ((double-double-reg) (double-double-stack))
+  (let ((real-tn (double-double-reg-hi-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 (double-double-reg-lo-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cdf-imag-stack y))
+    (inst fxch imag-tn)))
+
+;;; Double-double float register to register moves
+
+(define-vop (double-double-move)
+  (:args (x :scs (double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
+  (:note "double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the double-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-hi (double-double-reg-hi-tn x))
+	     (y-hi (double-double-reg-hi-tn y)))
+	 (cond ((zerop (tn-offset y-hi))
+		(copy-fp-reg-to-fr0 x-hi))
+	       ((zerop (tn-offset x-hi))
+		(inst fstd y-hi))
+	       (t
+		(inst fxch x-hi)
+		(inst fstd y-hi)
+		(inst fxch x-hi))))
+       (let ((x-lo (double-double-reg-lo-tn x))
+	     (y-lo (double-double-reg-lo-tn y)))
+	 (inst fxch x-lo)
+	 (inst fstd y-lo)
+	 (inst fxch x-lo)))))
+;;;
+(define-move-vop double-double-move :move
+  (double-double-reg) (double-double-reg))
+
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+
+(define-vop (move-from-double-double)
+  (:args (x :scs (double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc any-reg :offset r11-offset) temp)
+  (:node-var node)
+  (:note "double double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:double-double-float-type
+			       vm:double-double-float-size temp node)
+       (let ((real-tn (double-double-reg-hi-tn x)))
+	 (with-tn at fp-top(real-tn)
+	   (inst fstd (ea-for-cdf-real-desc y))))
+       (let ((imag-tn (double-double-reg-lo-tn x)))
+	 (with-tn at fp-top(imag-tn)
+	   (inst fstd (ea-for-cdf-imag-desc y)))))))
+;;;
+(define-move-vop move-from-double-double :move
+  (double-double-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a double-double float register
+
+(define-vop (move-to-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-double-reg)))
+  (:note "pointer to double-double-float coercion")
+  (:generator 2
+    (let ((real-tn (double-double-reg-hi-tn y)))
+      (with-empty-tn at fp-top(real-tn)
+	(inst fldd (ea-for-cdf-real-desc x))))
+    (let ((imag-tn (double-double-reg-lo-tn y)))
+      (with-empty-tn at fp-top(imag-tn)
+	(inst fldd (ea-for-cdf-imag-desc x))))))
+
+(define-move-vop move-to-double-double :move
+  (descriptor-reg) (double-double-reg))
+
+;;; double-double float move-argument vop
+
+(define-vop (move-double-double-float-argument)
+  (:args (x :scs (double-double-reg) :target y)
+	 (fp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
+  (:results (y))
+  (:note "double double-float argument move")
+  (:generator 2
+    (sc-case y
+      (double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (double-double-reg-hi-tn x))
+	       (y-real (double-double-reg-hi-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 (double-double-reg-lo-tn x))
+	       (y-imag (double-double-reg-lo-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))))
+      (double-double-stack
+       (let ((hi-tn (double-double-reg-hi-tn x)))
+	 (cond ((zerop (tn-offset hi-tn))
+		(inst fstd (ea-for-cdf-real-stack y fp)))
+	       (t
+		(inst fxch hi-tn)
+		(inst fstd (ea-for-cdf-real-stack y fp))
+		(inst fxch hi-tn))))
+       (let ((lo-tn (double-double-reg-lo-tn x)))
+	 (inst fxch lo-tn)
+	 (inst fstd (ea-for-cdf-imag-stack y fp))
+	 (inst fxch lo-tn))))))
+
+(define-move-vop move-double-double-float-argument :move-argument
+  (double-double-reg descriptor-reg) (double-double-reg))
+
+
+(define-vop (move-to-complex-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-double-reg)))
+  (:note "pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+      (with-empty-tn at fp-top(real-tn)
+	(inst fldd (ea-for-cddf-real-hi-desc x))))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+      (with-empty-tn at fp-top(real-tn)
+	(inst fldd (ea-for-cddf-real-lo-desc x))))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+      (with-empty-tn at fp-top(imag-tn)
+	(inst fldd (ea-for-cddf-imag-hi-desc x))))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+      (with-empty-tn at fp-top(imag-tn)
+	(inst fldd (ea-for-cddf-imag-lo-desc x))))))
+
+(define-move-vop move-to-complex-double-double :move
+  (descriptor-reg) (complex-double-double-reg))
+
+
+(define-vop (make/double-double-float)
+  (:args (hi :scs (double-reg) :target r
+	     :load-if (not (location= hi r)))
+	 (lo :scs (double-reg) :to :save))
+  (:results (r :scs (double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r double-double-stack))))
+  (:arg-types double-float double-float)
+  (:result-types double-double-float)
+  (:translate kernel::%make-double-double-float)
+  (:note "inline double-double-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (double-double-reg
+       (let ((r-real (double-double-reg-hi-tn r)))
+	 (unless (location= hi r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 hi))
+		 ((zerop (tn-offset hi))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch hi)
+		  (inst fstd r-real)
+		  (inst fxch hi)))))
+       (let ((r-imag (double-double-reg-lo-tn r)))
+	 (unless (location= lo r-imag)
+	   (cond ((zerop (tn-offset lo))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch lo)
+		  (inst fstd r-imag)
+		  (inst fxch lo))))))
+      (double-double-stack
+       (unless (location= hi r)
+	 (cond ((zerop (tn-offset hi))
+		(inst fstd (ea-for-cdf-real-stack r)))
+	       (t
+		(inst fxch hi)
+		(inst fstd (ea-for-cdf-real-stack r))
+		(inst fxch hi))))
+       (inst fxch lo)
+       (inst fstd (ea-for-cdf-imag-stack r))
+       (inst fxch lo)))))
+
+(define-vop (double-double-value)
+  (:args (x :target r))
+  (:results (r))
+  (:variant-vars offset)
+  (:policy :fast-safe)
+  (:generator 3
+    (cond ((sc-is x double-double-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 double-reg)
+	   (let ((ea (sc-case x
+		       (double-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 at fp-top(r)
+	       (inst fldd ea))))
+	  (t (error "double-double-value VOP failure")))))
+
+
+(define-vop (hi/double-double-value double-double-value)
+  (:translate kernel::double-double-hi)
+  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "double-double high part")
+  (:variant 0))
+
+(define-vop (lo/double-double-value double-double-value)
+  (:translate kernel::double-double-lo)
+  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "double-double low part")
+  (:variant 1))
+
+(define-vop (make-complex-double-double-float)
+  (:translate complex)
+  (:args (real :scs (double-double-reg) :target r
+	       :load-if (not (location= real r))
+	       )
+	 (imag :scs (double-double-reg) :to :save))
+  (:arg-types double-double-float double-double-float)
+  (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-double-stack))))
+  (:result-types complex-double-double-float)
+  (:note "inline complex double-double-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-double-double-reg
+       (let ((r-real (complex-double-double-reg-real-hi-tn r))
+	     (a-real (double-double-reg-hi-tn real)))
+	 (unless (location= a-real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 a-real))
+		 ((zerop (tn-offset a-real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch a-real)
+		  (inst fstd r-real)
+		  (inst fxch a-real)))))
+       (let ((r-real (complex-double-double-reg-real-lo-tn r))
+	     (a-real (double-double-reg-lo-tn real)))
+	 (unless (location= a-real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 a-real))
+		 ((zerop (tn-offset a-real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch a-real)
+		  (inst fstd r-real)
+		  (inst fxch a-real)))))
+       (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+	     (a-imag (double-double-reg-hi-tn imag)))
+	 (unless (location= a-imag r-imag)
+	   (cond ((zerop (tn-offset a-imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch a-imag)
+		  (inst fstd r-imag)
+		  (inst fxch a-imag)))))
+       (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+	     (a-imag (double-double-reg-lo-tn imag)))
+	 (unless (location= a-imag r-imag)
+	   (cond ((zerop (tn-offset a-imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch a-imag)
+		  (inst fstd r-imag)
+		  (inst fxch a-imag))))))
+      (complex-double-double-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fstd (ea-for-cddf-real-hi-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fstd (ea-for-cddf-real-hi-stack r))
+		(inst fxch real))))
+       (let ((real-lo (double-double-reg-lo-tn real)))
+	 (cond ((zerop (tn-offset real-lo))
+		(inst fstd (ea-for-cddf-real-lo-stack r)))
+	       (t
+		(inst fxch real-lo)
+		(inst fstd (ea-for-cddf-real-lo-stack r))
+		(inst fxch real-lo))))
+       (let ((imag-val (double-double-reg-hi-tn imag)))
+	 (inst fxch imag-val)
+	 (inst fstd (ea-for-cddf-imag-hi-stack r))
+	 (inst fxch imag-val))
+       (let ((imag-val (double-double-reg-lo-tn imag)))
+	 (inst fxch imag-val)
+	 (inst fstd (ea-for-cddf-imag-lo-stack r))
+	 (inst fxch imag-val))))))
+
+(define-vop (complex-double-double-float-value)
+  (:args (x :scs (complex-double-double-reg descriptor-reg) :target r
+	    :load-if (not (sc-is x complex-double-double-stack))))
+  (:arg-types complex-double-double-float)
+  (:results (r :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:generator 3
+    (sc-case x
+      (complex-double-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-hi-tn x))
+			 (:imag (complex-double-double-reg-imag-hi-tn x))))
+	     (r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= value-tn r-hi)
+	   (cond ((zerop (tn-offset r-hi))
+		  (copy-fp-reg-to-fr0 value-tn))
+		 ((zerop (tn-offset value-tn))
+		  (inst fstd r-hi))
+		 (t
+		  (inst fxch value-tn)
+		  (inst fstd r-hi)
+		  (inst fxch value-tn)))))
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-lo-tn x))
+			 (:imag (complex-double-double-reg-imag-lo-tn x))))
+	     (r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= value-tn r-lo)
+	   (cond ((zerop (tn-offset r-lo))
+		  (copy-fp-reg-to-fr0 value-tn))
+		 ((zerop (tn-offset value-tn))
+		  (inst fstd r-lo))
+		 (t
+		  (inst fxch value-tn)
+		  (inst fstd r-lo)
+		  (inst fxch value-tn))))))
+      (complex-double-double-stack
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (with-empty-tn at fp-top (r-hi)
+	   (inst fldd (ecase slot
+		       (:real (ea-for-cddf-real-hi-stack x))
+		       (:imag (ea-for-cddf-imag-hi-stack x))))))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (with-empty-tn at fp-top (r-lo)
+	   (inst fldd (ecase slot
+		       (:real (ea-for-cddf-real-lo-stack x))
+		       (:imag (ea-for-cddf-imag-lo-stack x)))))))
+      (descriptor-reg
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (with-empty-tn at fp-top (r-hi)
+	   (inst fldd (ecase slot
+		       (:real (ea-for-cddf-real-hi-desc x))
+		       (:imag (ea-for-cddf-imag-hi-desc x))))))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (with-empty-tn at fp-top (r-lo)
+	   (inst fldd (ecase slot
+		       (:real (ea-for-cddf-real-lo-desc x))
+		       (:imag (ea-for-cddf-imag-lo-desc x))))))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+  (:translate realpart)
+  (:note "complex float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+  (:translate imagpart)
+  (:note "complex float imagpart")
+  (:variant :imag))
+
+); progn
Index: src/compiler/amd64/parms.lisp
diff -u src/compiler/amd64/parms.lisp:1.3 src/compiler/amd64/parms.lisp:1.3.36.1
--- src/compiler/amd64/parms.lisp:1.3	Fri Jun 18 19:44:42 2004
+++ src/compiler/amd64/parms.lisp	Mon Nov  2 09:29:46 2009
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group at cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/parms.lisp,v 1.3 2004-06-18 23:44:42 cwang Rel $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/parms.lisp,v 1.3.36.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -55,7 +55,8 @@
 
 ;;;; Machine Architecture parameters:
 
-(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes
+	  float-sign-shift
 
 	  single-float-bias single-float-exponent-byte
 	  single-float-significand-byte single-float-normal-exponent-min
@@ -76,6 +77,8 @@
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit))
 
+#+double-double
+(export '(double-double-float-digits))
 	  
 
 (eval-when (compile load eval)
@@ -86,6 +89,12 @@
 (defconstant byte-bits 8
   "Number of bits per byte where a byte is the smallest addressable object.")
 
+(defconstant char-bits #-unicode 8 #+unicode 16
+  "Number of bits needed to represent a character")
+
+(defconstant char-bytes (truncate char-bits byte-bits)
+  "Number of bytes needed to represent a character")
+
 (defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
   "Number of bits to shift between word addresses and byte addresses.")
 
@@ -134,6 +143,10 @@
 (defconstant long-float-digits
   (+ (byte-size long-float-significand-byte) 32 1))
 
+#+double-double
+(defconstant double-double-float-digits
+  (* 2 double-float-digits))
+
 ;;; pfw -- from i486 microprocessor programmers reference manual
 (defconstant float-invalid-trap-bit        (ash 1 0))
 (defconstant float-denormal-trap-bit       (ash 1 1))
@@ -147,16 +160,26 @@
 (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))
+;; NOTE: These actually match the SSE2 MXCSR register definitions.  We
+;; need to do it this way because the interface assumes the modes are
+;; in the same order as the MXCSR register.
+(defconstant float-rounding-mode     (byte 2 13))
+(defconstant float-sticky-bits       (byte 6  0))
+(defconstant float-traps-byte        (byte 6  7))
+(defconstant float-exceptions-byte   (byte 6  0))
+
+#-sse2
+(progn
 (defconstant float-fast-bit 0) ; No fast mode on x86
+)
+
+#+sse2
+(progn
+;; SSE2 has a flush-to-zero flag, which we use as the fast bit.  Some
+;; versions of sse2 also have a denormals-are-zeros flag.  We don't
+;; currently use denormals-are-zeroes for anything.
+(defconstant float-fast-bit (ash 1 15))
+)
 ); eval-when
 
 
@@ -171,9 +194,15 @@
 ;;; Where to put the different spaces.
 ;;; 
 (defconstant target-read-only-space-start #x10000000)
-(defconstant target-static-space-start    #x28000000)
-(defconstant target-dynamic-space-start   #x48000000)
-(defconstant target-foreign-linkage-space-start #xB0000000)
+(defconstant target-static-space-start
+  #+FreeBSD #x28F00000
+  #-FreeBSD #x28000000)
+(defconstant target-dynamic-space-start
+  #+linux #x58100000
+  #-linux #x48000000)
+(defconstant target-foreign-linkage-space-start
+  #+linux #x58000000
+  #-linux #xB0000000)
 (defconstant target-foreign-linkage-entry-size 16) ;In bytes.  Duh.
 
 ;;; Given that NIL is the first thing allocated in static space, we
@@ -305,6 +334,20 @@
       lisp::*cmucl-lib*
       lisp::*cmucl-core-path*
       
+      ;; Weak hash table support
+      :key
+      :value
+      :key-and-value
+      :key-or-value
+
+      ;; 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*
+
       ;; Spare symbols.  Rename these when you need to add some static
       ;; symbols and don't want to do a cross-compile.
       spare-8
@@ -316,13 +359,6 @@
       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
 
       
Index: src/compiler/amd64/type-vops.lisp
diff -u src/compiler/amd64/type-vops.lisp:1.1 src/compiler/amd64/type-vops.lisp:1.1.36.1
--- src/compiler/amd64/type-vops.lisp:1.1	Mon May 24 18:35:00 2004
+++ src/compiler/amd64/type-vops.lisp	Mon Nov  2 09:29:46 2009
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group at cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.1 2004-05-24 22:35:00 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.1.36.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -32,7 +32,7 @@
 
 
 (defparameter function-header-types
-  (list funcallable-instance-header-type dylan-function-header-type
+  (list funcallable-instance-header-type 
 	byte-code-function-type byte-code-closure-type
 	function-header-type closure-function-header-type
 	closure-header-type))
Index: src/compiler/amd64/vm.lisp
diff -u src/compiler/amd64/vm.lisp:1.2 src/compiler/amd64/vm.lisp:1.2.36.1
--- src/compiler/amd64/vm.lisp:1.2	Tue Jul  6 16:23:30 2004
+++ src/compiler/amd64/vm.lisp	Mon Nov  2 09:29:46 2009
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group at cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/amd64/vm.lisp,v 1.2 2004-07-06 20:23:30 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/vm.lisp,v 1.2.36.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -215,13 +215,17 @@
   (sap-stack stack)			; System area pointers.
   (single-stack stack)			; single-floats
   (double-stack stack :element-size 2)	; double-floats.
+  #+double-double
+  (double-double-stack stack :element-size 4)	; double-double-float
   #+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
-
+  #+double-double
+  (complex-double-double-stack stack :element-size 8)	; complex-double-double-floats
+  
   ;; **** Magic SCs.
 
   (ignore-me noise)
@@ -318,6 +322,14 @@
 	    :save-p t
 	    :alternate-scs (long-stack))
 
+  #+double-double
+  (double-double-reg float-registers
+		     :locations (0 2 4 6)
+		     :element-size 2
+		     :constant-scs ()
+		     :save-p t
+		     :alternate-scs (double-double-stack))
+  
   (complex-single-reg float-registers
 		      :locations (0 2 4 6)
 		      :element-size 2
@@ -339,6 +351,13 @@
 		    :constant-scs ()
 		    :save-p t
 		    :alternate-scs (complex-long-stack))
+  #+double-double
+  (complex-double-double-reg float-registers
+		      :locations (0 4)
+		      :element-size 4
+		      :constant-scs ()
+		      :save-p t
+		      :alternate-scs (complex-double-double-stack))
 
   ;; A catch or unwind block.
   (catch-block stack :element-size vm:catch-block-size)
Index: src/compiler/float-tran.lisp
diff -u src/compiler/float-tran.lisp:1.133 src/compiler/float-tran.lisp:1.133.8.1
--- src/compiler/float-tran.lisp:1.133	Tue Aug 11 14:32:55 2009
+++ src/compiler/float-tran.lisp	Mon Nov  2 09:29:46 2009
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.133 2009-08-11 18:32:55 rtoy Rel $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.133.8.1 2009-11-02 14:29:46 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -82,6 +82,8 @@
   (movable foldable flushable))
 (defknown %complex-double-float (number) (complex double-float)
   (movable foldable flushable))
+
+#+double-double
 (defknown %complex-double-double-float (number) (complex double-double-float)
   (movable foldable flushable))
 
Index: src/lisp/Config.amd64
diff -u src/lisp/Config.amd64:1.3 src/lisp/Config.amd64:1.3.20.1
--- src/lisp/Config.amd64:1.3	Wed Feb 27 18:30:46 2008
+++ src/lisp/Config.amd64	Mon Nov  2 09:29:46 2009
@@ -2,17 +2,52 @@
 vpath %.h $(PATH1)
 vpath %.c $(PATH1)
 vpath %.S $(PATH1)
-CPPFLAGS = -I. -I$(PATH1) -I-
+
+
+# Enable support for :linkage-table feature.
+ifdef FEATURE_LINKAGE_TABLE
+CPP_DEFINE_OPTIONS += -DLINKAGE_TABLE
+endif
+
+
+# Enable support for generational GC
+ifdef FEATURE_GENCGC
+CPP_DEFINE_OPTIONS += -DGENCGC
+GC_SRC := gencgc.c
+else
+GC_SRC := cgc.c
+CPP_DEFINE_OPTIONS += -DWANT_CGC
+endif
+
+ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),)
+CPP_INCLUDE_OPTIONS := -iquote . -iquote $(PATH1)
+else
+CPP_INCLUDE_OPTIONS := -I. -I$(PATH1) -I-
+endif
+CPPFLAGS := $(CPP_DEFINE_OPTIONS) $(CPP_INCLUDE_OPTIONS) 
+CFLAGS += -Wstrict-prototypes -Wall -g
+ASFLAGS = -g 
+
 CC = gcc
 LD = ld
 CPP = cpp
-CFLAGS = -m64 -rdynamic -Wstrict-prototypes -Wall -g -DGENCGC -DLINKAGE_TABLE
-ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE
+CFLAGS += -m64 -Wstrict-prototypes -Wall -g
+ASFLAGS = -g
+
 NM = $(PATH1)/linux-nm
 UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
+
 ASSEM_SRC = amd64-assem.S linux-stubs.S
 ARCH_SRC = amd64-arch.c
-OS_SRC = Linux-os.c os-common.c elf.c
+OS_SRC = Linux-os.c os-common.c elf.c e_rem_pio2.c k_rem_pio2.c
 OS_LINK_FLAGS = -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker foo
 OS_LIBS = -ldl
 GC_SRC = gencgc.c
+
+DEPEND = $(CC) -MM -E
+DEPEND_FLAGS = 
+
+# This no longer has aliasing problems, so no need to use
+# -ffloat-store and -fno-strict-aliasing anymore.
+e_rem_pio2.o : e_rem_pio2.c
+	$(CC) -c $(CFLAGS) $(CPPFLAGS) $<
Index: src/lisp/Linux-os.c
diff -u src/lisp/Linux-os.c:1.44 src/lisp/Linux-os.c:1.44.2.1
--- src/lisp/Linux-os.c:1.44	Thu Oct 15 11:05:51 2009
+++ src/lisp/Linux-os.c	Mon Nov  2 09:29:46 2009
@@ -15,7 +15,7 @@
  * GENCGC support by Douglas Crosher, 1996, 1997.
  * Alpha support by Julian Dolby, 1999.
  *
- * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.44 2009-10-15 15:05:51 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.44.2.1 2009-11-02 14:29:46 rtoy Exp $
  *
  */
 
@@ -153,45 +153,52 @@
 #endif
 
 #ifdef __x86_64
-int *
-sc_reg(ucontext_t *c, int offset)
+unsigned long *
+os_sigcontext_reg(ucontext_t *c, int offset)
 {
     switch (offset) {
       case 0:
-	  return &c->uc_mcontext.gregs[REG_RAX];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RAX];
       case 2:
-	  return &c->uc_mcontext.gregs[REG_RCX];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RCX];
       case 4:
-	  return &c->uc_mcontext.gregs[REG_RDX];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RDX];
       case 6:
-	  return &c->uc_mcontext.gregs[REG_RBX];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RBX];
       case 8:
-	  return &c->uc_mcontext.gregs[REG_RSP];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RSP];
       case 10:
-	  return &c->uc_mcontext.gregs[REG_RBP];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RBP];
       case 12:
-	  return &c->uc_mcontext.gregs[REG_RSI];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RSI];
       case 14:
-	  return &c->uc_mcontext.gregs[REG_RDI];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_RDI];
       case 16:
-	  return &c->uc_mcontext.gregs[REG_R8];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R8];
       case 18:
-	  return &c->uc_mcontext.gregs[REG_R9];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R9];
       case 20:
-	  return &c->uc_mcontext.gregs[REG_R10];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R10];
       case 22:
-	  return &c->uc_mcontext.gregs[REG_R11];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R11];
       case 24:
-	  return &c->uc_mcontext.gregs[REG_R12];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R12];
       case 26:
-	  return &c->uc_mcontext.gregs[REG_R13];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R13];
       case 28:
-	  return &c->uc_mcontext.gregs[REG_R14];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R14];
       case 30:
-	  return &c->uc_mcontext.gregs[REG_R15];
+	  return (unsigned long *)&c->uc_mcontext.gregs[REG_R15];
     }
-    return (int *) 0;
+    return (unsigned long *) 0;
 }
+
+unsigned long *
+os_sigcontext_pc(ucontext_t *scp)
+{
+    return (unsigned long *) &scp->uc_mcontext.gregs[REG_RIP];
+}
+
 #endif
 
 os_vm_address_t
@@ -298,7 +305,12 @@
 void
 sigsegv_handler(HANDLER_ARGS)
 {
-    int fault_addr = context->uc_mcontext.cr2;
+    long fault_addr = 
+#ifdef i386
+      context->uc_mcontext.cr2;
+#else
+      context->uc_mcontext.gregs[REG_CR2];
+#endif    
 
 #ifdef RED_ZONE_HIT
     if (os_control_stack_overflow((void *) fault_addr, context))
@@ -422,6 +434,7 @@
     }
 }
 
+#ifdef i386
 void
 restore_fpu(ucontext_t *context)
 {
@@ -444,3 +457,27 @@
 #endif        
     }
 }
+#else
+void
+restore_fpu(ucontext_t *context)
+{
+    if (context->uc_mcontext.fpregs) {
+	short cw = context->uc_mcontext.fpregs->cwd;
+        DPRINTF(0, (stderr, "restore_fpu:  cw = %08x\n", cw));
+	__asm__ __volatile__ ("fldcw %0" : : "m" (*&cw));
+#ifdef FEATURE_SSE2
+        if (fpu_mode == SSE2) {
+            struct _fpstate *fpstate;
+            unsigned int mxcsr;
+            
+            fpstate = (struct _fpstate*) context->uc_mcontext.fpregs;
+            if (fpstate->magic != 0xffff) {
+                mxcsr = fpstate->mxcsr;
+                DPRINTF(0, (stderr, "restore_fpu:  mxcsr (raw) = %04x\n", mxcsr));
+                __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr));
+            }
+        }
+#endif        
+    }
+}
+#endif
Index: src/lisp/Linux-os.h
diff -u src/lisp/Linux-os.h:1.28 src/lisp/Linux-os.h:1.28.22.1
--- src/lisp/Linux-os.h:1.28	Thu Jan  3 06:41:54 2008
+++ src/lisp/Linux-os.h	Mon Nov  2 09:29:46 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.28 2008-01-03 11:41:54 cshapiro Rel $
+/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.28.22.1 2009-11-02 14:29:46 rtoy Exp $
 
  This code was written as part of the CMU Common Lisp project at
  Carnegie Mellon University, and has been placed in the public domain.
@@ -26,6 +26,9 @@
 #include <asm/unistd.h>
 #include <errno.h>
 
+#define __USE_GNU
+#include <sys/ucontext.h>
+
 typedef caddr_t os_vm_address_t;	/* like hpux */
 typedef size_t os_vm_size_t;	/* like hpux */
 typedef off_t os_vm_offset_t;	/* like hpux */
Index: src/lisp/amd64-arch.c
diff -u src/lisp/amd64-arch.c:1.9 src/lisp/amd64-arch.c:1.9.12.1
--- src/lisp/amd64-arch.c:1.9	Sat Dec  6 21:33:55 2008
+++ src/lisp/amd64-arch.c	Mon Nov  2 09:29:46 2009
@@ -1,6 +1,6 @@
 /* x86-arch.c -*- Mode: C; comment-column: 40 -*-
  *
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.9 2008-12-07 02:33:55 agoncharov Rel $ 
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.9.12.1 2009-11-02 14:29:46 rtoy Exp $ 
  *
  */
 
@@ -12,6 +12,7 @@
 #include "os.h"
 #include "internals.h"
 #include "arch.h"
+#define __USE_GNU
 #include "lispregs.h"
 #include "signal.h"
 #include "alloc.h"
@@ -39,22 +40,22 @@
  */
 
 void
-arch_skip_instruction(struct sigcontext *context)
+arch_skip_instruction(os_context_t *context)
 {
     int vlen, code;
 
-    DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", context->sc_pc));
+    DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", SC_PC(context)));
 
     /* Get and skip the lisp error code. */
-    code = *(char *) context->sc_pc++;
+    code = *(char *) SC_PC(context)++;
     switch (code) {
       case trap_Error:
       case trap_Cerror:
 	  /* Lisp error arg vector length */
-	  vlen = *(char *) context->sc_pc++;
+	  vlen = *(char *) SC_PC(context)++;
 	  /* Skip lisp error arg data bytes */
 	  while (vlen-- > 0)
-	      ((char *) context->sc_pc)++;
+	      SC_PC(context)++;
 	  break;
 
       case trap_Breakpoint:
@@ -71,23 +72,23 @@
 	  break;
     }
 
-    DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", context->sc_pc));
+    DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", SC_PC(context)));
 }
 
 unsigned char *
-arch_internal_error_arguments(struct sigcontext *context)
+arch_internal_error_arguments(os_context_t *context)
 {
-    return (unsigned char *) (context->sc_pc + 1);
+    return (unsigned char *) (SC_PC(context) + 1);
 }
 
 boolean
-arch_pseudo_atomic_atomic(struct sigcontext *context)
+arch_pseudo_atomic_atomic(os_context_t *context)
 {
     return SymbolValue(PSEUDO_ATOMIC_ATOMIC);
 }
 
 void
-arch_set_pseudo_atomic_interrupted(struct sigcontext *context)
+arch_set_pseudo_atomic_interrupted(os_context_t *context)
 {
     SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
 }
@@ -128,9 +129,9 @@
 #endif
 
 void
-arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst)
+arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
 {
-    unsigned int *pc = (unsigned int *) context->sc_pc;
+    unsigned int *pc = (unsigned int *) SC_PC(context);
 
     /*
      * Put the original instruction back.
@@ -139,8 +140,8 @@
     *((char *) pc) = orig_inst & 0xff;
     *((char *) pc + 1) = (orig_inst & 0xff00) >> 8;
 
-#ifdef __linux__
-    context->eflags |= 0x100;
+#ifdef SC_EFLAGS
+    SC_EFLAGS(context) |= 0x100;
 #else
 
     /*
@@ -159,7 +160,7 @@
     single_stepping = (unsigned int *) pc;
 
 #ifndef __linux__
-    (unsigned int *) context->sc_pc = (char *) pc - 9;
+    (unsigned int *) SC_PC(context) = (char *) pc - 9;
 #endif
 }
 
@@ -169,12 +170,9 @@
 {
     unsigned int trap;
 
-#ifdef __linux__
-    GET_CONTEXT
-#endif
 #if 0
 	fprintf(stderr, "x86sigtrap: %8x %x\n",
-		context->sc_pc, *(unsigned char *) (context->sc_pc - 1));
+		SC_PC(context), *(unsigned char *) (SC_PC(context) - 1));
     fprintf(stderr, "sigtrap(%d %d %x)\n", signal, code, context);
 #endif
 
@@ -183,20 +181,21 @@
 	fprintf(stderr, "* Single step trap %x\n", single_stepping);
 #endif
 
-#ifndef __linux__
+#ifdef SC_EFLAGS
+	/* Disable single-stepping */
+	SC_EFLAGS(context) ^= 0x100;
+#else
 	/* Un-install single step helper instructions. */
 	*(single_stepping - 3) = single_step_save1;
 	*(single_stepping - 2) = single_step_save2;
 	*(single_stepping - 1) = single_step_save3;
-#else
-	context->eflags ^= 0x100;
 #endif
 
 	/*
 	 * Re-install the breakpoint if possible.
 	 */
 
-	if ((int) context->sc_pc == (int) single_stepping + 1)
+	if ((int) SC_PC(context) == (int) single_stepping + 1)
 	    fprintf(stderr, "* Breakpoint not re-install\n");
 	else {
 	    char *ptr = (char *) single_stepping;
@@ -210,21 +209,9 @@
     }
 
     /* This is just for info in case monitor wants to print an approx */
-    current_control_stack_pointer = (unsigned long *) context->sc_sp;
-
-#if defined(__linux__) && (defined(i386) || defined(__x86_64))
-    /*
-     * Restore the FPU control word, setting the rounding mode to nearest.
-     */
-
-    if (contextstruct.fpstate)
-#if defined(__x86_64)
-	setfpucw(contextstruct.fpstate->cwd & ~0xc00);
-#else
-	setfpucw(contextstruct.fpstate->cw & ~0xc00);
-#endif
-#endif
+    current_control_stack_pointer = (unsigned long *) SC_SP(context);
 
+    RESTORE_FPU(context);
     /*
      * On entry %eip points just after the INT3 byte and aims at the
      * 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a
@@ -232,7 +219,7 @@
      * arguments to follow.
      */
 
-    trap = *(unsigned char *) (context->sc_pc);
+    trap = *(unsigned char *) (SC_PC(context));
 
     switch (trap) {
       case trap_PendingInterrupt:
@@ -261,27 +248,23 @@
       case trap_Error:
       case trap_Cerror:
 	  DPRINTF(0, (stderr, "<trap Error %d>\n", code));
-#ifdef __linux__
-	  interrupt_internal_error(signal, contextstruct, code == trap_Cerror);
-#else
-	  interrupt_internal_error(signal, code, context, code == trap_Cerror);
-#endif
+	  interrupt_internal_error(signal, code, context, CODE(code) == trap_Cerror);
 	  break;
 
       case trap_Breakpoint:
 #if 0
 	  fprintf(stderr, "*C break\n");
 #endif
-	  (char *) context->sc_pc -= 1;
-	  handle_breakpoint(signal, code, context);
+	  SC_PC(context) -= 1;
+	  handle_breakpoint(signal, CODE(code), context);
 #if 0
 	  fprintf(stderr, "*C break return\n");
 #endif
 	  break;
 
       case trap_FunctionEndBreakpoint:
-	  (char *) context->sc_pc -= 1;
-	  context->sc_pc =
+	  SC_PC(context) -= 1;
+	  SC_PC(context) =
 	      (int) handle_function_end_breakpoint(signal, code, context);
 	  break;
 
@@ -303,11 +286,7 @@
 	  DPRINTF(0,
 		  (stderr, "[C--trap default %d %d %x]\n", signal, code,
 		   context));
-#ifdef __linux__
-	  interrupt_handle_now(signal, contextstruct);
-#else
 	  interrupt_handle_now(signal, code, context);
-#endif
 	  break;
     }
 }
Index: src/lisp/amd64-assem.S
diff -u src/lisp/amd64-assem.S:1.10 src/lisp/amd64-assem.S:1.10.36.1
--- src/lisp/amd64-assem.S:1.10	Tue Jul 27 18:03:53 2004
+++ src/lisp/amd64-assem.S	Mon Nov  2 09:29:47 2009
@@ -1,6 +1,6 @@
 ### amd64-assem.S -*- Mode: Asm; -*-
 /**
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.10 2004-07-27 22:03:53 cwang Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.10.36.1 2009-11-02 14:29:47 rtoy Exp $
  *
  * Authors:	Paul F. Werkowski <pw at snoopy.mv.com>
  *		Douglas T. Crosher
@@ -119,7 +119,7 @@
 
 	movl	$0,GNAME(foreign_function_call_active)
 /* Return */	
-	jmp	*%ebx
+	jmp	*%rbx
 
 	.size	GNAME(call_into_c), . - GNAME(call_into_c)
 
Index: src/lisp/amd64-lispregs.h
diff -u src/lisp/amd64-lispregs.h:1.4 src/lisp/amd64-lispregs.h:1.4.22.1
--- src/lisp/amd64-lispregs.h:1.4	Tue Nov  7 06:24:12 2006
+++ src/lisp/amd64-lispregs.h	Mon Nov  2 09:29:47 2009
@@ -1,5 +1,5 @@
 /* x86-lispregs.h -*- Mode: C; -*-
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.4 2006-11-07 11:24:12 cshapiro Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.4.22.1 2009-11-02 14:29:47 rtoy Exp $
  */
 
 /* These register names and offsets correspond to definitions
@@ -52,7 +52,9 @@
  * xxx-os.c handle it.
  */
 
-#define SC_REG(sc, n) (*sc_reg(sc,n))
-#define SC_PC(sc) ((sc)->sc_pc)
+#define SC_REG(sc, n) (*os_sigcontext_reg(sc,n))
+#define SC_PC(sc) (*os_sigcontext_pc(sc))
+#define SC_EFLAGS(sc) ((sc)->uc_mcontext.gregs[REG_EFL])
+#define SC_SP(scp) SC_REG(scp, reg_RSP)
 
 #endif /* _AMD64_LISPREGS_H_ */
Index: src/lisp/backtrace.c
diff -u src/lisp/backtrace.c:1.17 src/lisp/backtrace.c:1.17.10.1
--- src/lisp/backtrace.c:1.17	Thu Jun 11 12:04:01 2009
+++ src/lisp/backtrace.c	Mon Nov  2 09:29:47 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.17 2009-06-11 16:04:01 rtoy Rel $
+/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.17.10.1 2009-11-02 14:29:47 rtoy Exp $
  *
  * Simple backtrace facility.  More or less from Rob's lisp version.
  */
@@ -497,8 +497,12 @@
     unsigned long fp;
     int i;
 
-    __asm__("movl %%ebp,%0":"=g"(fp));
-
+#ifdef __x86_64
+    __asm__("movq %%rbp,%0":"=g"(fp));
+#else
+    __asm__("movl %%rbp,%0":"=g"(fp));
+#endif
+    
     for (i = 0; i < nframes; ++i) {
 	lispobj *p;
 	unsigned long ra, next_fp;
Index: src/lisp/gencgc.c
diff -u src/lisp/gencgc.c:1.99 src/lisp/gencgc.c:1.99.8.1
--- src/lisp/gencgc.c:1.99	Tue Jul  7 13:09:17 2009
+++ src/lisp/gencgc.c	Mon Nov  2 09:29:47 2009
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997, 1998, 1999.
  *
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.99 2009-07-07 17:09:17 rtoy Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.99.8.1 2009-11-02 14:29:47 rtoy Exp $
  *
  */
 
@@ -3990,6 +3990,7 @@
         boolean eq_hash_p = eq_based_hash_vector(hash_vector, i);
         unsigned int index_value = index_vector[old_index];
 
+#ifdef KEY
 	if (((weak == KEY)
              && removable_weak_key(old_key, index_value,
                                    eq_hash_p))
@@ -4002,7 +4003,9 @@
             if (removep) {
                 free_hash_entry(hash_table, old_index, i);
             }
-        } else {
+        } else
+#endif
+          {
 	    /* If the key is EQ-hashed and moves, schedule it for rehashing. */
 	    scavenge(&kv_vector[2 * i], 2);
 #if 0
@@ -4069,6 +4072,7 @@
 	boolean value_survives = weak_value_survives(value);
 
 
+#ifdef KEY
 	if ((hash_table->weak_p == KEY)
 	    && key_survives
             && !survives_gc(value)) {
@@ -4111,6 +4115,7 @@
                 scavenged = 1;
             }
 	}
+#endif
     }
 
     return scavenged;
Index: src/lisp/gencgc.h
diff -u src/lisp/gencgc.h:1.14 src/lisp/gencgc.h:1.14.16.1
--- src/lisp/gencgc.h:1.14	Tue Sep 16 04:52:32 2008
+++ src/lisp/gencgc.h	Mon Nov  2 09:29:47 2009
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997.
  *
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.14 2008-09-16 08:52:32 cshapiro Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.14.16.1 2009-11-02 14:29:47 rtoy Exp $
  *
  */
 
@@ -123,7 +123,7 @@
  * write protected.
  */
 
-#if defined(i386)
+#if defined(i386) || defined(__x86_64)
 #define PAGE_SIZE 4096
 #elif defined(sparc)
 /*
Index: src/lisp/globals.h
diff -u src/lisp/globals.h:1.11 src/lisp/globals.h:1.11.12.1
--- src/lisp/globals.h:1.11	Mon Jan  5 17:26:27 2009
+++ src/lisp/globals.h	Mon Nov  2 09:29:47 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.11 2009-01-05 22:26:27 rtoy Rel $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.11.12.1 2009-11-02 14:29:47 rtoy Exp $ */
 
 #ifndef _GLOBALS_H_
 #define _GLOBALS_H_
@@ -31,7 +31,7 @@
 #endif
 extern lispobj *current_dynamic_space;
 
-#if !defined(ibmrt) && !defined(i386)
+#if !defined(ibmrt) && !defined(i386) && !defined(__x86_64)
 extern lispobj *current_dynamic_space_free_pointer;
 extern lispobj *current_auto_gc_trigger;
 #endif
Index: src/lisp/interrupt.c
diff -u src/lisp/interrupt.c:1.58 src/lisp/interrupt.c:1.58.8.1
--- src/lisp/interrupt.c:1.58	Tue Jul  7 13:06:54 2009
+++ src/lisp/interrupt.c	Mon Nov  2 09:29:47 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.58 2009-07-07 17:06:54 rtoy Rel $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.58.8.1 2009-11-02 14:29:47 rtoy Exp $ */
 
 /* Interrupt handling magic. */
 
@@ -22,6 +22,8 @@
 #include "dynbind.h"
 #include "interr.h"
 
+#include "bits/xopen_lim.h"
+
 boolean internal_errors_enabled = 0;
 
 os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
Index: src/tools/clean-target.sh
diff -u src/tools/clean-target.sh:1.6 src/tools/clean-target.sh:1.6.10.1
--- src/tools/clean-target.sh:1.6	Mon Apr 20 16:54:10 2009
+++ src/tools/clean-target.sh	Mon Nov  2 09:29:47 2009
@@ -63,6 +63,7 @@
 	-name "*.ppcf" -o \
 	-name "*.sparcf" -o \
 	-name "*.x86f" -o \
+	-name "*.amd64f" -o \
 	-name "*.sse2f" $CORE | $GREP | xargs rm 2> /dev/null
 
 for d in $TARGET
Index: src/tools/cross-scripts/cross-x86-amd64.lisp
diff -u src/tools/cross-scripts/cross-x86-amd64.lisp:1.1 src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.1
--- src/tools/cross-scripts/cross-x86-amd64.lisp:1.1	Tue Oct 20 17:58:50 2009
+++ src/tools/cross-scripts/cross-x86-amd64.lisp	Mon Nov  2 09:29:47 2009
@@ -102,7 +102,7 @@
 
 ;;; Rename the X86 package and backend so that new-backend does the
 ;;; right thing.
-(rename-package "X86" "OLD-X86")
+(rename-package "X86" "OLD-X86" '("OLD-VM"))
 (setf (c:backend-name c:*native-backend*) "OLD-X86")
 
 (c::new-backend "AMD64"
@@ -118,12 +118,25 @@
    '(:x86 :i486 :pentium :x86-bootstrap :alpha :osf1 :mips
      :propagate-fun-type :propagate-float-type :constrain-float-type
      :openbsd :freebsd :glibc2 :linux :mp :heap-overflow-check
-     :long-float :new-random :small))
+     :long-float :new-random :small
+     ))
 
 ;;; Compile the new backend.
 (pushnew :bootstrap *features*)
 (pushnew :building-cross-compiler *features*)
 
+(in-package "VM")
+(defconstant byte-bits 8
+  "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant char-bits #-unicode 8 #+unicode 16
+  "Number of bits needed to represent a character")
+
+(defconstant char-bytes (truncate char-bits byte-bits)
+  "Number of bytes needed to represent a character")
+
+(export '(byte-bits char-bits char-bytes) "VM")
+
 (in-package :cl-user)
 
 (load "target:tools/comcom")
@@ -204,30 +217,41 @@
 (macrolet ((frob (&rest syms)
 	     `(progn ,@(mapcar #'(lambda (sym)
 				   `(defconstant ,sym
-				      (symbol-value
-				       (find-symbol ,(symbol-name sym)
-						    :vm))))
+				     (symbol-value
+				      (find-symbol ,(symbol-name sym)
+				       :vm))))
 			       syms))))
-  (frob OLD-X86:BYTE-BITS
-	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
-	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
-	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
-	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
-	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
-	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
-	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
-	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
-	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
-	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
-	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
-	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
-	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
-	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
-	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
-	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
-	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
-	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
-	))
+  (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS
+	OLD-VM:CHAR-BITS
+	#+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-VM:SIMPLE-BIT-VECTOR-TYPE
+	OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE 
+	OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET
+	OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
+	OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 
+	OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+	OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
+	OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+	OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
+	)
+  #+double-double
+  (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
+	OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE
+	OLD-VM:DOUBLE-DOUBLE-FLOAT-DIGITS))
 
 (let ((function (symbol-function 'kernel:error-number-or-lose)))
   (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
@@ -277,3 +301,4 @@
 (let ((ht (c::backend-sc-names c::*target-backend*)))
   (setf (gethash 'old-x86::any-reg ht)
 	(gethash 'amd64::any-reg ht)))
+



More information about the cmucl-commit mailing list