diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 7f7571734526e9c106d85356048a3ed04894a3a2..23f206cca2a49cc721eacb5e95c3927658479c18 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.66 2004/05/15 18:30:47 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.67 2004/05/24 23:04:10 cwang Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -71,11 +71,11 @@
 (defstruct (descriptor
 	    (:constructor make-descriptor (high low &optional space offset))
 	    (:print-function %print-descriptor))
-  space			      ; The space is descriptor is allocated in.
+  space			      ; The space this descriptor is allocated in.
   offset		      ; The offset (in words) from the start of
 			      ;  that space.
-  high			      ; The high half of the descriptor.
-  low			      ; The low half of the descriptor.
+  high			      ; The high part of the descriptor.
+  low			      ; The low part of the descriptor.
   )
 
 (defun %print-descriptor (des stream depth)
@@ -86,9 +86,11 @@
 		  (logior (ash (descriptor-high des)
 			       (1+ (- descriptor-low-bits vm:lowtag-bits)))
 			  (ash (descriptor-low des) (- 1 vm:lowtag-bits)))))
-	     (if (> unsigned #x1FFFFFFF)
+	     (if (> unsigned (1- (ash 1 (- vm:word-bits 3))))
+		 ;; negative fixnum
 		 (format stream "#<fixnum: ~D>"
-			 (- unsigned #x40000000))
+			 (- unsigned (ash 1 (- vm:word-bits 2))))
+		 ;; positive fixnum
 		 (format stream "#<fixnum: ~D>" unsigned))))
 	  ((or (= lowtag vm:other-immediate-0-type)
 	       (= lowtag vm:other-immediate-1-type))
@@ -98,12 +100,20 @@
 			   (ash (descriptor-low des)
 				(- vm:type-bits)))
 		   (logand (descriptor-low des) vm:type-mask)))
+	  ((and (= lowtag vm:list-pointer-type)
+		(= (descriptor-bits des) (descriptor-bits *nil-descriptor*)))
+	   (format stream "NIL"))
 	  (t
-	   (format stream "#<pointer: #x~X, lowtag #b~3,'0B, ~A space>"
+	   (format stream
+		   (ecase lowtag
+		     (#.vm:function-pointer-type "#<function-pointer")
+		     (#.vm:list-pointer-type "#<list-pointer")
+		     (#.vm:other-pointer-type "#<other-pointer")
+		     (#.vm:instance-pointer-type "#<instance-pointer")))
+	   (format stream ": #x~X, ~A space>"
 		   (logior (ash (descriptor-high des)
 				descriptor-low-bits)
 			   (logandc2 (descriptor-low des) vm:lowtag-mask))
-		   lowtag
 		   (let ((space (descriptor-space des)))
 		     (if space
 			 (space-name space)
@@ -134,7 +144,7 @@
   "Return a descriptor for a block of LENGTH bytes out of SPACE.  The free
   pointer is boosted as necessary.  If any additional memory is needed, we
   vm_allocate it.  The descriptor returned is a pointer of type LOWTAG."
-  (let* ((bytes (round-up length (ash 1 vm:lowtag-bits)))
+  (let* ((bytes (round-up length #+amd64 16 #-amd64 (ash 1 vm:lowtag-bits)))
 	 (offset (space-free-pointer space))
 	 (new-free-ptr (+ offset (ash bytes (- vm:word-shift)))))
     (when (> new-free-ptr (space-words-allocated space))
@@ -278,26 +288,26 @@
 ;;;; Stuff to read and write the core memory.
 
 (defun maybe-byte-swap (word)
-  (declare (type (unsigned-byte 32) word))
-  (assert (= vm:word-bits 32))
-  (assert (= vm:byte-bits 8))
   (if (eq (c:backend-byte-order c:*native-backend*)
 	  (c:backend-byte-order c:*backend*))
       word
-      (logior (ash (ldb (byte 8 0) word) 24)
-	      (ash (ldb (byte 8 8) word) 16)
-	      (ash (ldb (byte 8 16) word) 8)
-	      (ldb (byte 8 24) word))))
+      (locally (declare (type (unsigned-byte 32) word))
+	(assert (= vm:word-bits 32))
+	(assert (= vm:byte-bits 8))
+	(logior (ash (ldb (byte 8 0) word) 24)
+		(ash (ldb (byte 8 8) word) 16)
+		(ash (ldb (byte 8 16) word) 8)
+		(ldb (byte 8 24) word)))))
 
 (defun maybe-byte-swap-short (short)
-  (declare (type (unsigned-byte 16) short))
-  (assert (= vm:word-bits 32))
-  (assert (= vm:byte-bits 8))
   (if (eq (c:backend-byte-order c:*native-backend*)
 	  (c:backend-byte-order c:*backend*))
       short
-      (logior (ash (ldb (byte 8 0) short) 8)
-	      (ldb (byte 8 8) short))))
+      (locally (declare (type (unsigned-byte 16) short))
+	(assert (= vm:word-bits 32))
+	(assert (= vm:byte-bits 8))
+	(logior (ash (ldb (byte 8 0) short) 8)
+		(ldb (byte 8 8) short)))))
   
 
 (defun write-indexed (address index value)
@@ -311,8 +321,20 @@
       (let ((sap (descriptor-sap address))
 	    (high (descriptor-high value))
 	    (low (descriptor-low value)))
-	(setf (sap-ref-32 sap (ash index vm:word-shift))
-	      (maybe-byte-swap (logior (ash high 16) low))))))
+	(ecase vm:word-bits
+	  (32
+	   (setf (sap-ref-32 sap (ash index vm:word-shift))
+		 (maybe-byte-swap (logior (ash high descriptor-low-bits) low))))
+	  (64
+	   (assert (eq (c:backend-byte-order c:*backend*) :little-endian))
+	   ;; lower 32 bits
+	   (setf (sap-ref-32 sap (ash index vm:word-shift))
+		 (maybe-byte-swap (logand
+				   (logior (ash high descriptor-low-bits) low)
+				   (1- (ash 1 32)))))
+	   ;; higher 32 bits
+	   (setf (sap-ref-32 sap (+ 4 (ash index vm:word-shift)))
+		 (maybe-byte-swap (ash high (- descriptor-low-bits 32)))))))))
 
 (defun write-memory (address value)
   "Write VALUE (a descriptor) at ADDRESS (also a descriptor)."
@@ -323,7 +345,14 @@
   "Return the value (as a descriptor) INDEX words from ADDRESS (a descriptor)."
   (let* ((sap (descriptor-sap address))
 	 (value (maybe-byte-swap (sap-ref-32 sap (ash index vm:word-shift)))))
-    (make-random-descriptor value)))
+    (ecase vm:word-bits
+      (32 (make-random-descriptor value))
+      (64
+       (assert (eq (c:backend-byte-order c:*backend*) :little-endian))
+       ;; assume little endian
+       (let ((most-significant (sap-ref-32 sap (+ 4 (ash index vm:word-shift)))))
+	 (make-random-descriptor (logior (ash most-significant 32) value)))))))
+	     
 
 (defun read-memory (address)
   "Return the value at ADDRESS (a descriptor)."
@@ -386,7 +415,10 @@
 	 (des (allocate-vector-object space vm:byte-bits (1+ len)
 				      vm:simple-string-type)))
     (write-indexed des vm:vector-length-slot (make-fixnum-descriptor len))
-    (copy-to-system-area string (* vm:vector-data-offset vm:word-bits)
+    (copy-to-system-area string (* vm:vector-data-offset 32) ; this should be the
+			 ;; word size of the old vm which may be different from the new vm
+			 ;; I'm assuming that the old vm is 32 bits!!!
+			 ;; TODO: add word-bits slot to the backend structure
 			 (descriptor-sap des)
 			 (* vm:vector-data-offset vm:word-bits)
 			 (* (1+ len) vm:byte-bits))
@@ -537,7 +569,7 @@
 ;;; COLD-VECTOR  --  Internal
 ;;;
 ;;;    Make a simple-vector that holds the specified Objects and return its
-;;; decriptor.
+;;; descriptor.
 ;;;
 (defun cold-vector (&rest objects)
   (let* ((size (length objects))
@@ -562,9 +594,10 @@
 		 vm:word-bits (1- vm:symbol-size) vm:symbol-header-type)))
     (write-indexed symbol vm:symbol-value-slot unbound-marker)
     (when (or (c:backend-featurep :x86)
+	      (c:backend-featurep :amd64)
 	      (c:backend-featurep :sparc))
-      (let ((offset #+(or x86 sparc) vm:symbol-hash-slot
-		    #-(or x86 sparc) vm:symbol-unused-slot)
+      (let ((offset #+(or x86 amd64 sparc) vm:symbol-hash-slot
+		    #-(or x86 amd64 sparc) vm:symbol-unused-slot)
 	    (value (sxhash name)))
 	
       (write-indexed symbol offset (make-fixnum-descriptor value))))
@@ -653,14 +686,15 @@
 ;;; anything else, we intern those here.  We also set the values of T and Nil.
 ;;;
 (defun initialize-symbols ()
-  "Initilizes the cold load symbol-hacking data structures."
+  "Initializes the cold load symbol-hacking data structures."
   (do-all-symbols (sym)
     (remprop sym 'cold-info))
   (setq *cold-packages* nil)
   (let ((*cold-symbol-allocation-space* *static*))
     ;; Special case NIL.
     (let ((des (allocate-unboxed-object *static* vm:word-bits
-					vm:symbol-size 0)))
+					#+amd64 (1+ vm:symbol-size) #-amd64 vm:symbol-size
+					0)))
       (setf *nil-descriptor*
 	    (make-descriptor (descriptor-high des)
 			     (+ (descriptor-low des) (* 2 vm:word-bytes)
@@ -857,7 +891,7 @@
   (let ((hash (extract-fdefn-name name)))
     (or (gethash hash *fdefn-objects*)
 	(let ((fdefn (allocate-boxed-object (or *fdefn-space* *dynamic*)
-					    (1- vm:fdefn-size)
+					    vm:fdefn-size
 					    vm:other-pointer-type)))
 	  (setf (gethash hash *fdefn-objects*) fdefn)
 	  (write-memory fdefn (make-other-immediate-descriptor
@@ -1731,8 +1765,11 @@
 							   (- vm:word-shift))
 						      vm:function-header-type))
     (write-indexed fn vm:function-self-slot
-		   (if (= (c:backend-fasl-file-implementation c:*backend*)
-			  #.c:x86-fasl-file-implementation)
+		   (if (or (= (c:backend-fasl-file-implementation c:*backend*)
+			      #.c:x86-fasl-file-implementation)
+			   (= (c:backend-fasl-file-implementation c:*backend*)
+			      #.c:amd64-fasl-file-implementation))
+		       ;; point to raw code instead of the code function object itself
 		       (make-random-descriptor
 			(+ (descriptor-bits fn)
 			   (- (ash vm:function-code-offset
@@ -1930,7 +1967,7 @@
   (clrhash *cold-foreign-hash*)
   ;; This has gotta be the first entry.  This has to match what
   ;; os_foreign_linkage_init does!
-  #+x86
+  #+(or x86 amd64)
   (cold-register-foreign-linkage "resolve_linkage_tramp" :code)
   #+sparc
   (progn
@@ -1971,7 +2008,7 @@
 (defvar *load-time-code-fixups* nil)
 
 (defun note-load-time-code-fixup (code-object offset value kind)
-  (assert (c:backend-featurep :x86))
+  (assert (or (c:backend-featurep :x86) (c:backend-featurep :amd64)))
   (when (= (space-identifier (descriptor-space code-object)) dynamic-space-id)
     (push (list code-object offset value kind) *load-time-code-fixups*)))
 
@@ -2059,7 +2096,8 @@
 			inst))))
 	  (setf (sap-ref-16 sap 2)
 		(maybe-byte-swap-short (ldb (byte 16 0) value))))))
-      (#.c:x86-fasl-file-implementation
+      ((#.c:x86-fasl-file-implementation
+	#.c:amd64-fasl-file-implementation) ;; I don't know if this right
        (let* ((disp (logior (sap-ref-8 sap 0)
 			    (ash (sap-ref-8 sap 1) 8)
 			    (ash (sap-ref-8 sap 2) 16)
@@ -2068,6 +2106,7 @@
 					vm:lowtag-mask)))
 	 (ecase kind
 	   (:absolute
+	    ;; fix this for 64 bit addresses
 	    (let ((new-value (+ value disp)))
 	      (setf (sap-ref-8 sap 0) (ldb (byte 8 0) new-value))
 	      (setf (sap-ref-8 sap 1) (ldb (byte 8 8) new-value))
@@ -2220,14 +2259,24 @@
 	       (test-tail (tail prefix priority)
 		 (when (tail-comp name tail)
 		   (record prefix
-			   (subseq name 0
-				   (- (length name)
-				      (length tail)))
+			   (let* ((len (- (length name)
+					  (length tail)))
+				  (result (make-string len)))
+			     ;; (subseq name 0 len) but subseq is broken somehow.
+			     (do ((i 0 (1+ i)))
+				 ((= i len) result)
+			       (setf (aref result i) (aref name i))))
 			   priority)))
 	       (test-head (head prefix priority)
 		 (when (head-comp name head)
 		   (record prefix
-			   (subseq name (length head))
+			   ;; (subseq name (length head)) but subseq is broken
+			   (let* ((head-len (length head))
+				  (len (- (length name) head-len))
+				  (result (make-string len)))
+			     (do ((i 0 (1+ i)))
+				 ((= i len) result)
+			       (setf (aref result i) (aref name (+ i head-len)))))
 			   priority))))
 	    (test-tail "-TYPE" "type_" 0)
 	    (test-tail "-FLAG" "flag_" 1)
@@ -2444,7 +2493,7 @@
 		(cold-load file))
 	      (maybe-gc))
 	    (resolve-assembler-fixups)
-	    (when (c:backend-featurep :x86)
+	    (when (or (c:backend-featurep :x86) (c:backend-featurep :amd64))
 	      (output-load-time-code-fixups))
 	    (linkage-info-to-core)
 	    (finish-symbols)