0.8.18.14:

author Christophe Rhodes <csr21@cam.ac.uk>

Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)

committer Christophe Rhodes <csr21@cam.ac.uk>

Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)
author Christophe Rhodes <csr21@cam.ac.uk>
Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)
committer Christophe Rhodes <csr21@cam.ac.uk>
Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)
diff --git a/CREDITS b/CREDITS

index be6601d..36d9436 100644 (file)
--- a/CREDITS
+++ b/CREDITS
@@ -509,13 +509,14 @@ Martin Atzmueller:
  Daniel Barlow:
    His contributions have included support for shared object loading
    (from CMUCL), the Cheney GC for non-x86 ports (from CMUCL), Alpha
  Daniel Barlow:
    His contributions have included support for shared object loading
    (from CMUCL), the Cheney GC for non-x86 ports (from CMUCL), Alpha
-  and PPC ports (from CMUCL), control stack exhaustion checking (new)
-  and native threads support for x86 Linux (new).  He also refactored
-  the garbage collectors for understandability, wrote code
-  (e.g. grovel-headers.c and stat_wrapper stuff) to find
-  machine-dependent and OS-dependent constants automatically, and was
-  original author of the asdf, asdf-install, sb-bsd-sockets,
-  sb-executable, sb-grovel and sb-posix contrib packages.
+  and PPC ports (from CMUCL), control stack exhaustion checking (new),
+  native threads support for x86 Linux (new), and the initial x86-64
+  backend (new).  He also refactored the garbage collectors for
+  understandability, wrote code (e.g. grovel-headers.c and
+  stat_wrapper stuff) to find machine-dependent and OS-dependent
+  constants automatically, and was original author of the asdf,
+  asdf-install, sb-bsd-sockets, sb-executable, sb-grovel and sb-posix
+  contrib packages.
  
  Robert E. Brown:
    He has reported various bugs and submitted several patches, 
  
  Robert E. Brown:
    He has reported various bugs and submitted several patches, 
@@ -697,7 +698,8 @@ Juho Snellman:
    function on strings, removal of unneccessary bounds checks, and
    multiple improvements to performance of common operations on
    bignums.  He ported and enhanced the statistical profiler written by
    function on strings, removal of unneccessary bounds checks, and
    multiple improvements to performance of common operations on
    bignums.  He ported and enhanced the statistical profiler written by
-  Gerd Moellmann for CMU CL.
+  Gerd Moellmann for CMU CL.  He completed the work on the x86-64 port
+  of SBCL.
  
  Brian Spilsbury:
    He wrote Unicode-capable versions of SBCL's character, string, and
  
  Brian Spilsbury:
    He wrote Unicode-capable versions of SBCL's character, string, and
@@ -725,6 +727,9 @@ Colin Walters:
    cmucl-imp@cons.org mailing list, was the inspiration for similar MAP
    code added in sbcl-0.6.8.
  
    cmucl-imp@cons.org mailing list, was the inspiration for similar MAP
    code added in sbcl-0.6.8.
  
+Cheuksan Edward Wang:
+  He assisted in debugging the SBCL x86-64 backend.
+
  Raymond Wiker:
    He ported sbcl-0.6.3 back to FreeBSD, restoring the ancestral
    CMU CL support for FreeBSD and updating it for the changes made
  Raymond Wiker:
    He ported sbcl-0.6.3 back to FreeBSD, restoring the ancestral
    CMU CL support for FreeBSD and updating it for the changes made
diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp

index 22f6793..ab29f66 100644 (file)
--- a/contrib/sb-bsd-sockets/constants.lisp
+++ b/contrib/sb-bsd-sockets/constants.lisp
@@ -133,62 +133,62 @@
                        (integer type "int" "h_addrtype")
                        (integer length "int" "h_length")
                        ((* (* (unsigned 8))) addresses "char **" "h_addr_list")))
                        (integer type "int" "h_addrtype")
                        (integer length "int" "h_length")
                        ((* (* (unsigned 8))) addresses "char **" "h_addr_list")))
- (:function socket ("socket" integer
-                    (domain integer)
-                    (type integer)
-                    (protocol integer)))
- (:function bind ("bind" integer
-                  (sockfd integer)
+ (:function socket ("socket" int
+                    (domain int)
+                    (type int)
+                    (protocol int)))
+ (:function bind ("bind" int
+                  (sockfd int)
                    (my-addr (* t))  ; KLUDGE: sockaddr-in or sockaddr-un?
                    (my-addr (* t))  ; KLUDGE: sockaddr-in or sockaddr-un?
-                  (addrlen integer)))
- (:function listen ("listen" integer
-                    (socket integer)
-                    (backlog integer)))
- (:function accept ("accept" integer
-                    (socket integer)
+                  (addrlen int)))
+ (:function listen ("listen" int
+                    (socket int)
+                    (backlog int)))
+ (:function accept ("accept" int
+                    (socket int)
                      (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                      (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
-                    (addrlen integer :in-out)))
- (:function getpeername ("getpeername" integer
-                         (socket integer)
+                    (addrlen int :in-out)))
+ (:function getpeername ("getpeername" int
+                         (socket int)
                           (her-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                           (her-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
-                         (addrlen integer :in-out)))
- (:function getsockname ("getsockname" integer
-                         (socket integer)
+                         (addrlen int :in-out)))
+ (:function getsockname ("getsockname" int
+                         (socket int)
                           (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                           (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
-                         (addrlen integer :in-out)))
- (:function connect ("connect" integer
-                    (socket integer)
+                         (addrlen int :in-out)))
+ (:function connect ("connect" int
+                    (socket int)
                      (his-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                      (his-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
-                    (addrlen integer )))
+                    (addrlen int )))
   
   
- (:function close ("close" integer
-                   (fd integer)))
- (:function recvfrom ("recvfrom" integer
-                                (socket integer)
+ (:function close ("close" int
+                   (fd int)))
+ (:function recvfrom ("recvfrom" int
+                                (socket int)
                                  (buf (* t))
                                  (len integer)
                                  (buf (* t))
                                  (len integer)
-                                (flags integer)
+                                (flags int)
                                  (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                                  (socklen (* socklen-t))))
   (:function gethostbyname ("gethostbyname" (* hostent) (name c-string)))
   (:function gethostbyaddr ("gethostbyaddr" (* hostent)
                                            (addr (* t))
                                  (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
                                  (socklen (* socklen-t))))
   (:function gethostbyname ("gethostbyname" (* hostent) (name c-string)))
   (:function gethostbyaddr ("gethostbyaddr" (* hostent)
                                            (addr (* t))
-                                          (len integer)
-                                          (af integer)))
- (:function setsockopt ("setsockopt" integer
-                        (socket integer)
-                        (level integer)
-                        (optname integer)
+                                          (len int)
+                                          (af int)))
+ (:function setsockopt ("setsockopt" int
+                        (socket int)
+                        (level int)
+                        (optname int)
                          (optval (* t))
                          (optval (* t))
-                        (optlen integer)))
- (:function fcntl ("fcntl" integer
-                   (fd integer)
-                   (cmd integer)
-                   (arg integer)))
- (:function getsockopt ("getsockopt" integer
-                        (socket integer)
-                        (level integer)
-                        (optname integer)
+                        (optlen int)))
+ (:function fcntl ("fcntl" int
+                   (fd int)
+                   (cmd int)
+                   (arg long)))
+ (:function getsockopt ("getsockopt" int
+                        (socket int)
+                        (level int)
+                        (optname int)
                          (optval (* t))
                          (optval (* t))
-                        (optlen (* integer)))))
+                        (optlen (* int)))))
  )
  )
diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp

index 88e83b6..7fa1ff7 100644 (file)
--- a/contrib/sb-bsd-sockets/sockopt.lisp
+++ b/contrib/sb-bsd-sockets/sockopt.lisp
@@ -49,7 +49,7 @@ Code for options that not every system has should be conditionalised:
        (defun ,lisp-name (socket)
         ,@(when documentation (list (concatenate 'string documentation " " info)))
         ,(if supportedp
        (defun ,lisp-name (socket)
         ,@(when documentation (list (concatenate 'string documentation " " info)))
         ,(if supportedp
-            `(sb-alien:with-alien ((size sb-alien:integer)
+            `(sb-alien:with-alien ((size sb-alien:int)
                                       (buffer ,buffer-type))
                   (setf size (sb-alien:alien-size ,buffer-type :bytes))
                   (if (= -1 (sockint::getsockopt (socket-file-descriptor socket)
                                       (buffer ,buffer-type))
                   (setf size (sb-alien:alien-size ,buffer-type :bytes))
                   (if (= -1 (sockint::getsockopt (socket-file-descriptor socket)
@@ -81,12 +81,12 @@ Code for options that not every system has should be conditionalised:
  ;;; sockopts that have integer arguments
  
  (defun foreign-int-to-integer (buffer size)
  ;;; sockopts that have integer arguments
  
  (defun foreign-int-to-integer (buffer size)
-  (assert (= size (sb-alien:alien-size sb-alien:integer :bytes)))
+  (assert (= size (sb-alien:alien-size sb-alien:int :bytes)))
    buffer)
  
  (defmacro define-socket-option-int (name level number &optional features (info ""))
    `(define-socket-option ,name nil ,level ,number
    buffer)
  
  (defmacro define-socket-option-int (name level number &optional features (info ""))
    `(define-socket-option ,name nil ,level ,number
-     sb-alien:integer nil foreign-int-to-integer sb-alien:addr ,features ,info))
+     sb-alien:int nil foreign-int-to-integer sb-alien:addr ,features ,info))
  
  (define-socket-option-int
    sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
  
  (define-socket-option-int
    sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
@@ -118,7 +118,7 @@ Code for options that not every system has should be conditionalised:
                   This can also be updated with SETF.~:@>"
              (symbol-name c-name))
      ,level ,c-name
                   This can also be updated with SETF.~:@>"
              (symbol-name c-name))
      ,level ,c-name
-    sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr
+    sb-alien:int bool-to-foreign-int foreign-int-to-bool sb-alien:addr
      ,features ,info))
  
  (define-socket-option-bool
      ,features ,info))
  
  (define-socket-option-bool
diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp

index bf9498e..ed265c1 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -219,10 +219,8 @@
  
  ;;; mmap, msync
  (define-call "mmap" sb-sys:system-area-pointer
  
  ;;; mmap, msync
  (define-call "mmap" sb-sys:system-area-pointer
-  ;; KLUDGE: #XFFFFFFFF is (void *)-1, which is the charming return
-  ;; value of mmap on failure.  Except on 64 bit systems ...
    (lambda (res)
    (lambda (res)
-    (= (sb-sys:sap-int res) #-alpha #XFFFFFFFF #+alpha #xffffffffffffffff))
+    (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits))))
    (addr sap-or-nil) (length unsigned) (prot unsigned)
    (flags unsigned) (fd file-descriptor) (offset sb-posix::off-t))
  
    (addr sap-or-nil) (length unsigned) (prot unsigned)
    (flags unsigned) (fd file-descriptor) (offset sb-posix::off-t))
  
diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp

index a82bd7e..1108583 100644 (file)
--- a/contrib/sb-posix/posix-tests.lisp
+++ b/contrib/sb-posix/posix-tests.lisp
@@ -355,11 +355,19 @@
        (sb-posix:syscall-errno c)))
    #.sb-posix::eisdir)
  
        (sb-posix:syscall-errno c)))
    #.sb-posix::eisdir)
  
+#-(and x86-64 linux)
  (deftest fcntl.1
    (let ((fd (sb-posix:open "/dev/null" sb-posix::o-nonblock)))
      (= (sb-posix:fcntl fd sb-posix::f-getfl) sb-posix::o-nonblock))
    t)
  (deftest fcntl.1
    (let ((fd (sb-posix:open "/dev/null" sb-posix::o-nonblock)))
      (= (sb-posix:fcntl fd sb-posix::f-getfl) sb-posix::o-nonblock))
    t)
-
+;; On AMD64/Linux O_LARGEFILE is always set, even though the whole
+;; flag makes no sense.
+#+(and x86-64 linux)
+(deftest fcntl.1
+  (let ((fd (sb-posix:open "/dev/null" sb-posix::o-nonblock)))
+    (/= 0 (logand (sb-posix:fcntl fd sb-posix::f-getfl)
+                 sb-posix::o-nonblock)))
+  t)
  
  (deftest opendir.1
    (let ((dir (sb-posix:opendir "/")))
  
  (deftest opendir.1
    (let ((dir (sb-posix:opendir "/")))
diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp

index d638443..dffc369 100644 (file)
--- a/contrib/sb-sprof/sb-sprof.lisp
+++ b/contrib/sb-sprof/sb-sprof.lisp
@@ -423,7 +423,7 @@
  (deftype address ()
    "Type used for addresses, for instance, program counters,
     code start/end locations etc."
  (deftype address ()
    "Type used for addresses, for instance, program counters,
     code start/end locations etc."
-  '(unsigned-byte #+alpha 64 #-alpha 32))
+  '(unsigned-byte #.sb-vm::n-machine-word-bits))
  
  (defconstant +unknown-address+ 0
    "Constant representing an address that cannot be determined.")
  
  (defconstant +unknown-address+ 0
    "Constant representing an address that cannot be determined.")
@@ -580,9 +580,9 @@
         (locally (declare (optimize (inhibit-warnings 2)))
          (let* ((pc-ptr (sb-vm:context-pc scp))
                 (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))
         (locally (declare (optimize (inhibit-warnings 2)))
          (let* ((pc-ptr (sb-vm:context-pc scp))
                 (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))
-               (ra (sap-ref-32 (int-sap fp)
-                               (- (* (1+ sb-vm::return-pc-save-offset)
-                                     sb-vm::n-word-bytes)))))
+               (ra (sap-ref-word (int-sap fp)
+                                 (- (* (1+ sb-vm::return-pc-save-offset)
+                                       sb-vm::n-word-bytes)))))
            (record (sap-int pc-ptr))
            (record ra)))))))
  
            (record (sap-int pc-ptr))
            (record ra)))))))
  
@@ -596,7 +596,7 @@
         (locally (declare (optimize (inhibit-warnings 2)))
          (let* ((pc-ptr (sb-vm:context-pc scp))
                 (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
         (locally (declare (optimize (inhibit-warnings 2)))
          (let* ((pc-ptr (sb-vm:context-pc scp))
                 (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
-               (ra (sap-ref-32 
+               (ra (sap-ref-word 
                      (int-sap fp)
                      (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
            (record (sap-int pc-ptr))
                      (int-sap fp)
                      (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
            (record (sap-int pc-ptr))
diff --git a/make-config.sh b/make-config.sh

index 0ba561e..238bc8a 100644 (file)
--- a/make-config.sh
+++ b/make-config.sh
@@ -30,7 +30,8 @@ printf '(' >> $ltf
  
  echo //guessing default target CPU architecture from host architecture
  case `uname -m` in 
  
  echo //guessing default target CPU architecture from host architecture
  case `uname -m` in 
-    *86|x86_64) guessed_sbcl_arch=x86 ;; 
+    *86) guessed_sbcl_arch=x86 ;; 
+    *x86_64) guessed_sbcl_arch=x86-64 ;; 
      [Aa]lpha) guessed_sbcl_arch=alpha ;;
      sparc*) guessed_sbcl_arch=sparc ;;
      sun*) guessed_sbcl_arch=sparc ;;
      [Aa]lpha) guessed_sbcl_arch=alpha ;;
      sparc*) guessed_sbcl_arch=sparc ;;
      sun*) guessed_sbcl_arch=sparc ;;
@@ -189,6 +190,8 @@ if [ "$sbcl_arch" = "x86" ]; then
      if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ]; then
         printf ' :linkage-table' >> $ltf
      fi
      if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ]; then
         printf ' :linkage-table' >> $ltf
      fi
+elif [ "$sbcl_arch" = "x86-64" ]; then
+    printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
  elif [ "$sbcl_arch" = "mips" ]; then
      # Use a little C program to try to guess the endianness.  Ware
      # cross-compilers!
  elif [ "$sbcl_arch" = "mips" ]; then
      # Use a little C program to try to guess the endianness.  Ware
      # cross-compilers!
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr

index 72b7b59..076bbe4 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1098,11 +1098,12 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                 "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-FUN"
                 "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS"
                 "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
                 "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-FUN"
                 "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS"
                 "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
-               "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
+               "%SET-SAP-REF-WORD" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
                 "%SET-SAP-REF-LONG" "%SET-SAP-REF-SAP"
                 "%SET-SAP-REF-SINGLE" "%SET-SIGNED-SAP-REF-16"
                 "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64"
                 "%SET-SAP-REF-LONG" "%SET-SAP-REF-SAP"
                 "%SET-SAP-REF-SINGLE" "%SET-SIGNED-SAP-REF-16"
                 "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64"
-               "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
+               "%SET-SIGNED-SAP-REF-WORD"
+              "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
                 "%SET-SYMBOL-HASH" "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
                 "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING"
                 "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
                 "%SET-SYMBOL-HASH" "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
                 "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING"
                 "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
@@ -1204,7 +1205,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                 "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO"
                 "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE"
                 "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR"
                 "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO"
                 "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE"
                 "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR"
-               #!+x86 "%LEA"
+               #!+(or x86-64 x86) "%LEA"
                 "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM"
                 "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE"
                 "ANSI-STREAM-ELEMENT-TYPE" "ANSI-STREAM-IN"
                 "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM"
                 "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE"
                 "ANSI-STREAM-ELEMENT-TYPE" "ANSI-STREAM-IN"
@@ -1329,8 +1330,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                 "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
                 "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE"
                 "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR"
                 "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
                 "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE"
                 "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR"
-               #!+x86 "*PSEUDO-ATOMIC-ATOMIC*"
-               #!+x86 "*PSEUDO-ATOMIC-INTERRUPTED*"
+               #!+(or x86 x86-64) "*PSEUDO-ATOMIC-ATOMIC*"
+               #!+(or x86 x86-64) "*PSEUDO-ATOMIC-INTERRUPTED*"
                 "PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR"
                 "READER-PACKAGE-ERROR" "READER-EOF-ERROR"
                 "RESTART-DESIGNATOR" "SCALE-DOUBLE-FLOAT"
                 "PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR"
                 "READER-PACKAGE-ERROR" "READER-EOF-ERROR"
                 "RESTART-DESIGNATOR" "SCALE-DOUBLE-FLOAT"
@@ -1823,7 +1824,8 @@ SB-KERNEL) have been undone, but probably more remain."
                 "REOPEN-SHARED-OBJECTS"
                "RESOLVE-LOADED-ASSEMBLER-REFERENCES"
                "SAP+" "SAP-" "SAP-INT"
                 "REOPEN-SHARED-OBJECTS"
                "RESOLVE-LOADED-ASSEMBLER-REFERENCES"
                "SAP+" "SAP-" "SAP-INT"
-              "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-8"
+              "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-WORD"
+              "SAP-REF-8"
                "SAP-REF-DESCRIPTOR"
                "SAP-REF-DOUBLE" "SAP-REF-LONG"
                "SAP-REF-SAP" "SAP-REF-SINGLE"
                "SAP-REF-DESCRIPTOR"
                "SAP-REF-DOUBLE" "SAP-REF-LONG"
                "SAP-REF-SAP" "SAP-REF-SINGLE"
@@ -1831,7 +1833,7 @@ SB-KERNEL) have been undone, but probably more remain."
                "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"
                "SERVE-EVENT" "SERVER" "SERVER-MESSAGE"
                "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32"
                "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"
                "SERVE-EVENT" "SERVER" "SERVER-MESSAGE"
                "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32"
-              "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-8"
+              "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-WORD" "SIGNED-SAP-REF-8"
                ;; FIXME: STRUCTURE!OBJECT stuff probably belongs in SB!KERNEL.
                "STRUCTURE!OBJECT" "STRUCTURE!OBJECT-MAKE-LOAD-FORM"
                "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" 
                ;; FIXME: STRUCTURE!OBJECT stuff probably belongs in SB!KERNEL.
                "STRUCTURE!OBJECT" "STRUCTURE!OBJECT-MAKE-LOAD-FORM"
                "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" 
diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp

new file mode 100644 (file)

index 0000000..cf4e3c8
--- /dev/null
+++ b/src/assembly/x86-64/alloc.lisp
@@ -0,0 +1,59 @@
+;;;; allocating simple objects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; from signed/unsigned
+
+;;; KLUDGE: Why don't we want vops for this one and the next
+;;; one? -- WHN 19990916
+#+sb-assembling ; We don't want a vop for this one.
+(define-assembly-routine
+    (move-from-signed)
+    ((:temp eax unsigned-reg eax-offset)
+     (:temp ebx unsigned-reg ebx-offset))
+  (inst mov ebx eax)
+  (inst shl ebx 1)
+  (inst jmp :o bignum)
+  (inst shl ebx 1)
+  (inst jmp :o bignum)
+  (inst shl ebx 1)
+  (inst jmp :o bignum)
+  (inst ret)
+  BIGNUM
+
+  (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1))
+    (storew eax ebx bignum-digits-offset other-pointer-lowtag))
+
+  (inst ret))
+
+#+sb-assembling ; We don't want a vop for this one either.
+(define-assembly-routine
+  (move-from-unsigned)
+  ((:temp eax unsigned-reg eax-offset)
+   (:temp ebx unsigned-reg ebx-offset))
+
+  (inst bsr ebx eax)
+  (inst cmp ebx 61)
+  (inst jmp :z DONE)
+  (inst jmp :ge BIGNUM)
+  ;; Fixnum
+  (inst mov ebx eax)
+  (inst shl ebx 3)
+  DONE
+  (inst ret)
+
+  BIGNUM
+  (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2))
+    (storew eax ebx bignum-digits-offset other-pointer-lowtag))
+  (inst ret))
+
+
diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp

new file mode 100644 (file)

index 0000000..71f05b0
--- /dev/null
+++ b/src/assembly/x86-64/arith.lisp
@@ -0,0 +1,303 @@
+;;;; simple cases for generic arithmetic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; addition, subtraction, and multiplication
+
+(macrolet ((define-generic-arith-routine ((fun cost) &body body)
+            `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
+                                       (:cost ,cost)
+                                       (:return-style :full-call)
+                                       (:translate ,fun)
+                                       (:policy :safe)
+                                       (:save-p t))
+               ((:arg x (descriptor-reg any-reg) rdx-offset)
+                (:arg y (descriptor-reg any-reg)
+                      ;; this seems wrong esi-offset -- FIXME: What's it mean?
+                      rdi-offset)
+
+                (:res res (descriptor-reg any-reg) rdx-offset)
+
+                (:temp rax unsigned-reg rax-offset)
+                (:temp rbx unsigned-reg rbx-offset)
+                (:temp rcx unsigned-reg rcx-offset))
+
+               (declare (ignorable rbx))
+
+               (inst test x 7)  ; fixnum?
+               (inst jmp :nz DO-STATIC-FUN) ; no - do generic
+               (inst test y 7)  ; fixnum?
+               (inst jmp :z DO-BODY)   ; yes - doit here
+
+               DO-STATIC-FUN
+               (inst pop rax)
+               (inst push rbp-tn)
+               (inst lea
+                     rbp-tn
+                     (make-ea :qword :base rsp-tn :disp n-word-bytes))
+               (inst sub rsp-tn (fixnumize 2))
+               (inst push rax)  ; callers return addr
+               (inst mov rcx (fixnumize 2)) ; arg count
+               (inst jmp
+                     (make-ea :qword
+                              :disp (+ nil-value
+                                       (static-fun-offset
+                                        ',(symbolicate "TWO-ARG-" fun)))))
+
+               DO-BODY
+               ,@body)))
+
+  (define-generic-arith-routine (+ 10)
+    (move res x)
+    (inst add res y)
+    (inst jmp :no OKAY)
+    (inst rcr res 1)                 ; carry has correct sign
+    (inst sar res 2)                 ; remove type bits
+
+    (move rcx res)
+
+    (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+      (storew rcx res bignum-digits-offset other-pointer-lowtag))
+
+    OKAY)
+
+  (define-generic-arith-routine (- 10)
+    ;; FIXME: This is screwed up.
+      ;;; I can't figure out the flags on subtract. Overflow never gets
+      ;;; set and carry always does. (- 0 most-negative-fixnum) can't be
+      ;;; easily detected so just let the upper level stuff do it.
+    (inst jmp DO-STATIC-FUN)
+
+    (move res x)
+    (inst sub res y)
+    (inst jmp :no OKAY)
+    (inst rcr res 1)
+    (inst sar res 2)                 ; remove type bits
+
+    (move rcx res)
+
+    (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+      (storew rcx res bignum-digits-offset other-pointer-lowtag))
+    OKAY)
+
+  (define-generic-arith-routine (* 30)
+    (move rax x)                  ; must use eax for 64-bit result
+    (inst sar rax 3)              ; remove *4 fixnum bias
+    (inst imul y)                 ; result in edx:eax
+    (inst jmp :no okay)                   ; still fixnum
+
+    ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
+    ;;     pfw says that loses big -- edx is target for arg x and result res
+    ;;     note that 'edx' is not defined -- using x
+    (inst shrd rax x 3)                   ; high bits from edx
+    (inst sar x 3)                ; now shift edx too
+
+    (move rcx x)                  ; save high bits from cqo
+    (inst cqo)                    ; edx:eax <- sign-extend of eax
+    (inst cmp x rcx)
+    (inst jmp :e SINGLE-WORD-BIGNUM)
+
+    (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
+      (storew rax res bignum-digits-offset other-pointer-lowtag)
+      (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
+    (inst jmp DONE)
+
+    SINGLE-WORD-BIGNUM
+
+    (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+      (storew rax res bignum-digits-offset other-pointer-lowtag))
+    (inst jmp DONE)
+
+    OKAY
+    (move res rax)
+    DONE))
+\f
+;;;; negation
+
+(define-assembly-routine (generic-negate
+                         (:cost 10)
+                         (:return-style :full-call)
+                         (:policy :safe)
+                         (:translate %negate)
+                         (:save-p t))
+                        ((:arg x (descriptor-reg any-reg) rdx-offset)
+                         (:res res (descriptor-reg any-reg) rdx-offset)
+
+                         (:temp rax unsigned-reg rax-offset)
+                         (:temp rcx unsigned-reg rcx-offset))
+  (inst test x 7)
+  (inst jmp :z FIXNUM)
+
+  (inst pop rax)
+  (inst push rbp-tn)
+  (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+  (inst sub rsp-tn (fixnumize 2))
+  (inst push rax)
+  (inst mov rcx (fixnumize 1))   ; arg count
+  (inst jmp (make-ea :qword
+                    :disp (+ nil-value (static-fun-offset '%negate))))
+
+  FIXNUM
+  (move res x)
+  (inst neg res)                       ; (- most-negative-fixnum) is BIGNUM
+  (inst jmp :no OKAY)
+  (inst shr res 3)                   ; sign bit is data - remove type bits
+  (move rcx res)
+
+  (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+    (storew rcx res bignum-digits-offset other-pointer-lowtag))
+
+  OKAY)
+\f
+;;;; comparison
+
+(macrolet ((define-cond-assem-rtn (name translate static-fn test)
+            `(define-assembly-routine (,name
+                                       (:cost 10)
+                                       (:return-style :full-call)
+                                       (:policy :safe)
+                                       (:translate ,translate)
+                                       (:save-p t))
+               ((:arg x (descriptor-reg any-reg) rdx-offset)
+                (:arg y (descriptor-reg any-reg) rdi-offset)
+
+                (:res res descriptor-reg rdx-offset)
+
+                (:temp eax unsigned-reg rax-offset)
+                (:temp ecx unsigned-reg rcx-offset))
+
+               ;; KLUDGE: The "3" here is a mask for the bits which will be
+               ;; zero in a fixnum. It should have a symbolic name. (Actually,
+               ;; it might already have a symbolic name which the coder
+               ;; couldn't be bothered to use..) -- WHN 19990917
+               (inst test x 7)
+               (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
+               (inst test y 7)
+               (inst jmp :z INLINE-FIXNUM-COMPARE)
+
+               TAIL-CALL-TO-STATIC-FN
+               (inst pop eax)
+               (inst push rbp-tn)
+               (inst lea rbp-tn (make-ea :qword
+                                         :base rsp-tn
+                                         :disp n-word-bytes))
+               (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
+                                               ; weirdly?
+               (inst push eax)
+               (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
+                                       ; SINGLE-FLOAT-BITS are parallel,
+                                       ; should be named parallelly.
+               (inst jmp (make-ea :qword
+                                  :disp (+ nil-value
+                                           (static-fun-offset ',static-fn))))
+
+               INLINE-FIXNUM-COMPARE
+               (inst cmp x y)
+               (inst jmp ,test RETURN-TRUE)
+               (inst mov res nil-value)
+               ;; FIXME: A note explaining this return convention, or a
+               ;; symbolic name for it, would be nice. (It looks as though we
+               ;; should be hand-crafting the same return sequence as would be
+               ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
+               ;; not clear why we don't just jump to the end of this function
+               ;; to share the return sequence there.
+               (inst pop eax)
+               (inst add eax 3)
+               (inst jmp eax)
+
+               RETURN-TRUE
+               (load-symbol res t))))
+
+  (define-cond-assem-rtn generic-< < two-arg-< :l)
+  (define-cond-assem-rtn generic-> > two-arg-> :g))
+
+(define-assembly-routine (generic-eql
+                         (:cost 10)
+                         (:return-style :full-call)
+                         (:policy :safe)
+                         (:translate eql)
+                         (:save-p t))
+                        ((:arg x (descriptor-reg any-reg) rdx-offset)
+                         (:arg y (descriptor-reg any-reg) rdi-offset)
+
+                         (:res res descriptor-reg rdx-offset)
+
+                         (:temp eax unsigned-reg rax-offset)
+                         (:temp ecx unsigned-reg rcx-offset))
+  (inst cmp x y)
+  (inst jmp :e RETURN-T)
+  (inst test x 7)
+  (inst jmp :z RETURN-NIL)
+  (inst test y 7)
+  (inst jmp :nz DO-STATIC-FN)
+
+  RETURN-NIL
+  (inst mov res nil-value)
+  (inst pop eax)
+  (inst add eax 3)
+  (inst jmp eax)
+
+  DO-STATIC-FN
+  (inst pop eax)
+  (inst push rbp-tn)
+  (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+  (inst sub rsp-tn (fixnumize 2))
+  (inst push eax)
+  (inst mov ecx (fixnumize 2))
+  (inst jmp (make-ea :qword
+                    :disp (+ nil-value (static-fun-offset 'eql))))
+
+  RETURN-T
+  (load-symbol res t)
+  ;; FIXME: I don't understand how we return from here..
+  )
+
+(define-assembly-routine (generic-=
+                         (:cost 10)
+                         (:return-style :full-call)
+                         (:policy :safe)
+                         (:translate =)
+                         (:save-p t))
+                        ((:arg x (descriptor-reg any-reg) rdx-offset)
+                         (:arg y (descriptor-reg any-reg) rdi-offset)
+
+                         (:res res descriptor-reg rdx-offset)
+
+                         (:temp eax unsigned-reg rax-offset)
+                         (:temp ecx unsigned-reg rcx-offset)
+                         )
+  (inst test x 7)                     ; descriptor?
+  (inst jmp :nz DO-STATIC-FN)          ; yes, do it here
+  (inst test y 7)                     ; descriptor?
+  (inst jmp :nz DO-STATIC-FN)
+  (inst cmp x y)
+  (inst jmp :e RETURN-T)               ; ok
+
+  (inst mov res nil-value)
+  (inst pop eax)
+  (inst add eax 3)
+  (inst jmp eax)
+
+  DO-STATIC-FN
+  (inst pop eax)
+  (inst push rbp-tn)
+  (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+  (inst sub rsp-tn (fixnumize 2))
+  (inst push eax)
+  (inst mov ecx (fixnumize 2))
+  (inst jmp (make-ea :qword
+                    :disp (+ nil-value (static-fun-offset 'two-arg-=))))
+
+  RETURN-T
+  (load-symbol res t))
+
+
diff --git a/src/assembly/x86-64/array.lisp b/src/assembly/x86-64/array.lisp

new file mode 100644 (file)

index 0000000..7662427
--- /dev/null
+++ b/src/assembly/x86-64/array.lisp
@@ -0,0 +1,39 @@
+;;;; various array operations that are too expensive (in space) to do
+;;;; inline
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; allocation
+
+(define-assembly-routine (allocate-vector
+                         (:policy :fast-safe)
+                         (:translate allocate-vector)
+                         (:arg-types positive-fixnum
+                                     positive-fixnum
+                                     positive-fixnum))
+                        ((:arg type unsigned-reg eax-offset)
+                         (:arg length any-reg ebx-offset)
+                         (:arg words any-reg ecx-offset)
+                         (:res result descriptor-reg edx-offset))
+  (inst mov result (+ (1- (ash 1 n-lowtag-bits))
+                     (* vector-data-offset n-word-bytes)))
+  (inst add result words)
+  (inst and result (lognot lowtag-mask))
+  (pseudo-atomic
+   (allocation result result)
+   (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+   (storew type result 0 other-pointer-lowtag)
+   (storew length result vector-length-slot other-pointer-lowtag))
+  (inst ret))
+\f
+;;;; Note: CMU CL had assembly language primitives for hashing strings,
+;;;; but SBCL doesn't.
diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp

new file mode 100644 (file)

index 0000000..caa75e5
--- /dev/null
+++ b/src/assembly/x86-64/assem-rtns.lisp
@@ -0,0 +1,263 @@
+;;;; the machine specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; RETURN-MULTIPLE
+
+;;; For RETURN-MULTIPLE, we have to move the results from the end of
+;;; the frame for the function that is returning to the end of the
+;;; frame for the function being returned to.
+
+#+sb-assembling ;; We don't want a vop for this one.
+(define-assembly-routine
+    (return-multiple (:return-style :none))
+    (;; These four are really arguments.
+     (:temp eax unsigned-reg rax-offset)
+     (:temp ebx unsigned-reg rbx-offset)
+     (:temp ecx unsigned-reg rcx-offset)
+     (:temp esi unsigned-reg rsi-offset)
+
+     ;; These we need as temporaries.
+     (:temp edx unsigned-reg rdx-offset)
+     (:temp edi unsigned-reg rdi-offset))
+
+  ;; Pick off the cases where everything fits in register args.
+  (inst jecxz zero-values)
+  (inst cmp ecx (fixnumize 1))
+  (inst jmp :e one-value)
+  (inst cmp ecx (fixnumize 2))
+  (inst jmp :e two-values)
+  (inst cmp ecx (fixnumize 3))
+  (inst jmp :e three-values)
+
+  ;; Save the count, because the loop is going to destroy it.
+  (inst mov edx ecx)
+
+  ;; Blit the values down the stack. Note: there might be overlap, so
+  ;; we have to be careful not to clobber values before we've read
+  ;; them. Because the stack builds down, we are coping to a larger
+  ;; address. Therefore, we need to iterate from larger addresses to
+  ;; smaller addresses. pfw-this says copy ecx words from esi to edi
+  ;; counting down.
+  (inst shr ecx 3)                     ; fixnum to raw word count
+  (inst std)                           ; count down
+  (inst sub esi 8)                     ; ?
+  (inst lea edi (make-ea :qword :base ebx :disp (- n-word-bytes)))
+  (inst rep)
+  (inst movs :qword)
+
+  ;; Restore the count.
+  (inst mov ecx edx)
+
+  ;; Set the stack top to the last result.
+  (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes))
+
+  ;; Load the register args.
+  (loadw edx ebx -1)
+  (loadw edi ebx -2)
+  (loadw esi ebx -3)
+
+  ;; And back we go.
+  (inst jmp eax)
+
+  ;; Handle the register arg cases.
+  ZERO-VALUES
+  (move rsp-tn ebx)
+  (inst mov edx nil-value)
+  (inst mov edi edx)
+  (inst mov esi edx)
+  (inst jmp eax)
+
+  ONE-VALUE ; Note: we can get this, because the return-multiple vop
+           ; doesn't check for this case when size > speed.
+  (loadw edx esi -1)
+  (inst mov rsp-tn ebx)
+  (inst add eax 3)
+  (inst jmp eax)
+
+  TWO-VALUES
+  (loadw edx esi -1)
+  (loadw edi esi -2)
+  (inst mov esi nil-value)
+  (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -2 n-word-bytes)))
+  (inst jmp eax)
+
+  THREE-VALUES
+  (loadw edx esi -1)
+  (loadw edi esi -2)
+  (loadw esi esi -3)
+  (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -3 n-word-bytes)))
+  (inst jmp eax))
+\f
+;;;; TAIL-CALL-VARIABLE
+
+;;; For tail-call-variable, we have to copy the arguments from the end
+;;; of our stack frame (were args are produced) to the start of our
+;;; stack frame (were args are expected).
+;;;
+;;; We take the function to call in EAX and a pointer to the arguments in
+;;; ESI. EBP says the same over the jump, and the old frame pointer is
+;;; still saved in the first stack slot. The return-pc is saved in
+;;; the second stack slot, so we have to push it to make it look like
+;;; we actually called. We also have to compute ECX from the difference
+;;; between ESI and the stack top.
+#+sb-assembling ;; No vop for this one either.
+(define-assembly-routine
+    (tail-call-variable
+     (:return-style :none))
+
+    ((:temp eax unsigned-reg rax-offset)
+     (:temp ebx unsigned-reg rbx-offset)
+     (:temp ecx unsigned-reg rcx-offset)
+     (:temp edx unsigned-reg rdx-offset)
+     (:temp edi unsigned-reg rdi-offset)
+     (:temp esi unsigned-reg rsi-offset))
+
+  ;; Calculate NARGS (as a fixnum)
+  (move ecx esi)
+  (inst sub ecx rsp-tn)
+
+  ;; Check for all the args fitting the the registers.
+  (inst cmp ecx (fixnumize 3))
+  (inst jmp :le REGISTER-ARGS)
+
+  ;; Save the OLD-FP and RETURN-PC because the blit it going to trash
+  ;; those stack locations. Save the ECX, because the loop is going
+  ;; to trash it.
+  (pushw rbp-tn -1)
+  (loadw ebx rbp-tn -2)
+  (inst push ecx)
+
+  ;; Do the blit. Because we are coping from smaller addresses to
+  ;; larger addresses, we have to start at the largest pair and work
+  ;; our way down.
+  (inst shr ecx 3)                     ; fixnum to raw words
+  (inst std)                           ; count down
+  (inst lea edi (make-ea :qword :base rbp-tn :disp (- n-word-bytes)))
+  (inst sub esi (fixnumize 1))
+  (inst rep)
+  (inst movs :qword)
+
+  ;; Load the register arguments carefully.
+  (loadw edx rbp-tn -1)
+
+  ;; Restore OLD-FP and ECX.
+  (inst pop ecx)
+  (popw rbp-tn -1)                     ; overwrites a0
+
+  ;; Blow off the stack above the arguments.
+  (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes))
+
+  ;; remaining register args
+  (loadw edi rbp-tn -2)
+  (loadw esi rbp-tn -3)
+
+  ;; Push the (saved) return-pc so it looks like we just called.
+  (inst push ebx)
+
+  ;; And jump into the function.
+    (inst jmp
+         (make-ea :byte :base eax
+                  :disp (- (* closure-fun-slot n-word-bytes)
+                           fun-pointer-lowtag)))
+
+  ;; All the arguments fit in registers, so load them.
+  REGISTER-ARGS
+  (loadw edx esi -1)
+  (loadw edi esi -2)
+  (loadw esi esi -3)
+
+  ;; Clear most of the stack.
+  (inst lea rsp-tn
+       (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes)))
+
+  ;; Push the return-pc so it looks like we just called.
+  (pushw rbp-tn -2)    ; XXX dan ? 
+  
+  ;; And away we go.
+  (inst jmp (make-ea :byte :base eax
+                    :disp (- (* closure-fun-slot n-word-bytes)
+                             fun-pointer-lowtag))))
+\f
+(define-assembly-routine (throw
+                         (:return-style :none))
+                        ((:arg target (descriptor-reg any-reg) rdx-offset)
+                         (:arg start any-reg rbx-offset)
+                         (:arg count any-reg rcx-offset)
+                         (:temp catch any-reg rax-offset))
+
+  (declare (ignore start count))
+
+  (load-tl-symbol-value catch *current-catch-block*)
+
+  LOOP
+
+  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+    (inst or catch catch)              ; check for NULL pointer
+    (inst jmp :z error))
+
+  (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
+  (inst jmp :e exit)
+
+  (loadw catch catch catch-block-previous-catch-slot)
+  (inst jmp loop)
+
+  EXIT
+
+  ;; Here EAX points to catch block containing symbol pointed to by EDX.
+  (inst jmp (make-fixup 'unwind :assembly-routine)))
+
+;;;; non-local exit noise
+
+(define-assembly-routine (unwind
+                         (:return-style :none)
+                         (:translate %continue-unwind)
+                         (:policy :fast-safe))
+                        ((:arg block (any-reg descriptor-reg) rax-offset)
+                         (:arg start (any-reg descriptor-reg) rbx-offset)
+                         (:arg count (any-reg descriptor-reg) rcx-offset)
+                         (:temp uwp unsigned-reg rsi-offset))
+  (declare (ignore start count))
+
+  (let ((error (generate-error-code nil invalid-unwind-error)))
+    (inst or block block)              ; check for NULL pointer
+    (inst jmp :z error))
+
+  (load-tl-symbol-value uwp *current-unwind-protect-block*)
+
+  ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in
+  ;; argument's CURRENT-UWP-SLOT?
+  (inst cmp uwp
+       (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
+  ;; If a match, return to context in arg block.
+  (inst jmp :e do-exit)
+
+  ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context.
+  ;; Important! Must save (and return) the arg 'block' for later use!!
+  (move rdx-tn block)
+  (move block uwp)
+  ;; Set next unwind protect context.
+  (loadw uwp uwp unwind-block-current-uwp-slot)
+  ;; we're about to reload ebp anyway, so let's borrow it here as a
+  ;; temporary.  Hope this works
+  (store-tl-symbol-value uwp *current-unwind-protect-block* rbp-tn)
+
+  DO-EXIT
+
+  (loadw rbp-tn block unwind-block-current-cont-slot)
+
+  ;; Uwp-entry expects some things in known locations so that they can
+  ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
+  ;; count in ecx-tn.
+
+  (inst jmp (make-ea :byte :base block
+                    :disp (* unwind-block-entry-pc-slot n-word-bytes))))
diff --git a/src/assembly/x86-64/bit-bash.lisp b/src/assembly/x86-64/bit-bash.lisp

new file mode 100644 (file)

index 0000000..15f45ab
--- /dev/null
+++ b/src/assembly/x86-64/bit-bash.lisp
@@ -0,0 +1,12 @@
+;;;; just a dummy file to maintain parallelism with other VMs
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp

new file mode 100644 (file)

index 0000000..e96ddbc
--- /dev/null
+++ b/src/assembly/x86-64/support.lisp
@@ -0,0 +1,46 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(!def-vm-support-routine generate-call-sequence (name style vop)
+  (ecase style
+    (:raw
+     (values
+      `((inst lea r13-tn
+             (make-ea :qword :disp (make-fixup ',name :assembly-routine)))
+       (inst call r13-tn))
+      nil))
+    (:full-call
+     (values
+      `((note-this-location ,vop :call-site)
+       (inst lea r13-tn
+             (make-ea :qword :disp (make-fixup ',name :assembly-routine)))
+       (inst call r13-tn)
+       (note-this-location ,vop :single-value-return)
+       (move rsp-tn rbx-tn))
+      '((:save-p :compute-only))))
+    (:none
+     (values
+      `((inst lea r13-tn
+             (make-ea :qword :disp (make-fixup ',name :assembly-routine)))
+       (inst jmp r13-tn))
+      nil))))
+
+(!def-vm-support-routine generate-return-sequence (style)
+  (ecase style
+    (:raw
+     `(inst ret))
+    (:full-call
+     `(
+       (inst pop rax-tn)
+
+       (inst add rax-tn 3)
+       (inst jmp rax-tn)))
+    (:none)))
diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp

index d05a6fa..86656c7 100644 (file)
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -1184,8 +1184,8 @@
    (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
    (let ((res (dpb exp
                   sb!vm:single-float-exponent-byte
    (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
    (let ((res (dpb exp
                   sb!vm:single-float-exponent-byte
-                 (logandc2 (sb!ext:truly-the (unsigned-byte #.(1- sb!vm:n-word-bits))
-                                             (%bignum-ref bits 1))
+                 (logandc2 (logand #xffffffff
+                                   (%bignum-ref bits 1))
                             sb!vm:single-float-hidden-bit))))
      (make-single-float
       (if plusp
                             sb!vm:single-float-hidden-bit))))
      (make-single-float
       (if plusp
@@ -1196,14 +1196,15 @@
    (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
    (let ((hi (dpb exp
                  sb!vm:double-float-exponent-byte
    (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
    (let ((hi (dpb exp
                  sb!vm:double-float-exponent-byte
-                (logandc2 (sb!ext:truly-the (unsigned-byte #.(1- sb!vm:n-word-bits))
-                                            (%bignum-ref bits 2))
-                          sb!vm:double-float-hidden-bit))))
-    (make-double-float
-     (if plusp
-        hi
-        (logior hi (ash -1 sb!vm:float-sign-shift)))
-     (%bignum-ref bits 1))))
+                (logandc2 (ecase sb!vm::n-word-bits
+                            (32 (%bignum-ref bits 2))
+                            (64 (ash (%bignum-ref bits 1) -32)))
+                          sb!vm:double-float-hidden-bit)))
+       (lo (logand #xffffffff (%bignum-ref bits 1))))
+    (make-double-float (if plusp
+                          hi
+                          (logior hi (ash -1 sb!vm:float-sign-shift)))
+                      lo)))
  #!+(and long-float x86)
  (defun long-float-from-bits (bits exp plusp)
    (declare (fixnum exp))
  #!+(and long-float x86)
  (defun long-float-from-bits (bits exp plusp)
    (declare (fixnum exp))
diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp

index 66cfb57..0ca7ed6 100644 (file)
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -109,24 +109,27 @@
            (type index offset)
            (values system-area-pointer index))
    (let ((address (sap-int sap)))
            (type index offset)
            (values system-area-pointer index))
    (let ((address (sap-int sap)))
-    (values (int-sap #!-alpha (word-logical-andc2 address 3)
+    (values (int-sap #!-alpha (word-logical-andc2 address
+                                                 sb!vm::fixnum-tag-mask)
                      #!+alpha (ash (ash address -2) 2))
                      #!+alpha (ash (ash address -2) 2))
-           (+ (* (logand address 3) n-byte-bits) offset))))
+           (+ (* (logand address sb!vm::fixnum-tag-mask) n-byte-bits)
+              offset))))
  
  #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
  (defun word-sap-ref (sap offset)
    (declare (type system-area-pointer sap)
            (type index offset)
  
  #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
  (defun word-sap-ref (sap offset)
    (declare (type system-area-pointer sap)
            (type index offset)
-          (values (unsigned-byte 32))
+          (values sb!vm:word)
            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
-  (sap-ref-32 sap (the index (ash offset 2))))
+  (sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits))))
  (defun %set-word-sap-ref (sap offset value)
    (declare (type system-area-pointer sap)
            (type index offset)
  (defun %set-word-sap-ref (sap offset value)
    (declare (type system-area-pointer sap)
            (type index offset)
-          (type (unsigned-byte 32) value)
-          (values (unsigned-byte 32))
+          (type sb!vm:word value)
+          (values sb!vm:word)
            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (setf (sap-ref-32 sap (the index (ash offset 2))) value))
+  (setf (sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits)))
+       value))
  \f
  ;;;; CONSTANT-BIT-BASH
  
  \f
  ;;;; CONSTANT-BIT-BASH
  
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp

index f3217e6..db603e9 100644 (file)
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -184,10 +184,10 @@
             (setf (svref *!load-time-values* (third toplevel-thing))
                   (funcall (second toplevel-thing))))
            (:load-time-value-fixup
             (setf (svref *!load-time-values* (third toplevel-thing))
                   (funcall (second toplevel-thing))))
            (:load-time-value-fixup
-           (setf (sap-ref-32 (second toplevel-thing) 0)
+           (setf (sap-ref-word (second toplevel-thing) 0)
                   (get-lisp-obj-address
                    (svref *!load-time-values* (third toplevel-thing)))))
                   (get-lisp-obj-address
                    (svref *!load-time-values* (third toplevel-thing)))))
-          #!+(and x86 gencgc)
+          #!+(and (or x86 x86-64) gencgc)
            (:load-time-code-fixup
             (sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
                                                    (third  toplevel-thing)
            (:load-time-code-fixup
             (sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
                                                    (third  toplevel-thing)
diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp

index 86d8082..51efcbf 100644 (file)
--- a/src/code/cross-misc.lisp
+++ b/src/code/cross-misc.lisp
@@ -145,10 +145,10 @@
    (assert (typep array '(simple-array * (*))))
    (values array start end 0))
  
    (assert (typep array '(simple-array * (*))))
    (values array start end 0))
  
-#!-alpha
+#!-(or alpha x86-64)
  (defun sb!vm::ash-left-mod32 (integer amount)
    (ldb (byte 32 0) (ash integer amount)))
  (defun sb!vm::ash-left-mod32 (integer amount)
    (ldb (byte 32 0) (ash integer amount)))
-#!+alpha
+#!+(or alpha x86-64)
  (defun sb!vm::ash-left-mod64 (integer amount)
    (ldb (byte 64 0) (ash integer amount)))
  
  (defun sb!vm::ash-left-mod64 (integer amount)
    (ldb (byte 64 0) (ash integer amount)))
  
diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp

index 739fa11..574adeb 100644 (file)
--- a/src/code/cross-sap.lisp
+++ b/src/code/cross-sap.lisp
@@ -54,9 +54,13 @@
                '(sap-ref-8
                  sap-ref-16
                  sap-ref-32
                '(sap-ref-8
                  sap-ref-16
                  sap-ref-32
+                sap-ref-64
                  sap-ref-sap
                  sap-ref-sap
+                sap-ref-word
                  sap-ref-single
                  sap-ref-double
                  signed-sap-ref-8
                  signed-sap-ref-16
                  sap-ref-single
                  sap-ref-double
                  signed-sap-ref-8
                  signed-sap-ref-16
-                signed-sap-ref-32)))
+                signed-sap-ref-32
+                signed-sap-ref-64
+                signed-sap-ref-word)))
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp

index 9964063..0d52c97 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -539,9 +539,9 @@
    (make-lisp-obj (logior (sap-int component-ptr)
                          sb!vm:other-pointer-lowtag)))
  
    (make-lisp-obj (logior (sap-int component-ptr)
                          sb!vm:other-pointer-lowtag)))
  
-;;;; X86 support
+;;;; (OR X86 X86-64) support
  
  
-#!+x86
+#!+(or x86 x86-64)
  (progn
  
  (defun compute-lra-data-from-pc (pc)
  (progn
  
  (defun compute-lra-data-from-pc (pc)
@@ -587,18 +587,21 @@
  (defun x86-call-context (fp &key (depth 0))
    (declare (type system-area-pointer fp)
            (fixnum depth))
  (defun x86-call-context (fp &key (depth 0))
    (declare (type system-area-pointer fp)
            (fixnum depth))
-  ;;(format t "*CC ~S ~S~%" fp depth)
+;;  (format t "*CC ~S ~S~%" fp depth)
    (cond
     ((not (control-stack-pointer-valid-p fp))
      #+nil (format t "debug invalid fp ~S~%" fp)
      nil)
     (t
      ;; Check the two possible frame pointers.
    (cond
     ((not (control-stack-pointer-valid-p fp))
      #+nil (format t "debug invalid fp ~S~%" fp)
      nil)
     (t
      ;; Check the two possible frame pointers.
-    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4))))
+    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset)
+                                          sb!vm::n-word-bytes))))
           (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
           (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
-                                        4))))
+                                        sb!vm::n-word-bytes))))
           (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
           (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
           (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
           (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
+      #+nil (format t "  lisp-ocfp=~S~%  lisp-ra=~S~%  c-ocfp=~S~%  c-ra=~S~%"
+             lisp-ocfp lisp-ra c-ocfp c-ra)
        (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
                   (ra-pointer-valid-p lisp-ra)
                   (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
        (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
                   (ra-pointer-valid-p lisp-ra)
                   (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
@@ -701,10 +704,10 @@
                   (bogus-debug-fun
                    (let ((fp (frame-pointer frame)))
                      (when (control-stack-pointer-valid-p fp)
                   (bogus-debug-fun
                    (let ((fp (frame-pointer frame)))
                      (when (control-stack-pointer-valid-p fp)
-                      #!+x86
+                      #!+(or x86 x86-64)
                         (multiple-value-bind (ra ofp) (x86-call-context fp)
                          (and ra (compute-calling-frame ofp ra frame)))
                         (multiple-value-bind (ra ofp) (x86-call-context fp)
                          (and ra (compute-calling-frame ofp ra frame)))
-                       #!-x86
+                       #!-(or x86 x86-64)
                        (compute-calling-frame
                         #!-alpha
                         (sap-ref-sap fp (* ocfp-save-offset
                        (compute-calling-frame
                         #!-alpha
                         (sap-ref-sap fp (* ocfp-save-offset
@@ -722,7 +725,7 @@
  ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
  ;;; standard save location offset on the stack. LOC is the saved
  ;;; SC-OFFSET describing the main location.
  ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
  ;;; standard save location offset on the stack. LOC is the saved
  ;;; SC-OFFSET describing the main location.
-#!-x86
+#!-(or x86 x86-64)
  (defun get-context-value (frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
  (defun get-context-value (frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
@@ -731,7 +734,7 @@
      (if escaped
         (sub-access-debug-var-slot pointer loc escaped)
         (stack-ref pointer stack-slot))))
      (if escaped
         (sub-access-debug-var-slot pointer loc escaped)
         (stack-ref pointer stack-slot))))
-#!+x86
+#!+(or x86 x86-64)
  (defun get-context-value (frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
  (defun get-context-value (frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
@@ -743,9 +746,10 @@
           (#.ocfp-save-offset
            (stack-ref pointer stack-slot))
           (#.lra-save-offset
           (#.ocfp-save-offset
            (stack-ref pointer stack-slot))
           (#.lra-save-offset
-          (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
+          (sap-ref-sap pointer (- (* (1+ stack-slot)
+                                     sb!vm::n-word-bytes))))))))
  
  
-#!-x86
+#!-(or x86 x86-64)
  (defun (setf get-context-value) (value frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
  (defun (setf get-context-value) (value frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
@@ -755,7 +759,7 @@
         (sub-set-debug-var-slot pointer loc value escaped)
         (setf (stack-ref pointer stack-slot) value))))
  
         (sub-set-debug-var-slot pointer loc value escaped)
         (setf (stack-ref pointer stack-slot) value))))
  
-#!+x86
+#!+(or x86 x86-64)
  (defun (setf get-context-value) (value frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
  (defun (setf get-context-value) (value frame stack-slot loc)
    (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
            (type sb!c:sc-offset loc))
@@ -767,7 +771,8 @@
           (#.ocfp-save-offset
            (setf (stack-ref pointer stack-slot) value))
           (#.lra-save-offset
           (#.ocfp-save-offset
            (setf (stack-ref pointer stack-slot) value))
           (#.lra-save-offset
-          (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+          (setf (sap-ref-sap pointer (- (* (1+ stack-slot)
+                                           sb!vm::n-word-bytes))) value))))))
  
  (defun foreign-function-backtrace-name (sap)
    (let ((name (foreign-symbol-in-address sap)))
  
  (defun foreign-function-backtrace-name (sap)
    (let ((name (foreign-symbol-in-address sap)))
@@ -789,7 +794,7 @@
  ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
  ;;; calls into C. In this case, the code object is stored on the stack
  ;;; after the LRA, and the LRA is the word offset.
  ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
  ;;; calls into C. In this case, the code object is stored on the stack
  ;;; after the LRA, and the LRA is the word offset.
-#!-x86
+#!-(or x86 x86-64)
  (defun compute-calling-frame (caller lra up-frame)
    (declare (type system-area-pointer caller))
    (when (control-stack-pointer-valid-p caller)
  (defun compute-calling-frame (caller lra up-frame)
    (declare (type system-area-pointer caller))
    (when (control-stack-pointer-valid-p caller)
@@ -833,7 +838,7 @@
                                                         escaped)
                                  (if up-frame (1+ (frame-number up-frame)) 0)
                                  escaped))))))
                                                         escaped)
                                  (if up-frame (1+ (frame-number up-frame)) 0)
                                  escaped))))))
-#!+x86
+#!+(or x86 x86-64)
  (defun compute-calling-frame (caller ra up-frame)
    (declare (type system-area-pointer caller ra))
    (/noshow0 "entering COMPUTE-CALLING-FRAME")
  (defun compute-calling-frame (caller ra up-frame)
    (declare (type system-area-pointer caller ra))
    (/noshow0 "entering COMPUTE-CALLING-FRAME")
@@ -883,7 +888,7 @@
                        (+ sb!vm::thread-interrupt-contexts-offset n))
                       (* os-context-t)))
  
                        (+ sb!vm::thread-interrupt-contexts-offset n))
                       (* os-context-t)))
  
-#!+x86
+#!+(or x86 x86-64)
  (defun find-escaped-frame (frame-pointer)
    (declare (type system-area-pointer frame-pointer))
    (/noshow0 "entering FIND-ESCAPED-FRAME")
  (defun find-escaped-frame (frame-pointer)
    (declare (type system-area-pointer frame-pointer))
    (/noshow0 "entering FIND-ESCAPED-FRAME")
@@ -923,7 +928,7 @@
                (return
                (values code pc-offset context)))))))))
  
                (return
                (values code pc-offset context)))))))))
  
-#!-x86
+#!-(or x86 x86-64)
  (defun find-escaped-frame (frame-pointer)
    (declare (type system-area-pointer frame-pointer))
    (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
  (defun find-escaped-frame (frame-pointer)
    (declare (type system-area-pointer frame-pointer))
    (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
@@ -983,7 +988,7 @@
                              nil))
                    (values code pc-offset scp))))))))))
  
                              nil))
                    (values code pc-offset scp))))))))))
  
-#!-x86
+#!-(or x86 x86-64)
  (defun find-pc-from-assembly-fun (code scp)
    "Finds the PC for the return from an assembly routine properly.
  For some architectures (such as PPC) this will not be the $LRA
  (defun find-pc-from-assembly-fun (code scp)
    "Finds the PC for the return from an assembly routine properly.
  For some architectures (such as PPC) this will not be the $LRA
@@ -1092,34 +1097,34 @@ register."
                        (sap-ref-32 catch
                                    (* sb!vm:catch-block-current-cont-slot
                                       sb!vm:n-word-bytes))))
                        (sap-ref-32 catch
                                    (* sb!vm:catch-block-current-cont-slot
                                       sb!vm:n-word-bytes))))
-           (let* (#!-x86
+           (let* (#!-(or x86 x86-64)
                    (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
                    (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
-                  #!+x86
+                  #!+(or x86 x86-64)
                    (ra (sap-ref-sap
                         catch (* sb!vm:catch-block-entry-pc-slot
                                  sb!vm:n-word-bytes)))
                    (ra (sap-ref-sap
                         catch (* sb!vm:catch-block-entry-pc-slot
                                  sb!vm:n-word-bytes)))
-                  #!-x86
+                  #!-(or x86 x86-64)
                    (component
                     (stack-ref catch sb!vm:catch-block-current-code-slot))
                    (component
                     (stack-ref catch sb!vm:catch-block-current-code-slot))
-                  #!+x86
+                  #!+(or x86 x86-64)
                    (component (component-from-component-ptr
                                (component-ptr-from-pc ra)))
                    (offset
                    (component (component-from-component-ptr
                                (component-ptr-from-pc ra)))
                    (offset
-                   #!-x86
+                   #!-(or x86 x86-64)
                     (* (- (1+ (get-header-data lra))
                           (get-header-data component))
                        sb!vm:n-word-bytes)
                     (* (- (1+ (get-header-data lra))
                           (get-header-data component))
                        sb!vm:n-word-bytes)
-                   #!+x86
+                   #!+(or x86 x86-64)
                     (- (sap-int ra)
                        (- (get-lisp-obj-address component)
                           sb!vm:other-pointer-lowtag)
                        (* (get-header-data component) sb!vm:n-word-bytes))))
                     (- (sap-int ra)
                        (- (get-lisp-obj-address component)
                           sb!vm:other-pointer-lowtag)
                        (* (get-header-data component) sb!vm:n-word-bytes))))
-             (push (cons #!-x86
+             (push (cons #!-(or x86 x86-64)
                           (stack-ref catch sb!vm:catch-block-tag-slot)
                           (stack-ref catch sb!vm:catch-block-tag-slot)
-                         #!+x86
+                         #!+(or x86 x86-64)
                           (make-lisp-obj
                           (make-lisp-obj
-                          (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
-                                               sb!vm:n-word-bytes)))
+                          (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                                 sb!vm:n-word-bytes)))
                           (make-compiled-code-location
                            offset (frame-debug-fun frame)))
                     reversed-result)))
                           (make-compiled-code-location
                            offset (frame-debug-fun frame)))
                     reversed-result)))
@@ -1984,9 +1989,9 @@ register."
  (defun make-valid-lisp-obj (val)
    (if (or
         ;; fixnum
  (defun make-valid-lisp-obj (val)
    (if (or
         ;; fixnum
-       (zerop (logand val 3))
+       (zerop (logand val sb!vm:fixnum-tag-mask))
         ;; character
         ;; character
-       (and (zerop (logand val #xffff0000)) ; Top bits zero
+       (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
             (= (logand val #xff) sb!vm:character-widetag)) ; char tag
         ;; unbound marker
         (= val sb!vm:unbound-marker-widetag)
             (= (logand val #xff) sb!vm:character-widetag)) ; char tag
         ;; unbound marker
         (= val sb!vm:unbound-marker-widetag)
@@ -2006,7 +2011,7 @@ register."
        (make-lisp-obj val)
        :invalid-object))
  
        (make-lisp-obj val)
        :invalid-object))
  
-#!-x86
+#!-(or x86 x86-64)
  (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
    (macrolet ((with-escaped-value ((var) &body forms)
                 `(if escaped
  (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
    (macrolet ((with-escaped-value ((var) &body forms)
                 `(if escaped
@@ -2149,7 +2154,7 @@ register."
           (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
                                      sb!vm:n-word-bytes)))))))
  
           (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
                                      sb!vm:n-word-bytes)))))))
  
-#!+x86
+#!+(or x86 x86-64)
  (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
    (declare (type system-area-pointer fp))
    (macrolet ((with-escaped-value ((var) &body forms)
  (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
    (declare (type system-area-pointer fp))
    (macrolet ((with-escaped-value ((var) &body forms)
@@ -2238,14 +2243,14 @@ register."
         (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
        (#.sb!vm:character-stack-sc-number
         (code-char
         (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
        (#.sb!vm:character-stack-sc-number
         (code-char
-       (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                            sb!vm:n-word-bytes)))))
+       (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+                              sb!vm:n-word-bytes)))))
        (#.sb!vm:unsigned-stack-sc-number
        (#.sb!vm:unsigned-stack-sc-number
-       (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                           sb!vm:n-word-bytes))))
+       (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+                             sb!vm:n-word-bytes))))
        (#.sb!vm:signed-stack-sc-number
        (#.sb!vm:signed-stack-sc-number
-       (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                  sb!vm:n-word-bytes))))
+       (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+                                    sb!vm:n-word-bytes))))
        (#.sb!vm:sap-stack-sc-number
         (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                              sb!vm:n-word-bytes)))))))
        (#.sb!vm:sap-stack-sc-number
         (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                              sb!vm:n-word-bytes)))))))
@@ -2278,7 +2283,7 @@ register."
              (compiled-debug-var-sc-offset debug-var))
          value))))
  
              (compiled-debug-var-sc-offset debug-var))
          value))))
  
-#!-x86
+#!-(or x86 x86-64)
  (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
    (macrolet ((set-escaped-value (val)
                `(if escaped
  (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
    (macrolet ((set-escaped-value (val)
                `(if escaped
@@ -2437,7 +2442,7 @@ register."
                                    sb!vm:n-word-bytes))
                (the system-area-pointer value)))))))
  
                                    sb!vm:n-word-bytes))
                (the system-area-pointer value)))))))
  
-#!+x86
+#!+(or x86 x86-64)
  (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
    (macrolet ((set-escaped-value (val)
                `(if escaped
  (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
    (macrolet ((set-escaped-value (val)
                `(if escaped
@@ -2516,18 +2521,18 @@ register."
        (#.sb!vm:control-stack-sc-number
         (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
        (#.sb!vm:character-stack-sc-number
        (#.sb!vm:control-stack-sc-number
         (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
        (#.sb!vm:character-stack-sc-number
-       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                        sb!vm:n-word-bytes)))
+       (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+                                   sb!vm:n-word-bytes)))
              (char-code (the character value))))
        (#.sb!vm:unsigned-stack-sc-number
              (char-code (the character value))))
        (#.sb!vm:unsigned-stack-sc-number
-       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                        sb!vm:n-word-bytes)))
-            (the (unsigned-byte 32) value)))
+       (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+                                   sb!vm:n-word-bytes)))
+            (the sb!vm:word value)))
        (#.sb!vm:signed-stack-sc-number
        (#.sb!vm:signed-stack-sc-number
-       (setf (signed-sap-ref-32
+       (setf (signed-sap-ref-word
               fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                        sb!vm:n-word-bytes)))
               fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                        sb!vm:n-word-bytes)))
-            (the (signed-byte 32) value)))
+            (the (signed-byte #.sb!vm:n-word-bits) value)))
        (#.sb!vm:sap-stack-sc-number
         (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                           sb!vm:n-word-bytes)))
        (#.sb!vm:sap-stack-sc-number
         (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                           sb!vm:n-word-bytes)))
@@ -2891,7 +2896,7 @@ register."
      (do ((frame frame (frame-down frame)))
         ((not frame) nil)
        (when (and (compiled-frame-p frame)
      (do ((frame frame (frame-down frame)))
         ((not frame) nil)
        (when (and (compiled-frame-p frame)
-                 (#!-x86 eq #!+x86 sap=
+                 (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap=
                   lra
                   (get-context-value frame lra-save-offset lra-sc-offset)))
         (return t)))))
                   lra
                   (get-context-value frame lra-save-offset lra-sc-offset)))
         (return t)))))
@@ -3225,8 +3230,8 @@ register."
  (defun get-fun-end-breakpoint-values (scp)
    (let ((ocfp (int-sap (sb!vm:context-register
                         scp
  (defun get-fun-end-breakpoint-values (scp)
    (let ((ocfp (int-sap (sb!vm:context-register
                         scp
-                       #!-x86 sb!vm::ocfp-offset
-                       #!+x86 sb!vm::ebx-offset)))
+                       #!-(or x86 x86-64) sb!vm::ocfp-offset
+                       #!+(or x86 x86-64) sb!vm::ebx-offset)))
         (nargs (make-lisp-obj
                 (sb!vm:context-register scp sb!vm::nargs-offset)))
         (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
         (nargs (make-lisp-obj
                 (sb!vm:context-register scp sb!vm::nargs-offset)))
         (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
@@ -3243,9 +3248,9 @@ register."
  ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
  
  (defconstant bogus-lra-constants
  ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
  
  (defconstant bogus-lra-constants
-  #!-x86 2 #!+x86 3)
+  #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3)
  (defconstant known-return-p-slot
  (defconstant known-return-p-slot
-  (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
+  (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2))
  
  ;;; Make a bogus LRA object that signals a breakpoint trap when
  ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
  
  ;;; Make a bogus LRA object that signals a breakpoint trap when
  ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
@@ -3270,9 +3275,9 @@ register."
       (setf (%code-debug-info code-object) :bogus-lra)
       (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
            length)
       (setf (%code-debug-info code-object) :bogus-lra)
       (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
            length)
-     #!-x86
+     #!-(or x86 x86-64)
       (setf (code-header-ref code-object real-lra-slot) real-lra)
       (setf (code-header-ref code-object real-lra-slot) real-lra)
-     #!+x86
+     #!+(or x86 x86-64)
       (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
         (setf (code-header-ref code-object real-lra-slot) code)
         (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
       (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
         (setf (code-header-ref code-object real-lra-slot) code)
         (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
@@ -3280,9 +3285,9 @@ register."
            known-return-p)
       (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits))
       (sb!vm:sanctify-for-execution code-object)
            known-return-p)
       (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits))
       (sb!vm:sanctify-for-execution code-object)
-     #!+x86
+     #!+(or x86 x86-64)
       (values dst-start code-object (sap- trap-loc src-start))
       (values dst-start code-object (sap- trap-loc src-start))
-     #!-x86
+     #!-(or x86 x86-64)
       (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
                                       sb!vm:other-pointer-lowtag))))
         (set-header-data
       (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
                                       sb!vm:other-pointer-lowtag))))
         (set-header-data
diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp

index 9a9e11c..002e818 100644 (file)
--- a/src/code/defsetfs.lisp
+++ b/src/code/defsetfs.lisp
@@ -41,12 +41,10 @@
  (defsetf %instance-ref %instance-set)
  (defsetf %raw-ref-single %raw-set-single)
  (defsetf %raw-ref-double %raw-set-double)
  (defsetf %instance-ref %instance-set)
  (defsetf %raw-ref-single %raw-set-single)
  (defsetf %raw-ref-double %raw-set-double)
-#!+long-float
-(defsetf %raw-ref-long %raw-set-long)
+
  (defsetf %raw-ref-complex-single %raw-set-complex-single)
  (defsetf %raw-ref-complex-double %raw-set-complex-double)
  (defsetf %raw-ref-complex-single %raw-set-complex-single)
  (defsetf %raw-ref-complex-double %raw-set-complex-double)
-#!+long-float
-(defsetf %raw-ref-complex-long %raw-set-complex-long)
+
  (defsetf %instance-layout %set-instance-layout)
  (defsetf %funcallable-instance-info %set-funcallable-instance-info)
  
  (defsetf %instance-layout %set-instance-layout)
  (defsetf %funcallable-instance-info %set-funcallable-instance-info)
  
@@ -118,6 +116,8 @@
  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
  (defsetf sap-ref-64 %set-sap-ref-64)
  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
  (defsetf sap-ref-64 %set-sap-ref-64)
  (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
+(defsetf sap-ref-word %set-sap-ref-word)
+(defsetf signed-sap-ref-word %set-signed-sap-ref-word)
  (defsetf sap-ref-sap %set-sap-ref-sap)
  (defsetf sap-ref-single %set-sap-ref-single)
  (defsetf sap-ref-double %set-sap-ref-double)
  (defsetf sap-ref-sap %set-sap-ref-sap)
  (defsetf sap-ref-single %set-sap-ref-single)
  (defsetf sap-ref-double %set-sap-ref-double)
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp

index 8a72c68..5c3ff13 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -698,7 +698,7 @@
  ;;;
  ;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
  (defun structure-raw-slot-type-and-size (type)
  ;;;
  ;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
  (defun structure-raw-slot-type-and-size (type)
-  (cond ((and (sb!xc:subtypep type '(unsigned-byte 32))
+  (cond ((and (sb!xc:subtypep type 'sb!vm:word)
               (multiple-value-bind (fixnum? fixnum-certain?)
                   (sb!xc:subtypep type 'fixnum)
                 ;; (The extra test for FIXNUM-CERTAIN? here is
               (multiple-value-bind (fixnum? fixnum-certain?)
                   (sb!xc:subtypep type 'fixnum)
                 ;; (The extra test for FIXNUM-CERTAIN? here is
@@ -914,8 +914,9 @@
                           ;; FIXME: when the 64-bit world rolls
                           ;; around, this will need to be reviewed,
                           ;; along with the whole RAW-SLOT thing.
                           ;; FIXME: when the 64-bit world rolls
                           ;; around, this will need to be reviewed,
                           ;; along with the whole RAW-SLOT thing.
-                         `(truly-the (simple-array (unsigned-byte 32) (*))
-                                     ,raw-vector-bare-form))
+                         `(truly-the
+                           (simple-array sb!vm:word (*))
+                           ,raw-vector-bare-form))
                         raw-vector-bare-form)))
               `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
  
                         raw-vector-bare-form)))
               `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
  
@@ -1314,7 +1315,7 @@
          ,@(when raw-index
              `((setf (%instance-ref ,instance ,raw-index)
                      (make-array ,(dd-raw-length dd)
          ,@(when raw-index
              `((setf (%instance-ref ,instance ,raw-index)
                      (make-array ,(dd-raw-length dd)
-                                :element-type '(unsigned-byte 32)))))
+                                :element-type 'sb!vm:word))))
          ,@(mapcar (lambda (dsd value)
                      ;; (Note that we can't in general use the
                      ;; ordinary named slot setter function here
          ,@(mapcar (lambda (dsd value)
                      ;; (Note that we can't in general use the
                      ;; ordinary named slot setter function here
diff --git a/src/code/fop.lisp b/src/code/fop.lisp

index 33146bf..89bafa3 100644 (file)
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -89,11 +89,11 @@
    #+sb-xc-host (bug "READ-STRING-AS-WORDS called")
    (dotimes (i length)
      (setf (aref string i)
    #+sb-xc-host (bug "READ-STRING-AS-WORDS called")
    (dotimes (i length)
      (setf (aref string i)
-         (sb!xc:code-char (logior
-                            (read-byte stream)
-                            (ash (read-byte stream) 8)
-                            (ash (read-byte stream) 16)
-                            (ash (read-byte stream) 24)))))
+         (let ((code 0))
+           ;; FIXME: is this the same as READ-WORD-ARG?
+           (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
+             (setf code (logior code (ash (read-byte stream) 
+                                          (* k sb!vm:n-byte-bits))))))))
    (values))
  \f
  ;;;; miscellaneous fops
    (values))
  \f
  ;;;; miscellaneous fops
diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp

index 5e23aa0..4daef08 100644 (file)
--- a/src/code/foreign.lisp
+++ b/src/code/foreign.lisp
@@ -52,8 +52,7 @@
        ;; If the address is from linkage-table and refers to data
        ;; we need to do a bit of juggling.
        (if (and sharedp datap)
        ;; If the address is from linkage-table and refers to data
        ;; we need to do a bit of juggling.
        (if (and sharedp datap)
-          ;; FIXME: 64bit badness here
-          (int-sap (sap-ref-32 (int-sap addr) 0))
+          (int-sap (sap-ref-word (int-sap addr) 0))
            (int-sap addr)))))
  
  #-sb-xc-host
            (int-sap addr)))))
  
  #-sb-xc-host
diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp

index 1690fd3..8a79e0e 100644 (file)
--- a/src/code/hash-table.lisp
+++ b/src/code/hash-table.lisp
@@ -53,17 +53,20 @@
    (next-free-kv 0 :type index)
    ;; The index vector. This may be larger than the hash size to help
    ;; reduce collisions.
    (next-free-kv 0 :type index)
    ;; The index vector. This may be larger than the hash size to help
    ;; reduce collisions.
-  (index-vector (missing-arg) :type (simple-array (unsigned-byte 32) (*)))
+  (index-vector (missing-arg)
+               :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*)))
    ;; This table parallels the KV vector, and is used to chain together
    ;; the hash buckets, the free list, and the values needing rehash, a
    ;; slot will only ever be in one of these lists.
    ;; This table parallels the KV vector, and is used to chain together
    ;; the hash buckets, the free list, and the values needing rehash, a
    ;; slot will only ever be in one of these lists.
-  (next-vector (missing-arg) :type (simple-array (unsigned-byte 32) (*)))
+  (next-vector (missing-arg)
+              :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*)))
    ;; This table parallels the KV table, and can be used to store the
    ;; hash associated with the key, saving recalculation. Could be
    ;; useful for EQL, and EQUAL hash tables. This table is not needed
    ;; for EQ hash tables, and when present the value of #x80000000
    ;; represents EQ-based hashing on the respective key.
    ;; This table parallels the KV table, and can be used to store the
    ;; hash associated with the key, saving recalculation. Could be
    ;; useful for EQL, and EQUAL hash tables. This table is not needed
    ;; for EQ hash tables, and when present the value of #x80000000
    ;; represents EQ-based hashing on the respective key.
-  (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*)))))
+  (hash-vector nil :type (or null (simple-array (unsigned-byte
+                                                #.sb!vm:n-word-bits) (*)))))
  \f
  (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
    #!+sb-doc
  \f
  (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
    #!+sb-doc
diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp

index 08b69bb..cfcf76b 100644 (file)
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -125,17 +125,8 @@
  
  (defun make-single-float (x) (make-single-float x))
  (defun make-double-float (hi lo) (make-double-float hi lo))
  
  (defun make-single-float (x) (make-single-float x))
  (defun make-double-float (hi lo) (make-double-float hi lo))
-#!+long-float
-(defun make-long-float (exp hi #!+sparc mid lo)
-  (make-long-float exp hi #!+sparc mid lo))
+
  (defun single-float-bits (x) (single-float-bits x))
  (defun double-float-high-bits (x) (double-float-high-bits x))
  (defun double-float-low-bits (x) (double-float-low-bits x))
  (defun single-float-bits (x) (single-float-bits x))
  (defun double-float-high-bits (x) (double-float-high-bits x))
  (defun double-float-low-bits (x) (double-float-low-bits x))
-#!+long-float
-(defun long-float-exp-bits (x) (long-float-exp-bits x))
-#!+long-float
-(defun long-float-high-bits (x) (long-float-high-bits x))
-#!+(and long-float sparc)
-(defun long-float-mid-bits (x) (long-float-mid-bits x))
-#!+long-float
-(defun long-float-low-bits (x) (long-float-low-bits x))
+
diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp

index 16929b1..af798b0 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1453,13 +1453,13 @@ the first."
  ;;; arithmetic, as that is only (currently) defined for constant
  ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
  ;;; discussion of this hack.  -- CSR, 2003-10-09
  ;;; arithmetic, as that is only (currently) defined for constant
  ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
  ;;; discussion of this hack.  -- CSR, 2003-10-09
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
  (defun sb!vm::ash-left-mod32 (integer amount)
    (etypecase integer
      ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
      (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
      (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
  (defun sb!vm::ash-left-mod32 (integer amount)
    (etypecase integer
      ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
      (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
      (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
  (defun sb!vm::ash-left-mod64 (integer amount)
    (etypecase integer
      ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
  (defun sb!vm::ash-left-mod64 (integer amount)
    (etypecase integer
      ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
diff --git a/src/code/room.lisp b/src/code/room.lisp

index c7696b2..3dc375e 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -98,11 +98,16 @@
                  (simple-array-unsigned-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-31-widetag . 2)
                  (simple-array-unsigned-byte-32-widetag . 2)
                  (simple-array-unsigned-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-31-widetag . 2)
                  (simple-array-unsigned-byte-32-widetag . 2)
+                (simple-array-unsigned-byte-60-widetag . 3)
+                (simple-array-unsigned-byte-63-widetag . 3)
+                (simple-array-unsigned-byte-64-widetag . 3)
                  (simple-array-signed-byte-8-widetag . 0)
                  (simple-array-signed-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-29-widetag . 2)
                  (simple-array-signed-byte-30-widetag . 2)
                  (simple-array-signed-byte-32-widetag . 2)
                  (simple-array-signed-byte-8-widetag . 0)
                  (simple-array-signed-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-29-widetag . 2)
                  (simple-array-signed-byte-30-widetag . 2)
                  (simple-array-signed-byte-32-widetag . 2)
+                (simple-array-signed-byte-61-widetag . 3)
+                (simple-array-signed-byte-64-widetag . 3)
                  (simple-array-single-float-widetag . 2)
                  (simple-array-double-float-widetag . 3)
                  (simple-array-complex-single-float-widetag . 3)
                  (simple-array-single-float-widetag . 2)
                  (simple-array-double-float-widetag . 3)
                  (simple-array-complex-single-float-widetag . 3)
@@ -110,13 +115,14 @@
    (let* ((name (car stuff))
          (size (cdr stuff))
          (sname (string name)))
    (let* ((name (car stuff))
          (size (cdr stuff))
          (sname (string name)))
-    (setf (svref *meta-room-info* (symbol-value name))
-         (make-room-info :name (intern (subseq sname
-                                               0
-                                               (mismatch sname "-WIDETAG"
-                                                         :from-end t)))
-                         :kind :vector
-                         :length size))))
+    (when (boundp name)
+      (setf (svref *meta-room-info* (symbol-value name))
+           (make-room-info :name (intern (subseq sname
+                                                 0
+                                                 (mismatch sname "-WIDETAG"
+                                                           :from-end t)))
+                           :kind :vector
+                           :length size)))))
  
  (setf (svref *meta-room-info* simple-base-string-widetag)
        (make-room-info :name 'simple-base-string
  
  (setf (svref *meta-room-info* simple-base-string-widetag)
        (make-room-info :name 'simple-base-string
@@ -213,7 +219,7 @@
             #+nil
             (prev nil))
         (loop
             #+nil
             (prev nil))
         (loop
-         (let* ((header (sap-ref-32 current 0))
+         (let* ((header (sap-ref-word current 0))
                  (header-widetag (logand header #xFF))
                  (info (svref *room-info* header-widetag)))
             (cond
                  (header-widetag (logand header #xFF))
                  (info (svref *room-info* header-widetag)))
             (cond
@@ -441,7 +447,7 @@
                                (%primitive code-instructions obj))))
            (incf code-words words)
            (dotimes (i words)
                                (%primitive code-instructions obj))))
            (incf code-words words)
            (dotimes (i words)
-            (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
+            (when (zerop (sap-ref-word sap (* i n-word-bytes)))
                (incf no-ops))))))
       space)
  
                (incf no-ops))))))
       space)
  
@@ -484,7 +490,7 @@
              #.simple-array-unsigned-byte-32-widetag
              #.simple-array-signed-byte-8-widetag
              #.simple-array-signed-byte-16-widetag
              #.simple-array-unsigned-byte-32-widetag
              #.simple-array-signed-byte-8-widetag
              #.simple-array-signed-byte-16-widetag
-            #.simple-array-signed-byte-30-widetag
+            ; #.simple-array-signed-byte-30-widetag
              #.simple-array-signed-byte-32-widetag
              #.simple-array-single-float-widetag
              #.simple-array-double-float-widetag
              #.simple-array-signed-byte-32-widetag
              #.simple-array-single-float-widetag
              #.simple-array-double-float-widetag
diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp

index f2dfe10..0808fdd 100644 (file)
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -331,7 +331,8 @@
    (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].
    (let ((string-bytes 0)
         ;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].
-       (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
+       (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)
+                     (+ (length string-list) 2))))
      (declare (fixnum string-bytes vec-bytes))
      (dolist (s string-list)
        (enforce-type s simple-string)
      (declare (fixnum string-bytes vec-bytes))
      (dolist (s string-list)
        (enforce-type s simple-string)
@@ -340,7 +341,7 @@
      (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))
      (let* ((total-bytes (+ string-bytes vec-bytes))
            (vec-sap (sb-sys:allocate-system-memory total-bytes))
            (string-sap (sap+ vec-sap vec-bytes))
-          (i #-alpha 4 #+alpha 8))
+          (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))
        (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
        (dolist (s string-list)
        (declare (type (and unsigned-byte fixnum) total-bytes i)
                (type sb-sys:system-area-pointer vec-sap string-sap))
        (dolist (s string-list)
@@ -357,10 +358,12 @@
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
           ;; Blast the pointer to the string into place.
           (setf (sap-ref-sap vec-sap i) string-sap)
           (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
-         (incf i #-alpha 4 #+alpha 8)))
+         (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))))
        ;; Blast in the last null pointer.
        (setf (sap-ref-sap vec-sap i) (int-sap 0))
        ;; Blast in the last null pointer.
        (setf (sap-ref-sap vec-sap i) (int-sap 0))
-      (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
+      (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits
+                                        sb-vm::n-byte-bits))
+             total-bytes))))
  
  (defmacro with-c-strvec ((var str-list) &body body)
    (with-unique-names (sap size)
  
  (defmacro with-c-strvec ((var str-list) &body body)
    (with-unique-names (sap size)
diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp

index e35489e..1d312c3 100644 (file)
--- a/src/code/target-c-call.lisp
+++ b/src/code/target-c-call.lisp
@@ -22,12 +22,12 @@
  (define-alien-type char (integer 8))
  (define-alien-type short (integer 16))
  (define-alien-type int (integer 32))
  (define-alien-type char (integer 8))
  (define-alien-type short (integer 16))
  (define-alien-type int (integer 32))
-(define-alien-type long (integer #!-alpha 32 #!+alpha 64))
+(define-alien-type long (integer #.sb!vm::n-machine-word-bits))
  
  (define-alien-type unsigned-char (unsigned 8))
  (define-alien-type unsigned-short (unsigned 16))
  (define-alien-type unsigned-int (unsigned 32))
  
  (define-alien-type unsigned-char (unsigned 8))
  (define-alien-type unsigned-short (unsigned 16))
  (define-alien-type unsigned-int (unsigned 32))
-(define-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64))
+(define-alien-type unsigned-long (unsigned #.sb!vm::n-machine-word-bits))
  
  (define-alien-type float single-float)
  (define-alien-type double double-float)
  
  (define-alien-type float single-float)
  (define-alien-type double double-float)
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp

index 267e58b..33dc00d 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -395,8 +395,8 @@
        (when raw-index
         (let* ((data (%instance-ref structure raw-index))
                (raw-len (length data))
        (when raw-index
         (let* ((data (%instance-ref structure raw-index))
                (raw-len (length data))
-              (new (make-array raw-len :element-type '(unsigned-byte 32))))
-         (declare (type (simple-array (unsigned-byte 32) (*)) data))
+              (new (make-array raw-len :element-type 'sb!vm::word)))
+         (declare (type (simple-array sb!vm::word (*)) data))
           (setf (%instance-ref res raw-index) new)
           (dotimes (i raw-len)
             (setf (aref new i) (aref data i))))))
           (setf (%instance-ref res raw-index) new)
           (dotimes (i raw-len)
             (setf (aref new i) (aref data i))))))
diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp

index 38bae0c..70d6ddb 100644 (file)
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -161,12 +161,14 @@
            (length (almost-primify (max scaled-size
                                         (1+ +min-hash-table-size+))))
            (index-vector (make-array length
            (length (almost-primify (max scaled-size
                                         (1+ +min-hash-table-size+))))
            (index-vector (make-array length
-                                    :element-type '(unsigned-byte 32)
+                                    :element-type
+                                    '(unsigned-byte #.sb!vm:n-word-bits)
                                      :initial-element 0))
            ;; needs to be the same length as the KV vector
             ;; (FIXME: really?  why doesn't the code agree?)
            (next-vector (make-array size+1
                                      :initial-element 0))
            ;; needs to be the same length as the KV vector
             ;; (FIXME: really?  why doesn't the code agree?)
            (next-vector (make-array size+1
-                                   :element-type '(unsigned-byte 32)))
+                                   :element-type
+                                   '(unsigned-byte #.sb!vm:n-word-bits)))
            (kv-vector (make-array (* 2 size+1)
                                   :initial-element +empty-ht-slot+))
            (table (%make-hash-table
            (kv-vector (make-array (* 2 size+1)
                                   :initial-element +empty-ht-slot+))
            (table (%make-hash-table
@@ -182,7 +184,7 @@
                    :next-vector next-vector
                    :hash-vector (unless (eq test 'eq)
                                   (make-array size+1
                    :next-vector next-vector
                    :hash-vector (unless (eq test 'eq)
                                   (make-array size+1
-                                             :element-type '(unsigned-byte 32)
+                                             :element-type '(unsigned-byte #.sb!vm:n-word-bits)
                                               :initial-element +magic-hash-vector-value+)))))
        (declare (type index size+1 scaled-size length))
        ;; Set up the free list, all free. These lists are 0 terminated.
                                               :initial-element +magic-hash-vector-value+)))))
        (declare (type index size+1 scaled-size length))
        ;; Set up the free list, all free. These lists are 0 terminated.
@@ -246,18 +248,18 @@
          (new-kv-vector (make-array (* 2 new-size)
                                     :initial-element +empty-ht-slot+))
          (new-next-vector (make-array new-size
          (new-kv-vector (make-array (* 2 new-size)
                                     :initial-element +empty-ht-slot+))
          (new-next-vector (make-array new-size
-                                     :element-type '(unsigned-byte 32)
+                                     :element-type '(unsigned-byte #.sb!vm:n-word-bits)
                                       :initial-element 0))
          (new-hash-vector (when old-hash-vector
                             (make-array new-size
                                       :initial-element 0))
          (new-hash-vector (when old-hash-vector
                             (make-array new-size
-                                       :element-type '(unsigned-byte 32)
+                                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
                                         :initial-element +magic-hash-vector-value+)))
          (old-index-vector (hash-table-index-vector table))
          (new-length (almost-primify
                       (truncate (/ (float new-size)
                                 (hash-table-rehash-threshold table)))))
          (new-index-vector (make-array new-length
                                         :initial-element +magic-hash-vector-value+)))
          (old-index-vector (hash-table-index-vector table))
          (new-length (almost-primify
                       (truncate (/ (float new-size)
                                 (hash-table-rehash-threshold table)))))
          (new-index-vector (make-array new-length
-                                      :element-type '(unsigned-byte 32)
+                                      :element-type '(unsigned-byte #.sb!vm:n-word-bits)
                                        :initial-element 0)))
      (declare (type index new-size new-length old-size))
  
                                        :initial-element 0)))
      (declare (type index new-size new-length old-size))
  
diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp

index 97acbf8..c729bba 100644 (file)
--- a/src/code/target-random.lisp
+++ b/src/code/target-random.lisp
@@ -202,8 +202,7 @@
    (* arg
       (- (sb!impl::make-double-float
          (dpb (ash (random-chunk state)
    (* arg
       (- (sb!impl::make-double-float
          (dpb (ash (random-chunk state)
-                  (- sb!vm:double-float-digits random-chunk-length
-                     sb!vm:n-word-bits))
+                  (- sb!vm:double-float-digits random-chunk-length 32))
               sb!vm:double-float-significand-byte
               (sb!impl::double-float-high-bits 1d0))
          (random-chunk state))
               sb!vm:double-float-significand-byte
               (sb!impl::double-float-high-bits 1d0))
          (random-chunk state))
diff --git a/src/code/target-sap.lisp b/src/code/target-sap.lisp

index 0f937b6..d49334a 100644 (file)
--- a/src/code/target-sap.lisp
+++ b/src/code/target-sap.lisp
@@ -83,6 +83,12 @@
            (fixnum offset))
    (sap-ref-64 sap offset))
  
            (fixnum offset))
    (sap-ref-64 sap offset))
  
+;;; Return the unsigned word of natural size OFFSET bytes from SAP.
+(defun sap-ref-word (sap offset)
+  (declare (type system-area-pointer sap)
+          (fixnum offset))
+  (sap-ref-word sap offset))
+
  ;;; Return the 32-bit SAP at OFFSET bytes from SAP.
  (defun sap-ref-sap (sap offset)
    (declare (type system-area-pointer sap)
  ;;; Return the 32-bit SAP at OFFSET bytes from SAP.
  (defun sap-ref-sap (sap offset)
    (declare (type system-area-pointer sap)
@@ -132,6 +138,12 @@
            (fixnum offset))
    (signed-sap-ref-64 sap offset))
  
            (fixnum offset))
    (signed-sap-ref-64 sap offset))
  
+;;; Return the signed word of natural size OFFSET bytes from SAP.
+(defun signed-sap-ref-word (sap offset)
+  (declare (type system-area-pointer sap)
+          (fixnum offset))
+  (signed-sap-ref-word sap offset))
+
  (defun %set-sap-ref-8 (sap offset new-value)
    (declare (type system-area-pointer sap)
            (fixnum offset)
  (defun %set-sap-ref-8 (sap offset new-value)
    (declare (type system-area-pointer sap)
            (fixnum offset)
@@ -156,6 +168,12 @@
            (type (unsigned-byte 64) new-value))
    (setf (sap-ref-64 sap offset) new-value))
  
            (type (unsigned-byte 64) new-value))
    (setf (sap-ref-64 sap offset) new-value))
  
+(defun %set-sap-ref-word (sap offset new-value)
+  (declare (type system-area-pointer sap)
+          (fixnum offset)
+          (type (unsigned-byte #.sb!vm:n-machine-word-bits) new-value))
+  (setf (sap-ref-word sap offset) new-value))
+
  (defun %set-signed-sap-ref-8 (sap offset new-value)
    (declare (type system-area-pointer sap)
            (fixnum offset)
  (defun %set-signed-sap-ref-8 (sap offset new-value)
    (declare (type system-area-pointer sap)
            (fixnum offset)
@@ -180,6 +198,12 @@
            (type (signed-byte 64) new-value))
    (setf (signed-sap-ref-64 sap offset) new-value))
  
            (type (signed-byte 64) new-value))
    (setf (signed-sap-ref-64 sap offset) new-value))
  
+(defun %set-signed-sap-ref-word (sap offset new-value)
+  (declare (type system-area-pointer sap)
+          (fixnum offset)
+          (type (signed-byte #.sb!vm:n-machine-word-bits) new-value))
+  (setf (signed-sap-ref-word sap offset) new-value))
+
  (defun %set-sap-ref-sap (sap offset new-value)
    (declare (type system-area-pointer sap new-value)
            (fixnum offset))
  (defun %set-sap-ref-sap (sap offset new-value)
    (declare (type system-area-pointer sap new-value)
            (fixnum offset))
diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp

index 38422a1..df0ec12 100644 (file)
--- a/src/code/target-sxhash.lisp
+++ b/src/code/target-sxhash.lisp
@@ -89,28 +89,20 @@
    (declare (optimize (speed 3) (safety 0)))
    (declare (type string string))
    (declare (type index count))
    (declare (optimize (speed 3) (safety 0)))
    (declare (type string string))
    (declare (type index count))
-  (let ((result 0))
-    (declare (type (unsigned-byte 32) result))
-    (unless (typep string '(vector nil))
-      (dotimes (i count)
-       (declare (type index i))
-       (setf result
-             (ldb (byte 32 0)
-                  (+ result (char-code (aref string i)))))
-       (setf result
-             (ldb (byte 32 0)
-                  (+ result (ash result 10))))
-       (setf result
-             (logxor result (ash result -6)))))
-    (setf result
-         (ldb (byte 32 0)
-              (+ result (ash result 3))))
-    (setf result
-         (logxor result (ash result -11)))
-    (setf result
-         (ldb (byte 32 0)
-              (logxor result (ash result 15))))
-    (logand result most-positive-fixnum)))
+  (macrolet ((set-result (form)
+              `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form))))
+    (let ((result 0))
+      (declare (type (unsigned-byte #.sb!vm:n-word-bits) result))
+      (unless (typep string '(vector nil))
+       (dotimes (i count)
+         (declare (type index i))
+         (set-result (+ result (char-code (aref string i))))
+         (set-result (+ result (ash result 10)))
+         (set-result (logxor result (ash result -6)))))
+      (set-result (+ result (ash result 3)))
+      (set-result (logxor result (ash result -11)))
+      (set-result (logxor result (ash result 15)))
+      (logand result most-positive-fixnum))))
  ;;; test:
  ;;;   (let ((ht (make-hash-table :test 'equal)))
  ;;;     (do-all-symbols (symbol)
  ;;; test:
  ;;;   (let ((ht (make-hash-table :test 'equal)))
  ;;;     (do-all-symbols (symbol)
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp

index b882962..0bedaba 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -351,7 +351,8 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
    "Call FUNCTION once for each known thread, giving it the thread structure as argument"
    (let ((function (coerce function 'function)))
      (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
    "Call FUNCTION once for each known thread, giving it the thread structure as argument"
    (let ((function (coerce function 'function)))
      (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
-         then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
+         then  (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes
+                                             sb!vm::thread-next-slot))
           until (sb!sys:sap= thread (sb!sys:int-sap 0))
           collect (funcall function thread))))
  
           until (sb!sys:sap= thread (sb!sys:int-sap 0))
           collect (funcall function thread))))
  
@@ -359,9 +360,11 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
    (let ((thread (alien-sap (extern-alien "all_threads" (* t)))))
      (loop 
       (when (sb!sys:sap= thread (sb!sys:int-sap 0)) (return nil))
    (let ((thread (alien-sap (extern-alien "all_threads" (* t)))))
      (loop 
       (when (sb!sys:sap= thread (sb!sys:int-sap 0)) (return nil))
-     (let ((pid (sb!sys:sap-ref-32 thread (* 4 sb!vm::thread-pid-slot))))
+     (let ((pid (sb!sys:sap-ref-32 thread (* sb!vm:n-word-bytes
+                                            sb!vm::thread-pid-slot))))
         (when (= pid id) (return thread))
         (when (= pid id) (return thread))
-       (setf thread (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot)))))))
+       (setf thread (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes
+                                                 sb!vm::thread-next-slot)))))))
  
  ;;; internal use only.  If you think you need to use this, either you
  ;;; are an SBCL developer, are doing something that you should discuss
  
  ;;; internal use only.  If you think you need to use this, either you
  ;;; are an SBCL developer, are doing something that you should discuss
@@ -371,7 +374,8 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
    (let ((thread (thread-sap-from-id thread-id)))
      (when thread
        (let* ((index (sb!vm::symbol-tls-index symbol))
    (let ((thread (thread-sap-from-id thread-id)))
      (when thread
        (let* ((index (sb!vm::symbol-tls-index symbol))
-            (tl-val (sb!sys:sap-ref-32 thread (* 4 index))))
+            (tl-val (sb!sys:sap-ref-word thread
+                                         (* sb!vm:n-word-bytes index))))
         (if (eql tl-val sb!vm::unbound-marker-widetag)
             (sb!vm::symbol-global-value symbol)
             (sb!kernel:make-lisp-obj tl-val))))))
         (if (eql tl-val sb!vm::unbound-marker-widetag)
             (sb!vm::symbol-global-value symbol)
             (sb!kernel:make-lisp-obj tl-val))))))
diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp

index 886ed82..89f7bb2 100644 (file)
--- a/src/code/target-unithread.lisp
+++ b/src/code/target-unithread.lisp
@@ -16,11 +16,11 @@
  (defun sb!vm::current-thread-offset-sap (n) 
    (declare (type (unsigned-byte 27) n))
    (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) 
  (defun sb!vm::current-thread-offset-sap (n) 
    (declare (type (unsigned-byte 27) n))
    (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) 
-              (* n 4)))
+              (* n sb!vm:n-word-bytes)))
  
  (defun current-thread-id ()
    (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t))) 
  
  (defun current-thread-id ()
    (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t))) 
-              (* sb!vm::thread-pid-slot 4)))
+              (* sb!vm::thread-pid-slot sb!vm:n-word-bytes)))
  
  (defun reap-dead-threads ())
  
  
  (defun reap-dead-threads ())
  
diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp

index 4f3d0f2..2a8eb52 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -196,7 +196,7 @@ steppers to maintain contextual information.")
                  ((= offset bytes-per-scrub-unit)
                   (look (sap+ ptr bytes-per-scrub-unit) 0 count))
                  (t
                  ((= offset bytes-per-scrub-unit)
                   (look (sap+ ptr bytes-per-scrub-unit) 0 count))
                  (t
-                 (setf (sap-ref-32 ptr offset) 0)
+                 (setf (sap-ref-word ptr offset) 0)
                   (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
          (look (ptr offset count)
            (declare (type system-area-pointer ptr)
                   (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
          (look (ptr offset count)
            (declare (type system-area-pointer ptr)
@@ -206,11 +206,11 @@ steppers to maintain contextual information.")
            (cond ((>= (sap-int ptr) end-of-stack) 0)
                  ((= offset bytes-per-scrub-unit)
                   count)
            (cond ((>= (sap-int ptr) end-of-stack) 0)
                  ((= offset bytes-per-scrub-unit)
                   count)
-                ((zerop (sap-ref-32 ptr offset))
+                ((zerop (sap-ref-word ptr offset))
                   (look ptr (+ offset sb!vm:n-word-bytes) count))
                  (t
                   (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
                   (look ptr (+ offset sb!vm:n-word-bytes) count))
                  (t
                   (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
-      (declare (type (unsigned-byte 32) csp))
+      (declare (type sb!vm::word csp))
        (scrub (int-sap (- csp initial-offset))
              (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
              0)))
        (scrub (int-sap (- csp initial-offset))
              (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
              0)))
@@ -232,7 +232,7 @@ steppers to maintain contextual information.")
                     (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
                           0 count))
                    (t ;; need to fix bug in %SET-STACK-REF
                     (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
                           0 count))
                    (t ;; need to fix bug in %SET-STACK-REF
-                   (setf (sap-ref-32 loc 0) 0)
+                   (setf (sap-ref-word loc 0) 0)
                     (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
          (look (ptr offset count)
            (declare (type system-area-pointer ptr)
                     (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
          (look (ptr offset count)
            (declare (type system-area-pointer ptr)
@@ -247,7 +247,7 @@ steppers to maintain contextual information.")
                     (look ptr (+ offset sb!vm:n-word-bytes) count))
                    (t
                     (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
                     (look ptr (+ offset sb!vm:n-word-bytes) count))
                    (t
                     (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
-      (declare (type (unsigned-byte 32) csp))
+      (declare (type sb!vm::word csp))
        (scrub (int-sap (+ csp initial-offset))
              (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
              0))))
        (scrub (int-sap (+ csp initial-offset))
              (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
              0))))
diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp

new file mode 100644 (file)

index 0000000..50cd4f8
--- /dev/null
+++ b/src/code/x86-64-vm.lisp
@@ -0,0 +1,341 @@
+;;;; X86-64-specific runtime stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; OS-CONTEXT-T
+
+;;; a POSIX signal context, i.e. the type passed as the third 
+;;; argument to an SA_SIGACTION-style signal handler
+;;;
+;;; The real type does have slots, but at Lisp level, we never
+;;; access them, or care about the size of the object. Instead, we
+;;; always refer to these objects by pointers handed to us by the C
+;;; runtime library, and ask the runtime library any time we need
+;;; information about the contents of one of these objects. Thus, it
+;;; works to represent this as an object with no slots.
+;;;
+;;; KLUDGE: It would be nice to have a type definition analogous to
+;;; C's "struct os_context_t;", for an incompletely specified object
+;;; which can only be referred to by reference, but I don't know how
+;;; to do that in the FFI, so instead we just this bogus no-slots
+;;; representation. -- WHN 20000730
+;;;
+;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
+;;; it's no longer architecture-dependent, and probably belongs in
+;;; some other package, perhaps SB-KERNEL.
+(define-alien-type os-context-t (struct os-context-t-struct))
+\f
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+  #!+sb-doc
+  "Return a string describing the type of the local machine."
+  "X86-64")
+
+;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere
+(defun get-machine-version ()
+  #!+linux
+  (with-open-file (stream "/proc/cpuinfo"
+                         ;; Even on Linux it's an option to build
+                         ;; kernels without /proc filesystems, so
+                         ;; degrade gracefully.
+                         :if-does-not-exist nil)
+    (loop with line while (setf line (read-line stream nil))
+         ;; The field "model name" exists on kernel 2.4.21-rc6-ac1
+         ;; anyway, with values e.g.
+         ;;   "AMD Athlon(TM) XP 2000+"
+         ;;   "Intel(R) Pentium(R) M processor 1300MHz"
+         ;; which seem comparable to the information in the example
+         ;; in the MACHINE-VERSION page of the ANSI spec.
+          when (eql (search "model name" line) 0)
+          return (string-trim " " (subseq line (1+ (position #\: line))))))
+  #!-linux
+  nil)
+\f
+;;;; :CODE-OBJECT fixups
+
+;;; a counter to measure the storage overhead of these fixups
+(defvar *num-fixups* 0)
+;;; FIXME: When the system runs, it'd be interesting to see what this is.
+
+(declaim (inline adjust-fixup-array))
+(defun adjust-fixup-array (array size)
+  (let ((new (make-array size :element-type '(unsigned-byte 64))))
+    (replace new array)
+    new))
+
+;;; This gets called by LOAD to resolve newly positioned objects
+;;; with things (like code instructions) that have to refer to them.
+;;;
+;;; Add a fixup offset to the vector of fixup offsets for the given
+;;; code object.
+(defun fixup-code-object (code offset fixup kind)
+  (declare (type index offset))
+  (flet ((add-fixup (code offset)
+          ;; (We check for and ignore fixups for code objects in the
+          ;; read-only and static spaces. (In the old CMU CL code
+          ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*,
+          ;; but in SBCL relocatable dynamic space code is always in
+          ;; use, so we always do the check.)
+          (incf *num-fixups*)
+          (let ((fixups (code-header-ref code code-constants-offset)))
+            (cond ((typep fixups '(simple-array (unsigned-byte 64) (*)))
+                   (let ((new-fixups
+                          (adjust-fixup-array fixups (1+ (length fixups)))))
+                     (setf (aref new-fixups (length fixups)) offset)
+                     (setf (code-header-ref code code-constants-offset)
+                           new-fixups)))
+                  (t
+                   (unless (or (eq (widetag-of fixups)
+                                   unbound-marker-widetag)
+                               (zerop fixups))
+                     (format t "** Init. code FU = ~S~%" fixups)) ; FIXME
+                   (setf (code-header-ref code code-constants-offset)
+                         (make-array
+                          1
+                          :element-type '(unsigned-byte 64)
+                          :initial-element offset)))))))
+    (sb!sys:without-gcing
+     (let* ((sap (truly-the system-area-pointer
+                           (sb!kernel:code-instructions code)))
+           (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code)
+                                   #xfffffffffffffff8))
+           (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+                                             code)))
+           (ncode-words (sb!kernel:code-header-ref code 1))
+           (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
+       (unless (member kind '(:absolute :absolute64 :relative))
+        (error "Unknown code-object-fixup kind ~S." kind))
+       (ecase kind
+        (:absolute64
+         ;; Word at sap + offset contains a value to be replaced by
+         ;; adding that value to fixup.
+         (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset)))
+         ;; Record absolute fixups that point within the code object.
+         (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr)
+           (add-fixup code offset)))
+        (:absolute
+         ;; Word at sap + offset contains a value to be replaced by
+         ;; adding that value to fixup.
+         (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
+         ;; Record absolute fixups that point within the code object.
+         (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+           (add-fixup code offset)))
+        (:relative
+         ;; Fixup is the actual address wanted.
+         ;;
+         ;; Record relative fixups that point outside the code
+         ;; object.
+         (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+           (add-fixup code offset))
+         ;; Replace word with value to add to that loc to get there.
+         (let* ((loc-sap (+ (sap-int sap) offset))
+                (rel-val (- fixup loc-sap (/ n-word-bytes 2))))
+           (declare (type (unsigned-byte 64) loc-sap)
+                    (type (signed-byte 32) rel-val))
+           (setf (signed-sap-ref-32 sap offset) rel-val))))))
+    nil))
+
+;;; Add a code fixup to a code object generated by GENESIS. The fixup
+;;; has already been applied, it's just a matter of placing the fixup
+;;; in the code's fixup vector if necessary.
+;;;
+;;; KLUDGE: I'd like a good explanation of why this has to be done at
+;;; load time instead of in GENESIS. It's probably simple, I just haven't
+;;; figured it out, or found it written down anywhere. -- WHN 19990908
+#!+gencgc
+(defun !envector-load-time-code-fixup (code offset fixup kind)
+  (flet ((frob (code offset)
+          (let ((fixups (code-header-ref code code-constants-offset)))
+            (cond ((typep fixups '(simple-array (unsigned-byte 64) (*)))
+                   (let ((new-fixups
+                          (adjust-fixup-array fixups (1+ (length fixups)))))
+                     (setf (aref new-fixups (length fixups)) offset)
+                     (setf (code-header-ref code code-constants-offset)
+                           new-fixups)))
+                  (t
+                   (unless (or (eq (widetag-of fixups)
+                                   unbound-marker-widetag)
+                               (zerop fixups))
+                     (sb!impl::!cold-lose "Argh! can't process fixup"))
+                   (setf (code-header-ref code code-constants-offset)
+                         (make-array
+                          1
+                          :element-type '(unsigned-byte 64)
+                          :initial-element offset)))))))
+    (let* ((sap (truly-the system-area-pointer
+                          (sb!kernel:code-instructions code)))
+          (obj-start-addr
+           ;; FIXME: looks like (LOGANDC2 foo typebits)
+           (logand (sb!kernel:get-lisp-obj-address code) #xfffffffffffffff8))
+          (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+                                            code)))
+          (ncode-words (sb!kernel:code-header-ref code 1))
+        (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
+      (ecase kind
+       (:absolute
+        ;; Record absolute fixups that point within the code object.
+        ;; The fixup data is 32 bits, don't use SAP-REF-64 here.
+        (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+          (frob code offset)))
+       (:relative
+        ;; Record relative fixups that point outside the code object.
+        (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+          (frob code offset)))))))
+\f
+;;;; low-level signal context access functions
+;;;;
+;;;; Note: In CMU CL, similar functions were hardwired to access
+;;;; BSD-style sigcontext structures defined as alien objects. Our
+;;;; approach is different in two ways:
+;;;;   1. We use POSIX SA_SIGACTION-style signals, so our context is
+;;;;      whatever the void pointer in the sigaction handler dereferences
+;;;;      to, not necessarily a sigcontext.
+;;;;   2. We don't try to maintain alien definitions of the context
+;;;;      structure at Lisp level, but instead call alien C functions
+;;;;      which take care of access for us. (Since the C functions can
+;;;;      be defined in terms of system standard header files, they
+;;;;      should be easier to maintain; and since Lisp code uses signal
+;;;;      contexts only in interactive or exception code (like the debugger
+;;;;      and internal error handling) the extra runtime cost should be
+;;;;      negligible.
+
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
+  ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
+  ;; 'unsigned *' interpretation for the 32-bit word passed to us by
+  ;; the C code, even though the C code may think it's an 'int *'.)
+  (context (* os-context-t)))
+
+(defun context-pc (context)
+  (declare (type (alien (* os-context-t)) context))
+  (let ((addr (context-pc-addr context)))
+    (declare (type (alien (* unsigned-long)) addr))
+    (int-sap (deref addr))))
+
+(define-alien-routine ("os_context_register_addr" context-register-addr)
+  (* unsigned-long)
+  ;; (Note the mismatch here between the 'int *' value that the C code
+  ;; may think it's giving us and the 'unsigned *' value that we
+  ;; receive. It's intentional: the C header files may think of
+  ;; register values as signed, but the CMU CL code tends to think of
+  ;; register values as unsigned, and might get bewildered if we ask
+  ;; it to work with signed values.)
+  (context (* os-context-t))
+  (index int))
+
+(defun context-register (context index)
+  (declare (type (alien (* os-context-t)) context))
+  (let ((addr (context-register-addr context index)))
+    (declare (type (alien (* unsigned-long)) addr))
+    (deref addr)))
+
+(defun %set-context-register (context index new)
+  (declare (type (alien (* os-context-t)) context))
+  (let ((addr (context-register-addr context index)))
+    (declare (type (alien (* unsigned-long)) addr))
+    (setf (deref addr) new)))
+
+;;; This is like CONTEXT-REGISTER, but returns the value of a float
+;;; register. FORMAT is the type of float to return.
+;;;
+;;; As of sbcl-0.6.7, there is no working code which calls this code,
+;;; so it's stubbed out. Someday, in order to make the debugger work
+;;; better, it may be necessary to unstubify it.
+(defun context-float-register (context index format)
+  (declare (ignore context index))
+  (warn "stub CONTEXT-FLOAT-REGISTER")
+  (coerce 0.0 format))
+(defun %set-context-float-register (context index format new-value)
+  (declare (ignore context index))
+  (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
+  (coerce new-value format))
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+  (declare (ignore context)) ; stub!
+  (warn "stub CONTEXT-FLOATING-POINT-MODES")
+  0)
+
+\f
+;;;; INTERNAL-ERROR-ARGS
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream.
+(defun internal-error-args (context)
+  (declare (type (alien (* os-context-t)) context))
+  (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
+  (/hexstr context)
+  (let ((pc (context-pc context)))
+    (declare (type system-area-pointer pc))
+    (/show0 "got PC")
+    ;; using INT3 the pc is .. INT3 <here> code length bytes...
+    (let* ((length (sap-ref-8 pc 1))
+          (vector (make-array length :element-type '(unsigned-byte 8))))
+      (declare (type (unsigned-byte 8) length)
+              (type (simple-array (unsigned-byte 8) (*)) vector))
+      (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
+      (/hexstr length)
+      (/hexstr vector)
+      (copy-from-system-area pc (* n-byte-bits 2)
+                            vector (* n-word-bits vector-data-offset)
+                            (* length n-byte-bits))
+      (let* ((index 0)
+            (error-number (sb!c:read-var-integer vector index)))
+       (/hexstr error-number)
+       (collect ((sc-offsets))
+         (loop
+          (/show0 "INDEX=..")
+          (/hexstr index)
+          (when (>= index length)
+            (return))
+          (let ((sc-offset (sb!c:read-var-integer vector index)))
+            (/show0 "SC-OFFSET=..")
+            (/hexstr sc-offset)
+            (sc-offsets sc-offset)))
+         (values error-number (sc-offsets)))))))
+\f
+;;; This is used in error.lisp to insure that floating-point exceptions
+;;; are properly trapped. The compiler translates this to a VOP.
+(defun float-wait ()
+  (float-wait))
+
+;;; float constants
+;;;
+;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
+;;; than the i387 load constant instructions to avoid consing in some
+;;; cases. Note these are initialized by GENESIS as they are needed
+;;; early.
+(defvar *fp-constant-0f0*)
+(defvar *fp-constant-1f0*)
+(defvar *fp-constant-0d0*)
+(defvar *fp-constant-1d0*)
+;;; the long-float constants
+(defvar *fp-constant-0l0*)
+(defvar *fp-constant-1l0*)
+(defvar *fp-constant-pi*)
+(defvar *fp-constant-l2t*)
+(defvar *fp-constant-l2e*)
+(defvar *fp-constant-lg2*)
+(defvar *fp-constant-ln2*)
+
+;;; the current alien stack pointer; saved/restored for non-local exits
+(defvar *alien-stack*)
+
+;;; Support for the MT19937 random number generator. The update
+;;; function is implemented as an assembly routine. This definition is
+;;; transformed to a call to the assembly routine allowing its use in
+;;; interpreted code.
+#+nil
+(defun random-mt19937 (state)
+  (declare (type (simple-array (unsigned-byte 32) (627)) state))
+  (random-mt19937 state))
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp

index cb22831..89771f2 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -346,11 +346,11 @@
      (/noshow (local-alien-info-force-to-memory-p info))
      (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
      (if (local-alien-info-force-to-memory-p info)
      (/noshow (local-alien-info-force-to-memory-p info))
      (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
      (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(truly-the system-area-pointer
+      #!+(or x86 x86-64) `(truly-the system-area-pointer
                          (%primitive alloc-alien-stack-space
                                      ,(ceiling (alien-type-bits alien-type)
                                                sb!vm:n-byte-bits)))
                          (%primitive alloc-alien-stack-space
                                      ,(ceiling (alien-type-bits alien-type)
                                                sb!vm:n-byte-bits)))
-      #!-x86 `(truly-the system-area-pointer
+      #!-(or x86 x86-64) `(truly-the system-area-pointer
                          (%primitive alloc-number-stack-space
                                      ,(ceiling (alien-type-bits alien-type)
                                                sb!vm:n-byte-bits)))
                          (%primitive alloc-number-stack-space
                                      ,(ceiling (alien-type-bits alien-type)
                                                sb!vm:n-byte-bits)))
@@ -434,10 +434,10 @@
    (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
      (if (local-alien-info-force-to-memory-p info)
    (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
      (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(%primitive dealloc-alien-stack-space
+      #!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space
                           ,(ceiling (alien-type-bits alien-type)
                                     sb!vm:n-byte-bits))
                           ,(ceiling (alien-type-bits alien-type)
                                     sb!vm:n-byte-bits))
-      #!-x86 `(%primitive dealloc-number-stack-space
+      #!-(or x86 x86-64) `(%primitive dealloc-number-stack-space
                           ,(ceiling (alien-type-bits alien-type)
                                     sb!vm:n-byte-bits))
        nil)))
                           ,(ceiling (alien-type-bits alien-type)
                                     sb!vm:n-byte-bits))
        nil)))
@@ -678,19 +678,19 @@
         (let* ((arg (pop args))
                (sc (tn-sc tn))
                (scn (sc-number sc))
         (let* ((arg (pop args))
                (sc (tn-sc tn))
                (scn (sc-number sc))
-              #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
+              #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn)
                                                        scn))
                (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
           (aver arg)
           (unless (= (length move-arg-vops) 1)
             (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
                                                        scn))
                (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
           (aver arg)
           (unless (= (length move-arg-vops) 1)
             (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
-         #!+x86 (emit-move-arg-template call
+         #!+(or x86 x86-64) (emit-move-arg-template call
                                          block
                                          (first move-arg-vops)
                                          (lvar-tn call block arg)
                                          nsp
                                          tn)
                                          block
                                          (first move-arg-vops)
                                          (lvar-tn call block arg)
                                          nsp
                                          tn)
-         #!-x86 (progn
+         #!-(or x86 x86-64) (progn
                    (emit-move call
                               block
                               (lvar-tn call block arg)
                    (emit-move call
                               block
                               (lvar-tn call block arg)
diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp

index 5332dea..c8fa15f 100644 (file)
--- a/src/compiler/disassem.lisp
+++ b/src/compiler/disassem.lisp
@@ -18,7 +18,7 @@
  (deftype text-width () '(integer 0 1000))
  (deftype alignment () '(integer 0 64))
  (deftype offset () '(signed-byte 24))
  (deftype text-width () '(integer 0 1000))
  (deftype alignment () '(integer 0 64))
  (deftype offset () '(signed-byte 24))
-(deftype address () '(unsigned-byte 32))
+(deftype address () '(unsigned-byte #.sb!vm:n-word-bits))
  (deftype disassem-length () '(unsigned-byte 24))
  (deftype column () '(integer 0 1000))
  
  (deftype disassem-length () '(unsigned-byte 24))
  (deftype column () '(integer 0 1000))
  
@@ -49,7 +49,15 @@
  (defvar *disassem-opcode-column-width* 6)
  (declaim (type text-width *disassem-opcode-column-width*))
  
  (defvar *disassem-opcode-column-width* 6)
  (declaim (type text-width *disassem-opcode-column-width*))
  
-(defvar *disassem-note-column* 45
+;;; the width of the column in which instruction-bytes are printed. A
+;;; value of zero disables the printing of instruction bytes.
+(defvar *disassem-inst-column-width* 16
+  #!+sb-doc
+  "The width of instruction bytes.") 
+(declaim (type text-width *disassem-inst-column-width*))
+        
+
+(defvar *disassem-note-column* (+ 45 *disassem-inst-column-width*)
    #!+sb-doc
    "The column in which end-of-line comments for notes are started.")
  
    #!+sb-doc
    "The column in which end-of-line comments for notes are started.")
  
@@ -131,7 +139,7 @@
                   dchunk=
                   dchunk-count-bits))
  
                   dchunk=
                   dchunk-count-bits))
  
-(def!constant dchunk-bits 32)
+(def!constant dchunk-bits #.sb!vm:n-word-bits)
  
  (deftype dchunk ()
    `(unsigned-byte ,dchunk-bits))
  
  (deftype dchunk ()
    `(unsigned-byte ,dchunk-bits))
@@ -139,7 +147,7 @@
    `(integer 0 ,dchunk-bits))
  
  (def!constant dchunk-zero 0)
    `(integer 0 ,dchunk-bits))
  
  (def!constant dchunk-zero 0)
-(def!constant dchunk-one #xFFFFFFFF)
+(def!constant dchunk-one #.(1- (expt 2 sb!vm:n-word-bits)))
  
  (defun dchunk-extract (from pos)
    (declare (type dchunk from))
  
  (defun dchunk-extract (from pos)
    (declare (type dchunk from))
diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp

index c4b2f7f..890263e 100644 (file)
--- a/src/compiler/generic/core.lisp
+++ b/src/compiler/generic/core.lisp
@@ -64,7 +64,7 @@
                     (:foreign-dataref
                      (aver (stringp name))
                      (foreign-symbol-address-as-integer name t))
                     (:foreign-dataref
                      (aver (stringp name))
                      (foreign-symbol-address-as-integer name t))
-                   #!+x86
+                   #!+(or x86 x86-64)
                     (:code-object
                      (aver (null name))
                      (values (get-lisp-obj-address code) t)))))
                     (:code-object
                      (aver (null name))
                      (values (get-lisp-obj-address code) t)))))
diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp

index e182880..e1e7b6a 100644 (file)
--- a/src/compiler/generic/early-objdef.lisp
+++ b/src/compiler/generic/early-objdef.lisp
@@ -116,7 +116,7 @@
           :start (+ (ash 1 n-lowtag-bits) other-immediate-0-lowtag)
           :step 4)
    ;; NOTE: the binary numbers off to the side are only valid for 32-bit
           :start (+ (ash 1 n-lowtag-bits) other-immediate-0-lowtag)
           :step 4)
    ;; NOTE: the binary numbers off to the side are only valid for 32-bit
-  ;; ports; add #x1000 if you want to know the values for 64-bit ports.
+  ;; ports; add #b1000 if you want to know the values for 64-bit ports.
    ;; And note that the numbers get a little scrambled further down.
    ;;   --njf, 2004-08-09
    bignum                            ; 00001010
    ;; And note that the numbers get a little scrambled further down.
    ;;   --njf, 2004-08-09
    bignum                            ; 00001010
@@ -151,7 +151,9 @@
    unused05                          ; 01101110
    unused06                          ; 01110010
    unused07                          ; 01110110
    unused05                          ; 01101110
    unused06                          ; 01110010
    unused07                          ; 01110110
+  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
    unused08                          ; 01111010
    unused08                          ; 01111010
+  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
    unused09                          ; 01111110
  
    #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
    unused09                          ; 01111110
  
    #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp

index fdfa848..fd4cbfc 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -663,6 +663,30 @@ core and return a descriptor to it."
      (write-wordindexed des 2 second)
      des))
  
      (write-wordindexed des 2 second)
      des))
  
+(defun write-double-float-bits (address index x)
+  (let ((hi (double-float-high-bits x))
+       (lo (double-float-low-bits x)))
+    (ecase sb!vm::n-word-bits
+      (32
+       (let ((high-bits (make-random-descriptor hi))
+            (low-bits (make-random-descriptor lo)))
+        (ecase sb!c:*backend-byte-order*
+          (:little-endian
+           (write-wordindexed address index low-bits)
+           (write-wordindexed address index high-bits))
+          (:big-endian
+           (write-wordindexed address index high-bits)
+           (write-wordindexed address (1+ index) low-bits)))))
+      (64
+       (let ((bits (make-random-descriptor
+                   (ecase sb!c:*backend-byte-order*
+                     (:little-endian (logior lo (ash hi 32)))
+                     ;; Just guessing.
+                     #+nil (:big-endian (logior (logand hi #xffffffff)
+                                                (ash lo 32)))))))
+        (write-wordindexed address index bits))))
+    address))
+
  (defun float-to-core (x)
    (etypecase x
      (single-float
  (defun float-to-core (x)
    (etypecase x
      (single-float
@@ -678,17 +702,8 @@ core and return a descriptor to it."
       (let ((des (allocate-unboxed-object *dynamic*
                                          sb!vm:n-word-bits
                                          (1- sb!vm:double-float-size)
       (let ((des (allocate-unboxed-object *dynamic*
                                          sb!vm:n-word-bits
                                          (1- sb!vm:double-float-size)
-                                        sb!vm:double-float-widetag))
-          (high-bits (make-random-descriptor (double-float-high-bits x)))
-          (low-bits (make-random-descriptor (double-float-low-bits x))))
-       (ecase sb!c:*backend-byte-order*
-        (:little-endian
-         (write-wordindexed des sb!vm:double-float-value-slot low-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
-        (:big-endian
-         (write-wordindexed des sb!vm:double-float-value-slot high-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
-       des))))
+                                        sb!vm:double-float-widetag)))
+       (write-double-float-bits des sb!vm:double-float-value-slot x)))))
  
  (defun complex-single-float-to-core (num)
    (declare (type (complex single-float) num))
  
  (defun complex-single-float-to-core (num)
    (declare (type (complex single-float) num))
@@ -706,39 +721,10 @@ core and return a descriptor to it."
    (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                       (1- sb!vm:complex-double-float-size)
                                       sb!vm:complex-double-float-widetag)))
    (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                       (1- sb!vm:complex-double-float-size)
                                       sb!vm:complex-double-float-widetag)))
-    (let* ((real (realpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits real)))
-          (low-bits (make-random-descriptor (double-float-low-bits real))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           low-bits))))
-    (let* ((imag (imagpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits imag)))
-          (low-bits (make-random-descriptor (double-float-low-bits imag))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           low-bits))))
-    des))
+    (write-double-float-bits des sb!vm:complex-double-float-real-slot
+                            (realpart num))
+    (write-double-float-bits des sb!vm:complex-double-float-imag-slot
+                            (imagpart num))))
  
  ;;; Copy the given number to the core.
  (defun number-to-core (number)
  
  ;;; Copy the given number to the core.
  (defun number-to-core (number)
@@ -2455,12 +2441,12 @@ core and return a descriptor to it."
                        ;; itself.) Ask on the mailing list whether
                        ;; this is documented somewhere, and if not,
                        ;; try to reverse engineer some documentation.
                        ;; itself.) Ask on the mailing list whether
                        ;; this is documented somewhere, and if not,
                        ;; try to reverse engineer some documentation.
-                      #!-x86
+                      #!-(or x86 x86-64)
                        ;; a pointer back to the function object, as
                        ;; described in CMU CL
                        ;; src/docs/internals/object.tex
                        fn
                        ;; a pointer back to the function object, as
                        ;; described in CMU CL
                        ;; src/docs/internals/object.tex
                        fn
-                      #!+x86
+                      #!+(or x86 x86-64)
                        ;; KLUDGE: a pointer to the actual code of the
                        ;; object, as described nowhere that I can find
                        ;; -- WHN 19990907
                        ;; KLUDGE: a pointer to the actual code of the
                        ;; object, as described nowhere that I can find
                        ;; -- WHN 19990907
@@ -3106,7 +3092,7 @@ initially undefined function references:~2%")
                               sb!vm:unbound-marker-widetag))
            *cold-assembler-fixups*
            *cold-assembler-routines*
                               sb!vm:unbound-marker-widetag))
            *cold-assembler-fixups*
            *cold-assembler-routines*
-          #!+x86 *load-time-code-fixups*)
+          #!+(or x86 x86-64) *load-time-code-fixups*)
  
        ;; Prepare for cold load.
        (initialize-non-nil-symbols)
  
        ;; Prepare for cold load.
        (initialize-non-nil-symbols)
@@ -3174,7 +3160,7 @@ initially undefined function references:~2%")
  
        ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
        (resolve-assembler-fixups)
  
        ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
        (resolve-assembler-fixups)
-      #!+x86 (output-load-time-code-fixups)
+      #!+(or x86 x86-64) (output-load-time-code-fixups)
        (foreign-symbols-to-core)
        (finish-symbols)
        (/show "back from FINISH-SYMBOLS")
        (foreign-symbols-to-core)
        (finish-symbols)
        (/show "back from FINISH-SYMBOLS")
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp

index 0659a28..1e4fc8b 100644 (file)
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -72,8 +72,8 @@
  
  (define-primitive-object (double-float :lowtag other-pointer-lowtag
                                        :widetag double-float-widetag)
  
  (define-primitive-object (double-float :lowtag other-pointer-lowtag
                                        :widetag double-float-widetag)
-  (filler)
-  (value :c-type "double" :length 2))
+  #!-x86-64 (filler)
+  (value :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
  
  #!+long-float
  (define-primitive-object (long-float :lowtag other-pointer-lowtag
  
  #!+long-float
  (define-primitive-object (long-float :lowtag other-pointer-lowtag
@@ -170,9 +170,9 @@
  (define-primitive-object (simple-fun :type function
                                      :lowtag fun-pointer-lowtag
                                      :widetag simple-fun-header-widetag)
  (define-primitive-object (simple-fun :type function
                                      :lowtag fun-pointer-lowtag
                                      :widetag simple-fun-header-widetag)
-  #!-x86 (self :ref-trans %simple-fun-self
+  #!-(or x86 x86-64) (self :ref-trans %simple-fun-self
                :set-trans (setf %simple-fun-self))
                :set-trans (setf %simple-fun-self))
-  #!+x86 (self
+  #!+(or x86 x86-64) (self
           ;; KLUDGE: There's no :SET-KNOWN, :SET-TRANS, :REF-KNOWN, or
           ;; :REF-TRANS here in this case. Instead, there's separate
           ;; DEFKNOWN/DEFINE-VOP/DEFTRANSFORM stuff in
           ;; KLUDGE: There's no :SET-KNOWN, :SET-TRANS, :REF-KNOWN, or
           ;; :REF-TRANS here in this case. Instead, there's separate
           ;; DEFKNOWN/DEFINE-VOP/DEFTRANSFORM stuff in
@@ -226,11 +226,11 @@
                           :lowtag fun-pointer-lowtag
                           :widetag funcallable-instance-header-widetag
                           :alloc-trans %make-funcallable-instance)
                           :lowtag fun-pointer-lowtag
                           :widetag funcallable-instance-header-widetag
                           :alloc-trans %make-funcallable-instance)
-  #!-x86
+  #!-(or x86 x86-64)
    (fun
     :ref-known (flushable) :ref-trans %funcallable-instance-fun
     :set-known (unsafe) :set-trans (setf %funcallable-instance-fun))
    (fun
     :ref-known (flushable) :ref-trans %funcallable-instance-fun
     :set-known (unsafe) :set-trans (setf %funcallable-instance-fun))
-  #!+x86
+  #!+(or x86 x86-64)
    (fun
     :ref-known (flushable) :ref-trans %funcallable-instance-fun
     ;; KLUDGE: There's no :SET-KNOWN or :SET-TRANS in this case.
    (fun
     :ref-known (flushable) :ref-trans %funcallable-instance-fun
     ;; KLUDGE: There's no :SET-KNOWN or :SET-TRANS in this case.
@@ -295,13 +295,13 @@
  (define-primitive-object (unwind-block)
    (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
    (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
  (define-primitive-object (unwind-block)
    (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
    (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
-  #!-x86 current-code
+  #!-(or x86 x86-64) current-code
    entry-pc)
  
  (define-primitive-object (catch-block)
    (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
    (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
    entry-pc)
  
  (define-primitive-object (catch-block)
    (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
    (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
-  #!-x86 current-code
+  #!-(or x86 x86-64) current-code
    entry-pc
    tag
    (previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32")
    entry-pc
    tag
    (previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32")
@@ -350,9 +350,9 @@
  (define-primitive-object (complex-double-float
                           :lowtag other-pointer-lowtag
                           :widetag complex-double-float-widetag)
  (define-primitive-object (complex-double-float
                           :lowtag other-pointer-lowtag
                           :widetag complex-double-float-widetag)
-  (filler)
-  (real :c-type "double" :length 2)
-  (imag :c-type "double" :length 2))
+  #!-x86-64 (filler) 
+  (real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
+  (imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
  
  ;;; this isn't actually a lisp object at all, it's a c structure that lives
  ;;; in c-land.  However, we need sight of so many parts of it from Lisp that
  
  ;;; this isn't actually a lisp object at all, it's a c structure that lives
  ;;; in c-land.  However, we need sight of so many parts of it from Lisp that
@@ -376,8 +376,8 @@
    (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
    (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
    (state)                              ; running, stopping, stopped, dead
    (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
    (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
    (state)                              ; running, stopping, stopped, dead
-  #!+x86 (pseudo-atomic-atomic)
-  #!+x86 (pseudo-atomic-interrupted)
+  #!+(or x86 x86-64) (pseudo-atomic-atomic)
+  #!+(or x86 x86-64) (pseudo-atomic-interrupted)
    (interrupt-data :c-type "struct interrupt_data *" 
                   :length #!+alpha 2 #!-alpha 1)
    (interrupt-contexts :c-type "os_context_t *" :rest-p t))
    (interrupt-data :c-type "struct interrupt_data *" 
                   :length #!+alpha 2 #!-alpha 1)
    (interrupt-contexts :c-type "os_context_t *" :rest-p t))
diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp

index a219a4f..d11bcf6 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -25,26 +25,27 @@
  (!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
    :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
  (/show0 "primtype.lisp 27")
  (!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
    :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
  (/show0 "primtype.lisp 27")
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
  (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
    :type (unsigned-byte 31))
  (/show0 "primtype.lisp 31")
  (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
    :type (unsigned-byte 31))
  (/show0 "primtype.lisp 31")
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
  (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
    :type (unsigned-byte 32))
  (/show0 "primtype.lisp 35")
  (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
    :type (unsigned-byte 32))
  (/show0 "primtype.lisp 35")
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
  (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
    :type (unsigned-byte 63))
  (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
    :type (unsigned-byte 63))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
  (!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
    :type (unsigned-byte 64))
  (!def-primitive-type fixnum (any-reg signed-reg)
    :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
  (!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
    :type (unsigned-byte 64))
  (!def-primitive-type fixnum (any-reg signed-reg)
    :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
-#!-alpha
+;; x86-64 needs a signed-byte-32 for proper handling of c-call return values.
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or x86-64))
  (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
    :type (signed-byte 32))
  (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
    :type (signed-byte 32))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
  (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
    :type (signed-byte 64))
  
  (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
    :type (signed-byte 64))
  
@@ -52,17 +53,16 @@
  
  (/show0 "primtype.lisp 53")
  (!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
  
  (/show0 "primtype.lisp 53")
  (!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
-(!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
-                                            #!-alpha unsigned-byte-31
-                                            #!+alpha unsigned-byte-64
-                                            #!+alpha unsigned-byte-63
-                                            positive-fixnum))
-(!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
-                                          #!+alpha signed-byte-64
-                                          fixnum
-                                          #!-alpha unsigned-byte-31
-                                          #!+alpha unsigned-byte-63
-                                          positive-fixnum))
+(!def-primitive-type-alias unsigned-num 
+  #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum)
+  #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum))
+(!def-primitive-type-alias signed-num 
+  #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)
+  #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
  
  ;;; other primitive immediate types
  (/show0 "primtype.lisp 68")
  
  ;;; other primitive immediate types
  (/show0 "primtype.lisp 68")
@@ -161,32 +161,48 @@
                (case t1-name
                  (positive-fixnum
                   (if (or (eq t2-name 'fixnum)
                (case t1-name
                  (positive-fixnum
                   (if (or (eq t2-name 'fixnum)
-                         (eq t2-name #!-alpha 'signed-byte-32
-                                     #!+alpha 'signed-byte-64)
-                         (eq t2-name #!-alpha 'unsigned-byte-31
-                                     #!+alpha 'unsigned-byte-63)
-                         (eq t2-name #!-alpha 'unsigned-byte-32
-                                     #!+alpha 'unsigned-byte-64))
+                         (eq t2-name
+                             (ecase sb!vm::n-machine-word-bits
+                               (32 'signed-byte-32)
+                               (64 'signed-byte-64)))
+                         (eq t2-name
+                             (ecase sb!vm::n-machine-word-bits
+                               (32 'unsigned-byte-31)
+                               (64 'unsigned-byte-63)))
+                         (eq t2-name
+                             (ecase sb!vm::n-machine-word-bits
+                               (32 'unsigned-byte-32)
+                               (64 'unsigned-byte-64))))
                       t2))
                  (fixnum
                   (case t2-name
                       t2))
                  (fixnum
                   (case t2-name
-                   (#!-alpha signed-byte-32
-                    #!+alpha signed-byte-64 t2)
-                   (#!-alpha unsigned-byte-31
-                    #!+alpha unsigned-byte-63
-                    (primitive-type-or-lose
-                     #!-alpha 'signed-byte-32
-                     #!+alpha 'signed-byte-64))))
-                (#!-alpha signed-byte-32
-                 #!+alpha signed-byte-64
-                 (if (eq t2-name #!-alpha 'unsigned-byte-31
-                                 #!+alpha 'unsigned-byte-63)
+                   (#.(ecase sb!vm::n-machine-word-bits
+                        (32 'signed-byte-32)
+                        (64 'signed-byte-64))
+                      t2)
+                   (#.(ecase sb!vm::n-machine-word-bits
+                        (32 'unsigned-byte-31)
+                        (64 'unsigned-byte-63))
+                      (primitive-type-or-lose
+                       (ecase sb!vm::n-machine-word-bits
+                         (32 'signed-byte-32)
+                         (64 'signed-byte-64))))))
+                (#.(ecase sb!vm::n-machine-word-bits
+                     (32 'signed-byte-32)
+                     (64 'signed-byte-64))
+                 (if (eq t2-name
+                         (ecase sb!vm::n-machine-word-bits
+                           (32 'unsigned-byte-31)
+                           (64 'unsigned-byte-63)))
                       t1))
                       t1))
-                (#!-alpha unsigned-byte-31
-                 #!+alpha unsigned-byte-63
-                 (if (eq t2-name #!-alpha 'unsigned-byte-32
-                                 #!+alpha 'unsigned-byte-64)
-                     t2))))))
+                (#.(ecase sb!vm::n-machine-word-bits
+                     (32 'unsigned-byte-31)
+                     (64 'unsigned-byte-63))
+                   (if (eq t2-name
+                           (ecase sb!vm::n-machine-word-bits
+                             (32 'unsigned-byte-32)
+                             (64 'unsigned-byte-64)))
+                       t2))))))
        (etypecase type
         (numeric-type
          (let ((lo (numeric-type-low type))
        (etypecase type
         (numeric-type
          (let ((lo (numeric-type-low type))
@@ -198,22 +214,26 @@
                  (cond ((and hi lo)
                         (dolist (spec
                                   `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
                  (cond ((and hi lo)
                         (dolist (spec
                                   `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
-                                   #!-alpha
-                                   (unsigned-byte-31 0 ,(1- (ash 1 31)))
-                                   #!-alpha
-                                   (unsigned-byte-32 0 ,(1- (ash 1 32)))
-                                   #!+alpha
-                                   (unsigned-byte-63 0 ,(1- (ash 1 63)))
-                                   #!+alpha
-                                   (unsigned-byte-64 0 ,(1- (ash 1 64)))
+                                   ,@(ecase sb!vm::n-machine-word-bits
+                                       (32
+                                        `((unsigned-byte-31
+                                           0 ,(1- (ash 1 31)))
+                                          (unsigned-byte-32
+                                           0 ,(1- (ash 1 32)))))
+                                       (64
+                                        `((unsigned-byte-63
+                                           0 ,(1- (ash 1 63)))
+                                          (unsigned-byte-64
+                                           0 ,(1- (ash 1 64))))))
                                     (fixnum ,sb!xc:most-negative-fixnum
                                             ,sb!xc:most-positive-fixnum)
                                     (fixnum ,sb!xc:most-negative-fixnum
                                             ,sb!xc:most-positive-fixnum)
-                                   #!-alpha
-                                   (signed-byte-32 ,(ash -1 31)
-                                                         ,(1- (ash 1 31)))
-                                   #!+alpha
-                                   (signed-byte-64 ,(ash -1 63)
-                                                   ,(1- (ash 1 63))))
+                                   ,(ecase sb!vm::n-machine-word-bits
+                                      (32
+                                       `(signed-byte-32 ,(ash -1 31)
+                                                        ,(1- (ash 1 31))))
+                                      (64
+                                       `(signed-byte-64 ,(ash -1 63)
+                                                        ,(1- (ash 1 63))))))
                                  (if (or (< hi sb!xc:most-negative-fixnum)
                                          (> lo sb!xc:most-positive-fixnum))
                                      (part-of bignum)
                                  (if (or (< hi sb!xc:most-negative-fixnum)
                                          (> lo sb!xc:most-positive-fixnum))
                                      (part-of bignum)
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp

index e0a4899..a2c9d35 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -54,9 +54,9 @@
            simple-array-complex-double-float-p
            #!+long-float simple-array-complex-long-float-p
            system-area-pointer-p realp
            simple-array-complex-double-float-p
            #!+long-float simple-array-complex-long-float-p
            system-area-pointer-p realp
-           #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+           ;; #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
             unsigned-byte-32-p
             unsigned-byte-32-p
-           #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+           ;; #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
             signed-byte-32-p
             #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
             unsigned-byte-64-p
             signed-byte-32-p
             #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
             unsigned-byte-64-p
diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp

index 114e61e..b4c5a67 100644 (file)
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -1417,7 +1417,7 @@
      ;; For non-x86 ports the presence of a save-tn associated with a
      ;; tn is used to identify the old-fp and return-pc tns. It depends
      ;; on the old-fp and return-pc being passed in registers.
      ;; For non-x86 ports the presence of a save-tn associated with a
      ;; tn is used to identify the old-fp and return-pc tns. It depends
      ;; on the old-fp and return-pc being passed in registers.
-    #!-x86
+    #!-(or x86 x86-64)
      (when (and (not (eq (tn-kind tn) :specified-save))
                (conflicts-in-sc original sc offset))
        (error "~S is wired to a location that it conflicts with." tn))
      (when (and (not (eq (tn-kind tn) :specified-save))
                (conflicts-in-sc original sc offset))
        (error "~S is wired to a location that it conflicts with." tn))
@@ -1444,7 +1444,7 @@
      ;; the stack so the above hack for the other ports does not always
      ;; work. Here the old-fp and return-pc tns are identified by being
      ;; on the stack in their standard save locations.
      ;; the stack so the above hack for the other ports does not always
      ;; work. Here the old-fp and return-pc tns are identified by being
      ;; on the stack in their standard save locations.
-    #!+x86
+    #!+(or x86 x86-64)
      (when (and (not (eq (tn-kind tn) :specified-save))
                (not (and (string= (sb-name sb) "STACK")
                          (or (= offset 0)
      (when (and (not (eq (tn-kind tn) :specified-save))
                (not (and (string= (sb-name sb) "STACK")
                          (or (= offset 0)
diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp

index 64f067b..f709cea 100644 (file)
--- a/src/compiler/saptran.lisp
+++ b/src/compiler/saptran.lisp
@@ -43,12 +43,14 @@
  
  (defknown sap+ (system-area-pointer integer) system-area-pointer
    (movable flushable))
  
  (defknown sap+ (system-area-pointer integer) system-area-pointer
    (movable flushable))
-(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
+(defknown sap- (system-area-pointer system-area-pointer) 
+               (signed-byte #.sb!vm::n-word-bits)
    (movable flushable))
  
    (movable flushable))
  
-(defknown sap-int (system-area-pointer) (unsigned-byte #!-alpha 32 #!+alpha 64)
+(defknown sap-int (system-area-pointer)
+  (unsigned-byte #.sb!vm::n-machine-word-bits)
    (movable flushable))
    (movable flushable))
-(defknown int-sap ((unsigned-byte #!-alpha 32 #!+alpha 64))
+(defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits))
    system-area-pointer (movable))
  
  (defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8)
    system-area-pointer (movable))
  
  (defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8)
@@ -78,6 +80,14 @@
    (unsigned-byte 64)
    ())
  
    (unsigned-byte 64)
    ())
  
+(defknown sap-ref-word (system-area-pointer fixnum)
+  (unsigned-byte #.sb!vm::n-machine-word-bits)
+  (flushable))
+(defknown %set-sap-ref-word
+    (system-area-pointer fixnum (unsigned-byte #.sb!vm::n-machine-word-bits))
+  (unsigned-byte #.sb!vm::n-machine-word-bits)
+  ())
+
  (defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8)
    (flushable))
  (defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8))
  (defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8)
    (flushable))
  (defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8))
@@ -102,6 +112,14 @@
    (signed-byte 64)
    ())
  
    (signed-byte 64)
    ())
  
+(defknown signed-sap-ref-word (system-area-pointer fixnum)
+  (signed-byte #.sb!vm::n-machine-word-bits)
+  (flushable))
+(defknown %set-signed-sap-ref-word
+    (system-area-pointer fixnum (signed-byte #.sb!vm::n-machine-word-bits))
+  (signed-byte #.sb!vm::n-machine-word-bits)
+  ())
+
  (defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer
    (flushable))
  (defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer)
  (defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer
    (flushable))
  (defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer)
@@ -182,3 +200,15 @@
    ;; redundancy.  --njf 2002-01-08
    #!+long-float (def sap-ref-long)
    #!+long-float (def %set-sap-ref-long))
    ;; redundancy.  --njf 2002-01-08
    #!+long-float (def sap-ref-long)
    #!+long-float (def %set-sap-ref-long))
+
+(macrolet ((def (fun args 32-bit 64-bit)
+              `(deftransform ,fun (,args)
+                 (ecase sb!vm::n-word-bits
+                   (32 '(,32-bit ,@args))
+                   (64 '(,64-bit ,@args))))))
+  (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
+  (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
+  (def %set-sap-ref-word (sap offset value)
+    %set-sap-ref-32 %set-sap-ref-64)
+  (def %set-signed-sap-ref-word (sap offset value)
+    %set-signed-sap-ref-32 %set-signed-sap-ref-64))
diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp

index b4572ef..69e24fa 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -485,7 +485,8 @@
         (when (> words 0)
           (print-words words stream dstate))
         (when (> bytes 0)
         (when (> words 0)
           (print-words words stream dstate))
         (when (> bytes 0)
-         (print-bytes bytes stream dstate))))
+         (print-inst bytes stream dstate)))
+      (print-bytes alignment stream dstate))
      (incf (dstate-next-offs dstate) alignment)))
  
  ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
      (incf (dstate-next-offs dstate) alignment)))
  
  ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for
@@ -525,29 +526,39 @@
            (let ((fun-prefix-p (call-fun-hooks chunk stream dstate)))
              (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
                  (setf prefix-p fun-prefix-p)
            (let ((fun-prefix-p (call-fun-hooks chunk stream dstate)))
              (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
                  (setf prefix-p fun-prefix-p)
-                (let ((inst (find-inst chunk ispace)))
-                  (cond ((null inst)
-                         (handle-bogus-instruction stream dstate))
-                        (t
-                         (setf (dstate-next-offs dstate)
-                               (+ (dstate-cur-offs dstate)
-                                  (inst-length inst)))
-
+              (let ((inst (find-inst chunk ispace)))
+                (cond ((null inst)
+                       (handle-bogus-instruction stream dstate))
+                      (t
+                       (setf (dstate-next-offs dstate)
+                             (+ (dstate-cur-offs dstate)
+                                (inst-length inst)))
+                       (let ((orig-next (dstate-next-offs dstate)))
+                         (print-inst (inst-length inst) stream dstate :trailing-space nil)
                           (let ((prefilter (inst-prefilter inst))
                                 (control (inst-control inst)))
                             (when prefilter
                               (funcall prefilter chunk dstate))
                           (let ((prefilter (inst-prefilter inst))
                                 (control (inst-control inst)))
                             (when prefilter
                               (funcall prefilter chunk dstate))
-
+                           
+                           ;; print any instruction bytes recognized by the prefilter which calls read-suffix
+                           ;; and updates next-offs
+                           (let ((suffix-len (- (dstate-next-offs dstate) orig-next)))
+                             (when (plusp suffix-len)
+                               (print-inst suffix-len stream dstate :offset (inst-length inst) :trailing-space nil))
+                             (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len))))
+                               (write-char #\space stream)))
+                           (write-char #\space stream)
+                           
                             (funcall function chunk inst)
                             (funcall function chunk inst)
-
+                           
                             (setf prefix-p (null (inst-printer inst)))
                             (setf prefix-p (null (inst-printer inst)))
-
+                           
                             (when control
                             (when control
-                             (funcall control chunk inst stream dstate))))))
-                )))))
-
+                             (funcall control chunk inst stream dstate))
+                           ))))))))))
+    
        (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
        (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
-
+      
        (unless (null stream)
         (unless prefix-p
           (print-notes-and-newline stream dstate))
        (unless (null stream)
         (unless prefix-p
           (print-notes-and-newline stream dstate))
@@ -728,6 +739,17 @@
      (fresh-line stream)
      (setf (dstate-notes dstate) nil)))
  
      (fresh-line stream)
      (setf (dstate-notes dstate) nil)))
  
+;;; Print NUM instruction bytes to STREAM as hex values.
+(defun print-inst (num stream dstate &key (offset 0) (trailing-space t))
+  (let ((sap (dstate-segment-sap dstate))
+       (start-offs (+ offset (dstate-cur-offs dstate))))
+    (dotimes (offs num)
+      (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs))))
+    (when trailing-space
+      (dotimes (i (- *disassem-inst-column-width* (* 2 num)))
+       (write-char #\space stream))
+      (write-char #\space stream))))
+
  ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
  (defun print-bytes (num stream dstate)
    (declare (type offset num)
  ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
  (defun print-bytes (num stream dstate)
    (declare (type offset num)
@@ -1785,7 +1807,7 @@
  (defun sap-ref-int (sap offset length byte-order)
    (declare (type sb!sys:system-area-pointer sap)
            (type (unsigned-byte 16) offset)
  (defun sap-ref-int (sap offset length byte-order)
    (declare (type sb!sys:system-area-pointer sap)
            (type (unsigned-byte 16) offset)
-          (type (member 1 2 4) length)
+          (type (member 1 2 4 8) length)
            (type (member :little-endian :big-endian) byte-order)
            (optimize (speed 3) (safety 0)))
    (ecase length
            (type (member :little-endian :big-endian) byte-order)
            (optimize (speed 3) (safety 0)))
    (ecase length
@@ -1803,14 +1825,31 @@
            (+ (sb!sys:sap-ref-8 sap offset)
               (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
               (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
            (+ (sb!sys:sap-ref-8 sap offset)
               (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
               (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
-             (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24))))))
+             (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24))))
+    (8 (if (eq byte-order :big-endian)
+          (+ (ash (sb!sys:sap-ref-8 sap offset) 56)
+             (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 48)
+             (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 40)
+             (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 32)
+             (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 24)
+             (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 16)
+             (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 8)
+             (sb!sys:sap-ref-8 sap (+ 7 offset)))
+          (+ (sb!sys:sap-ref-8 sap offset)
+             (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
+             (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
+             (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24)
+             (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 32)
+             (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 40)
+             (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 48)
+             (ash (sb!sys:sap-ref-8 sap (+ 7 offset)) 56))))))
  
  (defun read-suffix (length dstate)
  
  (defun read-suffix (length dstate)
-  (declare (type (member 8 16 32) length)
+  (declare (type (member 8 16 32 64) length)
            (type disassem-state dstate)
            (optimize (speed 3) (safety 0)))
            (type disassem-state dstate)
            (optimize (speed 3) (safety 0)))
-  (let ((length (ecase length (8 1) (16 2) (32 4))))
-    (declare (type (unsigned-byte 3) length))
+  (let ((length (ecase length (8 1) (16 2) (32 4) (64 8))))
+    (declare (type (unsigned-byte 4) length))
      (prog1
        (sap-ref-int (dstate-segment-sap dstate)
                    (dstate-next-offs dstate)
      (prog1
        (sap-ref-int (dstate-segment-sap dstate)
                    (dstate-next-offs dstate)
@@ -2007,6 +2046,7 @@
                (let ((num (pop lengths)))
                  (print-notes-and-newline stream dstate)
                  (print-current-address stream dstate)
                (let ((num (pop lengths)))
                  (print-notes-and-newline stream dstate)
                  (print-current-address stream dstate)
+                (print-inst num stream dstate)
                  (print-bytes num stream dstate)
                  (incf (dstate-cur-offs dstate) num)
                  (when note
                  (print-bytes num stream dstate)
                  (incf (dstate-cur-offs dstate) num)
                  (when note
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp

index bc7de22..a2300fb 100644 (file)
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -172,7 +172,7 @@
      (inst lea bytes
           (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
      (inst mov header bytes)
      (inst lea bytes
           (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
      (inst mov header bytes)
-    (inst shl header (- n-widetag-bits 2)) ; w+1 to length field
+    (inst shl header (- n-widetag-bits 3)) ; w+1 to length field
      (inst lea header                   ; (w-1 << 8) | type
           (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
      (inst and bytes (lognot lowtag-mask))
      (inst lea header                   ; (w-1 << 8) | type
           (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
      (inst and bytes (lognot lowtag-mask))
diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp

index 1dbf7b0..14c6e28 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -117,10 +117,12 @@
    (:result-types tagged-num)
    (:note "inline fixnum arithmetic"))
  
    (:result-types tagged-num)
    (:note "inline fixnum arithmetic"))
  
+;; 31 not 64 because it's hard work loading 64 bit constants, and since
+;; sign-extension of immediates causes problems with 32.
  (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
    (:args (x :target r :scs (unsigned-reg unsigned-stack)))
    (:info y)
  (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)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 31)))
    (:results (r :scs (unsigned-reg)
                :load-if (not (location= x r))))
    (:result-types unsigned-num)
    (:results (r :scs (unsigned-reg)
                :load-if (not (location= x r))))
    (:result-types unsigned-num)
@@ -134,7 +136,7 @@
    (:results (r :scs (signed-reg)
                :load-if (not (location= x r))))
    (:result-types signed-num)
    (:results (r :scs (signed-reg)
                :load-if (not (location= x r))))
    (:result-types signed-num)
-  (:note "inline (signed-byte 64) arithmetic"))
+  (:note "inline (signed-byte 32) arithmetic"))
  
  (macrolet ((define-binop (translate untagged-penalty op)
              `(progn
  
  (macrolet ((define-binop (translate untagged-penalty op)
              `(progn
@@ -609,8 +611,7 @@
                  (t 
                   ;; shift too far then back again, to zero tag bits
                   (inst sar result (- 3 amount))
                  (t 
                   ;; shift too far then back again, to zero tag bits
                   (inst sar result (- 3 amount))
-                 (inst lea result
-                       (make-ea :qword :index result :scale 8))))))))
+                 (inst shl result 3)))))))
  
  
  (define-vop (fast-ash-left/fixnum=>fixnum)
  
  
  (define-vop (fast-ash-left/fixnum=>fixnum)
@@ -960,6 +961,7 @@
    (:temporary (:sc unsigned-reg :from (:argument 0)) t1)
    (:generator 60
      (move result arg)
    (:temporary (:sc unsigned-reg :from (:argument 0)) t1)
    (:generator 60
      (move result arg)
+    (move t1 arg)
  
      (inst mov temp result)  
      (inst shr temp 1)
  
      (inst mov temp result)  
      (inst shr temp 1)
@@ -992,8 +994,7 @@
      (inst add result temp)
  
      ;;; now do the upper half
      (inst add result temp)
  
      ;;; now do the upper half
-    (move t1 arg)
-    (inst bswap t1)
+    (inst shr t1 32)
  
      (inst mov temp t1)  
      (inst shr temp 1)
  
      (inst mov temp t1)  
      (inst shr temp 1)
@@ -1063,7 +1064,7 @@
  
  (define-vop (fast-conditional-c/signed fast-conditional/signed)
    (:args (x :scs (signed-reg signed-stack)))
  
  (define-vop (fast-conditional-c/signed fast-conditional/signed)
    (:args (x :scs (signed-reg signed-stack)))
-  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:arg-types signed-num (:constant (signed-byte 31)))
    (:info target not-p y))
  
  (define-vop (fast-conditional/unsigned fast-conditional)
    (:info target not-p y))
  
  (define-vop (fast-conditional/unsigned fast-conditional)
@@ -1076,10 +1077,9 @@
  
  (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
    (:args (x :scs (unsigned-reg unsigned-stack)))
  
  (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
    (:args (x :scs (unsigned-reg unsigned-stack)))
-  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 31)))
    (:info target not-p y))
  
    (:info target not-p y))
  
-
  (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
              `(progn
                 ,@(mapcar
  (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
              `(progn
                 ,@(mapcar
@@ -1253,6 +1253,13 @@
  (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
               fast-ash-c/unsigned=>unsigned)
    (:translate ash-left-mod64))
  (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
               fast-ash-c/unsigned=>unsigned)
    (:translate ash-left-mod64))
+(define-vop (fast-ash-left-mod64/unsigned=>unsigned
+             fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod64 ((integer count)
+                             ((unsigned-byte 64) (unsigned-byte 6)))
+  (when (sb!c::constant-lvar-p count)
+    (sb!c::give-up-ir1-transform))
+  '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
  
  (in-package "SB!C")
  
  
  (in-package "SB!C")
  
diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp

index 917906e..725b457 100644 (file)
--- a/src/compiler/x86-64/array.lisp
+++ b/src/compiler/x86-64/array.lisp
@@ -11,6 +11,11 @@
  
  (in-package "SB!VM")
  \f
  
  (in-package "SB!VM")
  \f
+
+;; For use in constant indexing; we can't use INDEX since the displacement
+;; field of an EA can't contain 64 bit values.
+(deftype low-index () '(signed-byte 29))
+
  ;;;; allocator for the array header
  
  (define-vop (make-array-header)
  ;;;; allocator for the array header
  
  (define-vop (make-array-header)
@@ -33,7 +38,7 @@
                               :disp (fixnumize (1- array-dimensions-offset))))
      (inst shl header n-widetag-bits)
      (inst or  header type)
                               :disp (fixnumize (1- array-dimensions-offset))))
      (inst shl header n-widetag-bits)
      (inst or  header type)
-    (inst shr header (1- n-widetag-bits)) ;XXX was naked 2, am guessing
+    (inst shr header (1- n-lowtag-bits))
      (pseudo-atomic
       (allocation result bytes node)
       (inst lea result (make-ea :qword :base result :disp other-pointer-lowtag))
      (pseudo-atomic
       (allocation result bytes node)
       (inst lea result (make-ea :qword :base result :disp other-pointer-lowtag))
@@ -140,15 +145,11 @@
                   ,element-type data-vector-set)))
            )
    (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
                   ,element-type data-vector-set)))
            )
    (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
-  (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
-    unsigned-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num
      unsigned-reg)
    (def-full-data-vector-frobs simple-array-signed-byte-61 tagged-num any-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-60
        positive-fixnum any-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num
      unsigned-reg)
    (def-full-data-vector-frobs simple-array-signed-byte-61 tagged-num any-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-60
        positive-fixnum any-reg)
-  (def-full-data-vector-frobs simple-array-signed-byte-32
-      signed-num signed-reg)
    (def-full-data-vector-frobs simple-array-signed-byte-64
        signed-num signed-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
    (def-full-data-vector-frobs simple-array-signed-byte-64
        signed-num signed-reg)
    (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
@@ -175,7 +176,7 @@
            (move ecx index)
            (inst shr ecx ,bit-shift)
            (inst mov result
            (move ecx index)
            (inst shr ecx ,bit-shift)
            (inst mov result
-                (make-ea :qword :base object :index ecx :scale 4
+                (make-ea :qword :base object :index ecx :scale n-word-bytes
                           :disp (- (* vector-data-offset n-word-bytes)
                                    other-pointer-lowtag)))
            (move ecx index)
                           :disp (- (* vector-data-offset n-word-bytes)
                                    other-pointer-lowtag)))
            (move ecx index)
@@ -188,7 +189,7 @@
          (:translate data-vector-ref)
          (:policy :fast-safe)
          (:args (object :scs (descriptor-reg)))
          (:translate data-vector-ref)
          (:policy :fast-safe)
          (:args (object :scs (descriptor-reg)))
-        (:arg-types ,type (:constant index))
+        (:arg-types ,type (:constant low-index))
          (:info index)
          (:results (result :scs (unsigned-reg)))
          (:result-types positive-fixnum)
          (:info index)
          (:results (result :scs (unsigned-reg)))
          (:result-types positive-fixnum)
@@ -249,7 +250,8 @@
          (:policy :fast-safe)
          (:args (object :scs (descriptor-reg))
                 (value :scs (unsigned-reg immediate) :target result))
          (:policy :fast-safe)
          (:args (object :scs (descriptor-reg))
                 (value :scs (unsigned-reg immediate) :target result))
-        (:arg-types ,type (:constant index) positive-fixnum)
+        (:arg-types ,type (:constant low-index) positive-fixnum)
+        (:temporary (:sc unsigned-reg) mask-tn)
          (:info index)
          (:results (result :scs (unsigned-reg)))
          (:result-types positive-fixnum)
          (:info index)
          (:results (result :scs (unsigned-reg)))
          (:result-types positive-fixnum)
@@ -267,18 +269,21 @@
                        (mask ,(1- (ash 1 bits)))
                        (shift (* extra ,bits)))
                   (unless (= value mask)
                        (mask ,(1- (ash 1 bits)))
                        (shift (* extra ,bits)))
                   (unless (= value mask)
-                   (inst and old (lognot (ash mask shift))))
+                   (inst mov mask-tn (lognot (ash mask shift)))
+                   (inst and old mask-tn))
                   (unless (zerop value)
                   (unless (zerop value)
-                   (inst or old (ash value shift)))))
+                   (inst mov mask-tn (ash value shift))
+                   (inst or old mask-tn))))
                (unsigned-reg
                 (let ((shift (* extra ,bits)))
                   (unless (zerop shift)
                     (inst ror old shift))
                (unsigned-reg
                 (let ((shift (* extra ,bits)))
                   (unless (zerop shift)
                     (inst ror old shift))
-                  (inst and old (lognot ,(1- (ash 1 bits))))
+                 (inst mov mask-tn (lognot ,(1- (ash 1 bits))))
+                  (inst and old mask-tn)
                    (inst or old value)
                   (unless (zerop shift)
                      (inst rol old shift)))))
                    (inst or old value)
                   (unless (zerop shift)
                      (inst rol old shift)))))
-            (inst mov (make-ea :dword :base object
+            (inst mov (make-ea :qword :base object
                                 :disp (- (* (+ word vector-data-offset)
                                             n-word-bytes)
                                          other-pointer-lowtag))
                                 :disp (- (* (+ word vector-data-offset)
                                             n-word-bytes)
                                          other-pointer-lowtag))
@@ -300,14 +305,16 @@
    (:args (object :scs (descriptor-reg))
          (index :scs (any-reg)))
    (:arg-types simple-array-single-float positive-fixnum)
    (:args (object :scs (descriptor-reg))
          (index :scs (any-reg)))
    (:arg-types simple-array-single-float positive-fixnum)
+  (:temporary (:sc unsigned-reg) dword-index)
    (:results (value :scs (single-reg)))
    (:result-types single-float)
    (:generator 5
    (:results (value :scs (single-reg)))
    (:result-types single-float)
    (:generator 5
-   (with-empty-tn@fp-top(value)
-     (inst fld (make-ea        :dword :base object :index index :scale 1
-                       :disp (- (* vector-data-offset
-                                   n-word-bytes)
-                                other-pointer-lowtag))))))
+   (move dword-index index)
+   (inst shr dword-index 1)
+   (inst movss value (make-ea :dword :base object :index dword-index
+                             :disp (- (* vector-data-offset
+                                         n-word-bytes)
+                                      other-pointer-lowtag)))))
  
  (define-vop (data-vector-ref-c/simple-array-single-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref-c/simple-array-single-float)
    (:note "inline array access")
@@ -315,16 +322,15 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-single-float (:constant (signed-byte 61)))
+  (:arg-types simple-array-single-float (:constant low-index))
    (:results (value :scs (single-reg)))
    (:result-types single-float)
    (:generator 4
    (:results (value :scs (single-reg)))
    (:result-types single-float)
    (:generator 4
-   (with-empty-tn@fp-top(value)
-     (inst fld (make-ea        :dword :base object
-                       :disp (- (+ (* vector-data-offset
-                                      n-word-bytes)
-                                   (* 4 index))
-                                other-pointer-lowtag))))))
+   (inst movss value (make-ea :dword :base object
+                             :disp (- (+ (* vector-data-offset
+                                            n-word-bytes)
+                                         (* 4 index))
+                                      other-pointer-lowtag)))))
  
  (define-vop (data-vector-set/simple-array-single-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set/simple-array-single-float)
    (:note "inline array store")
@@ -334,33 +340,19 @@
          (index :scs (any-reg))
          (value :scs (single-reg) :target result))
    (:arg-types simple-array-single-float positive-fixnum single-float)
          (index :scs (any-reg))
          (value :scs (single-reg) :target result))
    (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:temporary (:sc unsigned-reg) dword-index)
    (:results (result :scs (single-reg)))
    (:result-types single-float)
    (:generator 5
    (:results (result :scs (single-reg)))
    (:result-types single-float)
    (:generator 5
-    (cond ((zerop (tn-offset value))
-          ;; Value is in ST0.
-          (inst fst (make-ea :dword :base object :index index :scale 1
-                             :disp (- (* vector-data-offset
-                                         n-word-bytes)
-                                      other-pointer-lowtag)))
-          (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 :dword :base object :index index :scale 1
-                             :disp (- (* vector-data-offset
-                                         n-word-bytes)
-                                      other-pointer-lowtag)))
-          (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)))))))
+   (move dword-index index)
+   (inst shr dword-index 1)
+   (inst movss (make-ea :dword :base object :index dword-index
+                       :disp (- (* vector-data-offset
+                                   n-word-bytes)
+                                other-pointer-lowtag))
+        value)
+   (unless (location= result value)
+     (inst movss result value))))
  
  (define-vop (data-vector-set-c/simple-array-single-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set-c/simple-array-single-float)
    (:note "inline array store")
@@ -369,37 +361,19 @@
    (:args (object :scs (descriptor-reg))
          (value :scs (single-reg) :target result))
    (:info index)
    (:args (object :scs (descriptor-reg))
          (value :scs (single-reg) :target result))
    (:info index)
-  (:arg-types simple-array-single-float (:constant (signed-byte 29))
+  (:arg-types simple-array-single-float (:constant low-index)
               single-float)
    (:results (result :scs (single-reg)))
    (:result-types single-float)
    (:generator 4
               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 :dword :base object
-                             :disp (- (+ (* vector-data-offset
-                                            n-word-bytes)
-                                         (* 4 index))
-                                      other-pointer-lowtag)))
-          (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 :dword :base object
-                             :disp (- (+ (* vector-data-offset
-                                            n-word-bytes)
-                                         (* 4 index))
-                                      other-pointer-lowtag)))
-          (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)))))))
+   (inst movss (make-ea :dword :base object
+                       :disp (- (+ (* vector-data-offset
+                                      n-word-bytes)
+                                   (* 4 index))
+                                other-pointer-lowtag))
+        value)
+   (unless (location= result value)
+     (inst movss result value))))
  
  (define-vop (data-vector-ref/simple-array-double-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref/simple-array-double-float)
    (:note "inline array access")
@@ -411,11 +385,10 @@
    (:results (value :scs (double-reg)))
    (:result-types double-float)
    (:generator 7
    (:results (value :scs (double-reg)))
    (:result-types double-float)
    (:generator 7
-   (with-empty-tn@fp-top(value)
-     (inst fldd (make-ea :dword :base object :index index :scale 2
-                        :disp (- (* vector-data-offset
-                                    n-word-bytes)
-                                 other-pointer-lowtag))))))
+   (inst movsd value (make-ea :qword :base object :index index :scale 1
+                             :disp (- (* vector-data-offset
+                                         n-word-bytes)
+                                      other-pointer-lowtag)))))
  
  (define-vop (data-vector-ref-c/simple-array-double-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref-c/simple-array-double-float)
    (:note "inline array access")
@@ -423,16 +396,15 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-double-float (:constant (signed-byte 29)))
+  (:arg-types simple-array-double-float (:constant low-index))
    (:results (value :scs (double-reg)))
    (:result-types double-float)
    (:generator 6
    (:results (value :scs (double-reg)))
    (:result-types double-float)
    (:generator 6
-   (with-empty-tn@fp-top(value)
-     (inst fldd (make-ea :dword :base object
-                        :disp (- (+ (* vector-data-offset
-                                       n-word-bytes)
-                                    (* 8 index))
-                                 other-pointer-lowtag))))))
+   (inst movsd value (make-ea :qword :base object
+                             :disp (- (+ (* vector-data-offset
+                                            n-word-bytes)
+                                         (* 8 index))
+                                      other-pointer-lowtag)))))
  
  (define-vop (data-vector-set/simple-array-double-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set/simple-array-double-float)
    (:note "inline array store")
@@ -445,30 +417,13 @@
    (:results (result :scs (double-reg)))
    (:result-types double-float)
    (:generator 20
    (:results (result :scs (double-reg)))
    (:result-types double-float)
    (:generator 20
-    (cond ((zerop (tn-offset value))
-          ;; Value is in ST0.
-          (inst fstd (make-ea :dword :base object :index index :scale 2
+   (inst movsd (make-ea :qword :base object :index index :scale 1
                                :disp (- (* vector-data-offset
                                            n-word-bytes)
                                :disp (- (* vector-data-offset
                                            n-word-bytes)
-                                       other-pointer-lowtag)))
-          (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 :dword :base object :index index :scale 2
-                              :disp (- (* vector-data-offset
-                                          n-word-bytes)
-                                       other-pointer-lowtag)))
-          (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)))))))
+                                       other-pointer-lowtag))
+        value)
+   (unless (location= result value)
+     (inst movsd result value))))
  
  (define-vop (data-vector-set-c/simple-array-double-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set-c/simple-array-double-float)
    (:note "inline array store")
@@ -477,38 +432,19 @@
    (:args (object :scs (descriptor-reg))
          (value :scs (double-reg) :target result))
    (:info index)
    (:args (object :scs (descriptor-reg))
          (value :scs (double-reg) :target result))
    (:info index)
-  (:arg-types simple-array-double-float (:constant (signed-byte 61))
+  (:arg-types simple-array-double-float (:constant low-index)
               double-float)
    (:results (result :scs (double-reg)))
    (:result-types double-float)
    (:generator 19
               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 :dword :base object
-                              :disp (- (+ (* vector-data-offset
-                                             n-word-bytes)
-                                          (* 8 index))
-                                       other-pointer-lowtag)))
-          (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 :dword :base object
-                              :disp (- (+ (* vector-data-offset
-                                             n-word-bytes)
-                                          (* 8 index))
-                                       other-pointer-lowtag)))
-          (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)))))))
-
+   (inst movsd (make-ea :qword :base object
+                       :disp (- (+ (* vector-data-offset
+                                      n-word-bytes)
+                                   (* 8 index))
+                                other-pointer-lowtag))
+        value)
+   (unless (location= result value)
+     (inst movsd result value))))
  
  
  ;;; complex float variants
  
  
  ;;; complex float variants
@@ -524,17 +460,16 @@
    (:result-types complex-single-float)
    (:generator 5
      (let ((real-tn (complex-single-reg-real-tn value)))
    (: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 :dword :base object :index index :scale 2
-                          :disp (- (* vector-data-offset
-                                      n-word-bytes)
-                                   other-pointer-lowtag)))))
+      (inst movss real-tn (make-ea :dword :base object :index index
+                                  :disp (- (* vector-data-offset
+                                              n-word-bytes)
+                                           other-pointer-lowtag))))
      (let ((imag-tn (complex-single-reg-imag-tn value)))
      (let ((imag-tn (complex-single-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fld (make-ea :dword :base object :index index :scale 2
-                          :disp (- (* (1+ vector-data-offset)
-                                      n-word-bytes)
-                                   other-pointer-lowtag)))))))
+      (inst movss imag-tn (make-ea :dword :base object :index index
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              4)
+                                           other-pointer-lowtag))))))
  
  (define-vop (data-vector-ref-c/simple-array-complex-single-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref-c/simple-array-complex-single-float)
    (:note "inline array access")
@@ -542,24 +477,22 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-complex-single-float (:constant (signed-byte 29)))
+  (:arg-types simple-array-complex-single-float (:constant low-index))
    (:results (value :scs (complex-single-reg)))
    (:result-types complex-single-float)
    (:generator 4
      (let ((real-tn (complex-single-reg-real-tn value)))
    (: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 :dword :base object
-                          :disp (- (+ (* vector-data-offset
-                                         n-word-bytes)
-                                      (* 8 index))
-                                   other-pointer-lowtag)))))
+      (inst movss real-tn (make-ea :dword :base object
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              (* 8 index))
+                                           other-pointer-lowtag))))
      (let ((imag-tn (complex-single-reg-imag-tn value)))
      (let ((imag-tn (complex-single-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fld (make-ea :dword :base object
-                          :disp (- (+ (* vector-data-offset
-                                         n-word-bytes)
-                                      (* 8 index) 4)
-                                   other-pointer-lowtag)))))))
+      (inst movss imag-tn (make-ea :dword :base object
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              (* 8 index) 4)
+                                           other-pointer-lowtag))))))
  
  (define-vop (data-vector-set/simple-array-complex-single-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set/simple-array-complex-single-float)
    (:note "inline array store")
@@ -575,41 +508,23 @@
    (:generator 5
      (let ((value-real (complex-single-reg-real-tn value))
           (result-real (complex-single-reg-real-tn result)))
    (: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 :dword :base object :index index :scale 2
-                               :disp (- (* vector-data-offset
-                                           n-word-bytes)
-                                        other-pointer-lowtag)))
-            (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 :dword :base object :index index :scale 2
-                               :disp (- (* vector-data-offset
-                                           n-word-bytes)
-                                        other-pointer-lowtag)))
-            (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))))))
+      (inst movss (make-ea :dword :base object :index index
+                          :disp (- (* vector-data-offset
+                                      n-word-bytes)
+                                   other-pointer-lowtag))
+           value-real)
+      (unless (location= value-real result-real)
+       (inst movss result-real value-real)))
      (let ((value-imag (complex-single-reg-imag-tn value))
           (result-imag (complex-single-reg-imag-tn result)))
      (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 :dword :base object :index index :scale 2
-                        :disp (- (+ (* vector-data-offset
-                                       n-word-bytes)
-                                    4)
-                                 other-pointer-lowtag)))
+      (inst movss (make-ea :dword :base object :index index
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      4)
+                                   other-pointer-lowtag))
+           value-imag)
        (unless (location= value-imag result-imag)
        (unless (location= value-imag result-imag)
-       (inst fst result-imag))
-      (inst fxch value-imag))))
+       (inst movss result-imag value-imag)))))
  
  (define-vop (data-vector-set-c/simple-array-complex-single-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set-c/simple-array-complex-single-float)
    (:note "inline array store")
@@ -618,51 +533,31 @@
    (:args (object :scs (descriptor-reg))
          (value :scs (complex-single-reg) :target result))
    (:info index)
    (:args (object :scs (descriptor-reg))
          (value :scs (complex-single-reg) :target result))
    (:info index)
-  (:arg-types simple-array-complex-single-float (:constant (signed-byte 61))
+  (:arg-types simple-array-complex-single-float (:constant low-index)
               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)))
               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 :dword :base object
-                               :disp (- (+ (* vector-data-offset
-                                              n-word-bytes)
-                                           (* 8 index))
-                                        other-pointer-lowtag)))
-            (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 :dword :base object
-                               :disp (- (+ (* vector-data-offset
-                                              n-word-bytes)
-                                           (* 8 index))
-                                        other-pointer-lowtag)))
-            (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))))))
+      (inst movss (make-ea :dword :base object
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      (* 8 index))
+                                   other-pointer-lowtag))
+           value-real)
+      (unless (location= value-real result-real)
+       (inst movss result-real value-real)))
      (let ((value-imag (complex-single-reg-imag-tn value))
           (result-imag (complex-single-reg-imag-tn result)))
      (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 :dword :base object
-                        :disp (- (+ (* vector-data-offset
-                                       n-word-bytes)
-                                    (* 8 index) 4)
-                                 other-pointer-lowtag)))
+      (inst movss (make-ea :dword :base object
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      (* 8 index) 4)
+                                   other-pointer-lowtag))
+           value-imag)
        (unless (location= value-imag result-imag)
        (unless (location= value-imag result-imag)
-       (inst fst result-imag))
-      (inst fxch value-imag))))
-
+       (inst movss result-imag value-imag)))))
  
  (define-vop (data-vector-ref/simple-array-complex-double-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref/simple-array-complex-double-float)
    (:note "inline array access")
@@ -675,18 +570,16 @@
    (:result-types complex-double-float)
    (:generator 7
      (let ((real-tn (complex-double-reg-real-tn value)))
    (: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 :dword :base object :index index :scale 4
-                           :disp (- (* vector-data-offset
-                                       n-word-bytes)
-                                    other-pointer-lowtag)))))
+      (inst movsd real-tn (make-ea :dword :base object :index index :scale 2
+                                  :disp (- (* vector-data-offset
+                                              n-word-bytes)
+                                           other-pointer-lowtag))))
      (let ((imag-tn (complex-double-reg-imag-tn value)))
      (let ((imag-tn (complex-double-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fldd (make-ea :dword :base object :index index :scale 4
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       8)
-                                    other-pointer-lowtag)))))))
+      (inst movsd imag-tn (make-ea :dword :base object :index index :scale 2
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              8)
+                                           other-pointer-lowtag))))))
  
  (define-vop (data-vector-ref-c/simple-array-complex-double-float)
    (:note "inline array access")
  
  (define-vop (data-vector-ref-c/simple-array-complex-double-float)
    (:note "inline array access")
@@ -694,24 +587,22 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-complex-double-float (:constant (signed-byte 29)))
+  (:arg-types simple-array-complex-double-float (:constant low-index))
    (:results (value :scs (complex-double-reg)))
    (:result-types complex-double-float)
    (:generator 6
      (let ((real-tn (complex-double-reg-real-tn value)))
    (: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 :dword :base object
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       (* 16 index))
-                                    other-pointer-lowtag)))))
+      (inst movsd real-tn (make-ea :qword :base object 
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              (* 16 index))
+                                           other-pointer-lowtag))))
      (let ((imag-tn (complex-double-reg-imag-tn value)))
      (let ((imag-tn (complex-double-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fldd (make-ea :dword :base object
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       (* 16 index) 8)
-                                    other-pointer-lowtag)))))))
+      (inst movsd imag-tn (make-ea :qword :base object
+                                  :disp (- (+ (* vector-data-offset
+                                                 n-word-bytes)
+                                              (* 16 index) 8)
+                                           other-pointer-lowtag))))))
  
  (define-vop (data-vector-set/simple-array-complex-double-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set/simple-array-complex-double-float)
    (:note "inline array store")
@@ -727,41 +618,23 @@
    (:generator 20
      (let ((value-real (complex-double-reg-real-tn value))
           (result-real (complex-double-reg-real-tn result)))
    (: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 :dword :base object :index index :scale 4
-                                :disp (- (* vector-data-offset
-                                            n-word-bytes)
-                                         other-pointer-lowtag)))
-            (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 :dword :base object :index index :scale 4
-                                :disp (- (* vector-data-offset
-                                            n-word-bytes)
-                                         other-pointer-lowtag)))
-            (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))))))
+      (inst movsd (make-ea :qword :base object :index index :scale 2
+                          :disp (- (* vector-data-offset
+                                      n-word-bytes)
+                                   other-pointer-lowtag))
+           value-real)
+      (unless (location= value-real result-real)
+       (inst movsd result-real value-real)))
      (let ((value-imag (complex-double-reg-imag-tn value))
           (result-imag (complex-double-reg-imag-tn result)))
      (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 :dword :base object :index index :scale 4
-                         :disp (- (+ (* vector-data-offset
-                                        n-word-bytes)
-                                     8)
-                                  other-pointer-lowtag)))
+      (inst movsd (make-ea :qword :base object :index index :scale 2
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      8)
+                                   other-pointer-lowtag))
+           value-imag)
        (unless (location= value-imag result-imag)
        (unless (location= value-imag result-imag)
-       (inst fstd result-imag))
-      (inst fxch value-imag))))
+       (inst movsd result-imag value-imag)))))
  
  (define-vop (data-vector-set-c/simple-array-complex-double-float)
    (:note "inline array store")
  
  (define-vop (data-vector-set-c/simple-array-complex-double-float)
    (:note "inline array store")
@@ -770,53 +643,31 @@
    (:args (object :scs (descriptor-reg))
          (value :scs (complex-double-reg) :target result))
    (:info index)
    (:args (object :scs (descriptor-reg))
          (value :scs (complex-double-reg) :target result))
    (:info index)
-  (:arg-types simple-array-complex-double-float (:constant (signed-byte 61))
+  (:arg-types simple-array-complex-double-float (:constant low-index)
               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)))
               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 :dword :base object
-                                :disp (- (+ (* vector-data-offset
-                                               n-word-bytes)
-                                            (* 16 index))
-                                         other-pointer-lowtag)))
-            (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 :dword :base object
-                                :disp (- (+ (* vector-data-offset
-                                               n-word-bytes)
-                                            (* 16 index))
-                                         other-pointer-lowtag)))
-            (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))))))
+      (inst movsd (make-ea :qword :base object
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      (* 16 index))
+                                   other-pointer-lowtag))
+           value-real)
+      (unless (location= value-real result-real)
+       (inst movsd result-real value-real)))
      (let ((value-imag (complex-double-reg-imag-tn value))
           (result-imag (complex-double-reg-imag-tn result)))
      (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 :dword :base object
-                         :disp (- (+ (* vector-data-offset
-                                        n-word-bytes)
-                                     (* 16 index) 8)
-                                  other-pointer-lowtag)))
+      (inst movsd (make-ea :qword :base object
+                          :disp (- (+ (* vector-data-offset
+                                         n-word-bytes)
+                                      (* 16 index) 8)
+                                   other-pointer-lowtag))
+           value-imag)
        (unless (location= value-imag result-imag)
        (unless (location= value-imag result-imag)
-       (inst fstd result-imag))
-      (inst fxch value-imag))))
-
-
-
+       (inst movsd result-imag value-imag)))))
  
  \f
  
  
  \f
  
@@ -841,7 +692,7 @@
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg)))
        (:info index)
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg)))
        (:info index)
-      (:arg-types ,ptype (:constant (signed-byte 61)))
+      (:arg-types ,ptype (:constant low-index))
        (:results (value :scs (unsigned-reg signed-reg)))
        (:result-types positive-fixnum)
        (:generator 4
        (:results (value :scs (unsigned-reg signed-reg)))
        (:result-types positive-fixnum)
        (:generator 4
@@ -874,7 +725,7 @@
        (:args (object :scs (descriptor-reg) :to (:eval 0))
              (value :scs (unsigned-reg signed-reg) :target eax))
        (:info index)
        (:args (object :scs (descriptor-reg) :to (:eval 0))
              (value :scs (unsigned-reg signed-reg) :target eax))
        (:info index)
-      (:arg-types ,ptype (:constant (signed-byte 61))
+      (:arg-types ,ptype (:constant low-index)
                   positive-fixnum)
        (:temporary (:sc unsigned-reg :offset eax-offset :target result
                        :from (:argument 1) :to (:result 0))
                   positive-fixnum)
        (:temporary (:sc unsigned-reg :offset eax-offset :target result
                        :from (:argument 1) :to (:result 0))
@@ -912,7 +763,7 @@
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg)))
         (:info index)
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg)))
         (:info index)
-       (:arg-types ,ptype (:constant (signed-byte 29)))
+       (:arg-types ,ptype (:constant low-index))
         (:results (value :scs (unsigned-reg signed-reg)))
         (:result-types positive-fixnum)
         (:generator 4
         (:results (value :scs (unsigned-reg signed-reg)))
         (:result-types positive-fixnum)
         (:generator 4
@@ -946,7 +797,7 @@
         (:args (object :scs (descriptor-reg) :to (:eval 0))
                (value :scs (unsigned-reg signed-reg) :target eax))
         (:info index)
         (:args (object :scs (descriptor-reg) :to (:eval 0))
                (value :scs (unsigned-reg signed-reg) :target eax))
         (:info index)
-       (:arg-types ,ptype (:constant (signed-byte 29))
+       (:arg-types ,ptype (:constant low-index)
                     positive-fixnum)
         (:temporary (:sc unsigned-reg :offset eax-offset :target result
                          :from (:argument 1) :to (:result 0))
                     positive-fixnum)
         (:temporary (:sc unsigned-reg :offset eax-offset :target result
                          :from (:argument 1) :to (:result 0))
@@ -984,13 +835,14 @@
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg)))
         (:info index)
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg)))
         (:info index)
-       (:arg-types ,ptype (:constant (signed-byte 61)))
+       (:arg-types ,ptype (:constant low-index))
         (:results (value :scs (unsigned-reg signed-reg)))
         (:result-types positive-fixnum)
         (:generator 4
           (inst movzxd value
                 (make-ea :dword :base object
         (:results (value :scs (unsigned-reg signed-reg)))
         (:result-types positive-fixnum)
         (:generator 4
           (inst movzxd value
                 (make-ea :dword :base object
-                        :disp (- (+ (* vector-data-offset n-word-bytes) (* 4 index))
+                        :disp (- (+ (* vector-data-offset n-word-bytes)
+                                    (* 4 index))
                                   other-pointer-lowtag)))))
        (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
         (:translate data-vector-set)
                                   other-pointer-lowtag)))))
        (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
         (:translate data-vector-set)
@@ -1018,7 +870,7 @@
         (:args (object :scs (descriptor-reg) :to (:eval 0))
                (value :scs (unsigned-reg signed-reg) :target rax))
         (:info index)
         (:args (object :scs (descriptor-reg) :to (:eval 0))
                (value :scs (unsigned-reg signed-reg) :target rax))
         (:info index)
-       (:arg-types ,ptype (:constant (signed-byte 61))
+       (:arg-types ,ptype (:constant low-index)
                     positive-fixnum)
         (:temporary (:sc unsigned-reg :offset rax-offset :target result
                          :from (:argument 1) :to (:result 0))
                     positive-fixnum)
         (:temporary (:sc unsigned-reg :offset rax-offset :target result
                          :from (:argument 1) :to (:result 0))
@@ -1038,14 +890,88 @@
  
  ;;; simple-string
  
  
  ;;; simple-string
  
+#!+sb-unicode
+(progn
  (define-vop (data-vector-ref/simple-base-string)
    (:translate data-vector-ref)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg))
          (index :scs (unsigned-reg)))
    (:arg-types simple-base-string positive-fixnum)
  (define-vop (data-vector-ref/simple-base-string)
    (:translate data-vector-ref)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg))
          (index :scs (unsigned-reg)))
    (:arg-types simple-base-string positive-fixnum)
-  (:results (value :scs (base-char-reg)))
-  (:result-types base-char)
+  (:results (value :scs (character-reg)))
+  (:result-types character)
+  (:generator 5
+    (inst movzx value
+         (make-ea :byte :base object :index index :scale 1
+                  :disp (- (* vector-data-offset n-word-bytes)
+                           other-pointer-lowtag)))))
+
+(define-vop (data-vector-ref-c/simple-base-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-base-string (:constant low-index))
+  (:results (value :scs (character-reg)))
+  (:result-types character)
+  (:generator 4
+    (inst movzx value
+         (make-ea :byte :base object
+                  :disp (- (+ (* vector-data-offset n-word-bytes) index)
+                           other-pointer-lowtag)))))
+
+(define-vop (data-vector-set/simple-base-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 (character-reg) :target rax))
+  (:arg-types simple-base-string positive-fixnum character)
+  (:temporary (:sc character-reg :offset rax-offset :target result
+                   :from (:argument 2) :to (:result 0))
+              rax)
+  (:results (result :scs (character-reg)))
+  (:result-types character)
+  (:generator 5
+    (move rax value)
+    (inst mov (make-ea :byte :base object :index index :scale 1
+                       :disp (- (* vector-data-offset n-word-bytes)
+                                other-pointer-lowtag))
+          al-tn)
+    (move result rax)))
+
+(define-vop (data-vector-set-c/simple-base-string)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+         (value :scs (character-reg)))
+  (:info index)
+  (:arg-types simple-base-string (:constant (signed-byte 30)) character)
+  (:temporary (:sc character-reg :offset eax-offset :target result
+                   :from (:argument 1) :to (:result 0))
+              rax)
+  (:results (result :scs (character-reg)))
+  (:result-types character)
+  (:generator 4
+    (move rax value)
+    (inst mov (make-ea :byte :base object
+                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
+                                other-pointer-lowtag))
+          al-tn)
+    (move result rax)))
+) ; PROGN
+
+
+#!-sb-unicode
+(progn
+(define-vop (data-vector-ref/simple-base-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+        (index :scs (unsigned-reg)))
+  (:arg-types simple-base-string positive-fixnum)
+  (:results (value :scs (character-reg)))
+  (:result-types character)
    (:generator 5
      (inst mov value
           (make-ea :byte :base object :index index :scale 1
    (:generator 5
      (inst mov value
           (make-ea :byte :base object :index index :scale 1
@@ -1057,9 +983,9 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-base-string (:constant (signed-byte 61)))
-  (:results (value :scs (base-char-reg)))
-  (:result-types base-char)
+  (:arg-types simple-base-string (:constant low-index))
+  (:results (value :scs (character-reg)))
+  (:result-types character)
    (:generator 4
      (inst mov value
           (make-ea :byte :base object
    (:generator 4
      (inst mov value
           (make-ea :byte :base object
@@ -1071,10 +997,10 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (index :scs (unsigned-reg) :to (:eval 0))
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (index :scs (unsigned-reg) :to (:eval 0))
-        (value :scs (base-char-reg) :target result))
-  (:arg-types simple-base-string positive-fixnum base-char)
-  (:results (result :scs (base-char-reg)))
-  (:result-types base-char)
+        (value :scs (character-reg) :target result))
+  (:arg-types simple-base-string positive-fixnum character)
+  (:results (result :scs (character-reg)))
+  (:result-types character)
    (:generator 5
      (inst mov (make-ea :byte :base object :index index :scale 1
                        :disp (- (* vector-data-offset n-word-bytes)
    (:generator 5
      (inst mov (make-ea :byte :base object :index index :scale 1
                        :disp (- (* vector-data-offset n-word-bytes)
@@ -1082,22 +1008,95 @@
           value)
      (move result value)))
  
           value)
      (move result value)))
  
-(define-vop (data-vector-set/simple-base-string-c)
+(define-vop (data-vector-set-c/simple-base-string)
    (:translate data-vector-set)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
    (:translate data-vector-set)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
-        (value :scs (base-char-reg)))
+        (value :scs (character-reg)))
    (:info index)
    (:info index)
-  (:arg-types simple-base-string (:constant (signed-byte 61)) base-char)
-  (:results (result :scs (base-char-reg)))
-  (:result-types base-char)
+  (:arg-types simple-base-string (:constant low-index) character)
+  (:results (result :scs (character-reg)))
+  (:result-types character)
    (:generator 4
     (inst mov (make-ea :byte :base object
                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
                                other-pointer-lowtag))
          value)
     (move result value)))
    (:generator 4
     (inst mov (make-ea :byte :base object
                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
                                other-pointer-lowtag))
          value)
     (move result value)))
+) ; PROGN
  
  
+#!+sb-unicode
+(macrolet ((define-data-vector-frobs (ptype)
+    `(progn
+      (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
+       (:translate data-vector-ref)
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+              (index :scs (unsigned-reg)))
+       (:arg-types ,ptype positive-fixnum)
+       (:results (value :scs (character-reg)))
+       (:result-types character)
+       (:generator 5
+         (inst movzxd value
+               (make-ea :dword :base object :index index :scale 4
+                        :disp (- (* vector-data-offset n-word-bytes)
+                                 other-pointer-lowtag)))))
+      (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
+       (:translate data-vector-ref)
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,ptype (:constant low-index))
+       (:results (value :scs (character-reg)))
+       (:result-types character)
+       (:generator 4
+         (inst movzxd value
+               (make-ea :dword :base object
+                        :disp (- (+ (* vector-data-offset n-word-bytes)
+                                    (* 4 index))
+                                 other-pointer-lowtag)))))
+      (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
+       (:translate data-vector-set)
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to (:eval 0))
+              (index :scs (unsigned-reg) :to (:eval 0))
+              (value :scs (character-reg) :target rax))
+       (:arg-types ,ptype positive-fixnum character)
+       (:temporary (:sc character-reg :offset rax-offset :target result
+                        :from (:argument 2) :to (:result 0))
+                   rax)
+       (:results (result :scs (character-reg)))
+       (:result-types character)
+       (:generator 5
+         (move rax value)
+         (inst mov (make-ea :dword :base object :index index :scale 4
+                            :disp (- (* vector-data-offset n-word-bytes)
+                                     other-pointer-lowtag))
+               eax-tn)
+         (move result rax)))
+
+      (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
+       (:translate data-vector-set)
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg) :to (:eval 0))
+              (value :scs (character-reg) :target rax))
+       (:info index)
+       (:arg-types ,ptype (:constant low-index) character)
+       (:temporary (:sc character-reg :offset rax-offset :target result
+                        :from (:argument 1) :to (:result 0))
+                   rax)
+       (:results (result :scs (character-reg)))
+       (:result-types character)
+       (:generator 4
+         (move rax value)
+         (inst mov (make-ea :dword :base object
+                            :disp (- (+ (* vector-data-offset n-word-bytes)
+                                        (* 4 index))
+                                     other-pointer-lowtag))
+               eax-tn)
+         (move result rax))))))
+  (define-data-vector-frobs simple-character-string))
+\f
  ;;; signed-byte-8
  
  (define-vop (data-vector-ref/simple-array-signed-byte-8)
  ;;; signed-byte-8
  
  (define-vop (data-vector-ref/simple-array-signed-byte-8)
@@ -1119,7 +1118,7 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 61)))
+  (:arg-types simple-array-signed-byte-8 (:constant low-index))
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
@@ -1154,7 +1153,7 @@
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
-  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 61))
+  (:arg-types simple-array-signed-byte-8 (:constant low-index)
               tagged-num)
    (:temporary (:sc unsigned-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
               tagged-num)
    (:temporary (:sc unsigned-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
@@ -1190,7 +1189,7 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 61)))
+  (:arg-types simple-array-signed-byte-16 (:constant low-index))
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
@@ -1226,7 +1225,7 @@
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
-  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 61)) tagged-num)
+  (:arg-types simple-array-signed-byte-16 (:constant low-index) tagged-num)
    (:temporary (:sc signed-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
               eax)
    (:temporary (:sc signed-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
               eax)
@@ -1262,7 +1261,7 @@
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
    (:policy :fast-safe)
    (:args (object :scs (descriptor-reg)))
    (:info index)
-  (:arg-types simple-array-signed-byte-32 (:constant (signed-byte 61)))
+  (:arg-types simple-array-signed-byte-32 (:constant low-index))
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
    (:results (value :scs (signed-reg)))
    (:result-types tagged-num)
    (:generator 4
@@ -1298,7 +1297,7 @@
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
    (:args (object :scs (descriptor-reg) :to (:eval 0))
          (value :scs (signed-reg) :target eax))
    (:info index)
-  (:arg-types simple-array-signed-byte-32 (:constant (signed-byte 61)) tagged-num)
+  (:arg-types simple-array-signed-byte-32 (:constant low-index) tagged-num)
    (:temporary (:sc signed-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
               eax)
    (:temporary (:sc signed-reg :offset eax-offset :target result
                    :from (:argument 1) :to (:result 0))
               eax)
@@ -1321,25 +1320,25 @@
    (:arg-types sb!c::raw-vector positive-fixnum))
  (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
    (:translate %raw-ref-single)
    (:arg-types sb!c::raw-vector positive-fixnum))
  (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
    (:translate %raw-ref-single)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+  (:arg-types sb!c::raw-vector (:constant low-index)))
  (define-vop (raw-set-single data-vector-set/simple-array-single-float)
    (:translate %raw-set-single)
    (:arg-types sb!c::raw-vector positive-fixnum single-float))
  (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
    (:translate %raw-set-single)
  (define-vop (raw-set-single data-vector-set/simple-array-single-float)
    (:translate %raw-set-single)
    (:arg-types sb!c::raw-vector positive-fixnum single-float))
  (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
    (:translate %raw-set-single)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61)) single-float))
+  (:arg-types sb!c::raw-vector (:constant low-index) single-float))
  (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
    (:translate %raw-ref-double)
    (:arg-types sb!c::raw-vector positive-fixnum))
  (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
    (:translate %raw-ref-double)
  (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
    (:translate %raw-ref-double)
    (:arg-types sb!c::raw-vector positive-fixnum))
  (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
    (:translate %raw-ref-double)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+  (:arg-types sb!c::raw-vector (:constant low-index)))
  (define-vop (raw-set-double data-vector-set/simple-array-double-float)
    (:translate %raw-set-double)
    (:arg-types sb!c::raw-vector positive-fixnum double-float))
  (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
    (:translate %raw-set-double)
  (define-vop (raw-set-double data-vector-set/simple-array-double-float)
    (:translate %raw-set-double)
    (:arg-types sb!c::raw-vector positive-fixnum double-float))
  (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
    (:translate %raw-set-double)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61)) double-float))
+  (:arg-types sb!c::raw-vector (:constant low-index) double-float))
  
  
  ;;;; complex-float raw structure slot accessors
  
  
  ;;;; complex-float raw structure slot accessors
@@ -1351,7 +1350,7 @@
  (define-vop (raw-ref-complex-single-c
              data-vector-ref-c/simple-array-complex-single-float)
    (:translate %raw-ref-complex-single)
  (define-vop (raw-ref-complex-single-c
              data-vector-ref-c/simple-array-complex-single-float)
    (:translate %raw-ref-complex-single)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+  (:arg-types sb!c::raw-vector (:constant low-index)))
  (define-vop (raw-set-complex-single
              data-vector-set/simple-array-complex-single-float)
    (:translate %raw-set-complex-single)
  (define-vop (raw-set-complex-single
              data-vector-set/simple-array-complex-single-float)
    (:translate %raw-set-complex-single)
@@ -1359,7 +1358,7 @@
  (define-vop (raw-set-complex-single-c
              data-vector-set-c/simple-array-complex-single-float)
    (:translate %raw-set-complex-single)
  (define-vop (raw-set-complex-single-c
              data-vector-set-c/simple-array-complex-single-float)
    (:translate %raw-set-complex-single)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))
+  (:arg-types sb!c::raw-vector (:constant low-index)
               complex-single-float))
  (define-vop (raw-ref-complex-double
              data-vector-ref/simple-array-complex-double-float)
               complex-single-float))
  (define-vop (raw-ref-complex-double
              data-vector-ref/simple-array-complex-double-float)
@@ -1368,7 +1367,7 @@
  (define-vop (raw-ref-complex-double-c
              data-vector-ref-c/simple-array-complex-double-float)
    (:translate %raw-ref-complex-double)
  (define-vop (raw-ref-complex-double-c
              data-vector-ref-c/simple-array-complex-double-float)
    (:translate %raw-ref-complex-double)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+  (:arg-types sb!c::raw-vector (:constant low-index)))
  (define-vop (raw-set-complex-double
              data-vector-set/simple-array-complex-double-float)
    (:translate %raw-set-complex-double)
  (define-vop (raw-set-complex-double
              data-vector-set/simple-array-complex-double-float)
    (:translate %raw-set-complex-double)
@@ -1376,7 +1375,7 @@
  (define-vop (raw-set-complex-double-c
              data-vector-set-c/simple-array-complex-double-float)
    (:translate %raw-set-complex-double)
  (define-vop (raw-set-complex-double-c
              data-vector-set-c/simple-array-complex-double-float)
    (:translate %raw-set-complex-double)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 61))
+  (:arg-types sb!c::raw-vector (:constant low-index)
               complex-double-float))
  
  
               complex-double-float))
  
  
diff --git a/src/compiler/x86-64/backend-parms.lisp b/src/compiler/x86-64/backend-parms.lisp

index a1802f5..1ef5f6f 100644 (file)
--- a/src/compiler/x86-64/backend-parms.lisp
+++ b/src/compiler/x86-64/backend-parms.lisp
@@ -17,7 +17,7 @@
  \f
  ;;;; compiler constants
  
  \f
  ;;;; compiler constants
  
-(def!constant +backend-fasl-file-implementation+ :x86)
+(def!constant +backend-fasl-file-implementation+ :x86-64)
  
  (setf *backend-register-save-penalty* 3)
  
  
  (setf *backend-register-save-penalty* 3)
  
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp

index 7c1d468..9cbca95 100644 (file)
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -23,43 +23,48 @@
                  offset))
  
  (defstruct (arg-state (:copier nil))
                  offset))
  
  (defstruct (arg-state (:copier nil))
+  (register-args 0)
+  (xmm-args 0)
    (stack-frame-size 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 6)
+          (setf (arg-state-register-args state) (1+ reg-args))
+          (my-make-wired-tn prim-type reg-sc
+                            (nth reg-args *c-call-register-arg-offsets*)))
+         (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))))))
+
  (define-alien-type-method (integer :arg-tn) (type state)
  (define-alien-type-method (integer :arg-tn) (type state)
-  (let ((stack-frame-size (arg-state-stack-frame-size state)))
-    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
-    (multiple-value-bind (ptype stack-sc)
-       (if (alien-integer-type-signed type)
-           (values 'signed-byte-64 'signed-stack)
-           (values 'unsigned-byte-64 'unsigned-stack))
-      (my-make-wired-tn ptype stack-sc stack-frame-size))))
+  (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)))
  
  (define-alien-type-method (system-area-pointer :arg-tn) (type state)
    (declare (ignore type))
  
  (define-alien-type-method (system-area-pointer :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 'system-area-pointer
-                     'sap-stack
-                     stack-frame-size)))
-
-#!+long-float
-(define-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)))
+  (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
+
+(defun float-arg (state prim-type reg-sc stack-sc)
+  (let ((xmm-args (arg-state-xmm-args state)))
+    (cond ((< xmm-args 8)
+          (setf (arg-state-xmm-args state) (1+ xmm-args))
+          (my-make-wired-tn prim-type reg-sc
+                            (nth xmm-args *float-regs*)))
+         (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))))))
  
  (define-alien-type-method (double-float :arg-tn) (type state)
    (declare (ignore type))
  
  (define-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)))
+  (float-arg state 'double-float 'double-reg 'double-stack))
  
  (define-alien-type-method (single-float :arg-tn) (type state)
    (declare (ignore type))
  
  (define-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)))
+  (float-arg state 'single-float 'single-reg 'single-stack))
  
  (defstruct (result-state (:copier nil))
    (num-results 0))
  
  (defstruct (result-state (:copier nil))
    (num-results 0))
@@ -69,12 +74,17 @@
      (0 eax-offset)
      (1 edx-offset)))
  
      (0 eax-offset)
      (1 edx-offset)))
  
+;; XXX The return handling probably doesn't conform to the ABI
+
  (define-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)
  (define-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 (if (= (sb!alien::alien-integer-type-bits type) 32)
+                       'signed-byte-32
+                       'signed-byte-64)
+                   'signed-reg)
             (values 'unsigned-byte-64 'unsigned-reg))
        (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
  
             (values 'unsigned-byte-64 'unsigned-reg))
        (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
  
@@ -85,24 +95,17 @@
      (my-make-wired-tn 'system-area-pointer 'sap-reg
                       (result-reg-offset num-results))))
  
      (my-make-wired-tn 'system-area-pointer 'sap-reg
                       (result-reg-offset num-results))))
  
-#!+long-float
-(define-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))))
-
  (define-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))
  (define-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))))
+    (my-make-wired-tn 'double-float 'double-reg num-results)))
  
  (define-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))
  
  (define-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))))
+    (my-make-wired-tn 'single-float 'single-reg num-results 2)))
  
  (define-alien-type-method (values :result-tn) (type state)
    (let ((values (alien-values-type-values type)))
  
  (define-alien-type-method (values :result-tn) (type state)
    (let ((values (alien-values-type-values type)))
@@ -188,51 +191,61 @@
    (:translate foreign-symbol-address)
    (:policy :fast-safe)
    (:args)
    (:translate foreign-symbol-address)
    (:policy :fast-safe)
    (:args)
-  (:arg-types (:constant simple-base-string))
+  (:arg-types (:constant simple-string))
    (:info foreign-symbol)
    (:results (res :scs (sap-reg)))
    (:result-types system-area-pointer)
    (:generator 2
     (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
  
    (:info foreign-symbol)
    (:results (res :scs (sap-reg)))
    (:result-types system-area-pointer)
    (:generator 2
     (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
  
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-address)
+  (:translate foreign-symbol-dataref-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-dataref))))
+
  (define-vop (call-out)
    (:args (function :scs (sap-reg))
          (args :more t))
    (:results (results :more t))
  (define-vop (call-out)
    (:args (function :scs (sap-reg))
          (args :more t))
    (:results (results :more t))
-  (:temporary (:sc unsigned-reg :offset eax-offset
-                  :from :eval :to :result) eax)
-  (:temporary (:sc unsigned-reg :offset ecx-offset
-                  :from :eval :to :result) ecx)
-  (:temporary (:sc unsigned-reg :offset edx-offset
-                  :from :eval :to :result) edx)
-  (:node-var node)
+  (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
+  (:temporary (:sc unsigned-reg :offset rcx-offset
+                  :from :eval :to :result) rcx)
    (:vop-var vop)
    (:save-p t)
    (:vop-var vop)
    (:save-p t)
-  (:ignore args ecx edx)
    (:generator 0
    (:generator 0
-    (cond ((policy node (> space speed))
-          (move eax function)
-          (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
-         (t
-          ;; Setup the NPX for C; all the FP registers need to be
-          ;; empty; pop them all.
-          (dotimes (i 8)
-            (inst fstp fr0-tn))
-
-          (inst call function)
-          ;; To give the debugger a clue. XX not really internal-error?
-          (note-this-location vop :internal-error)
-
-          ;; Restore the NPX for lisp; ensure 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
-          ))))
+    ;; ABI: AL contains amount of arguments passed in XMM registers
+    ;; for vararg calls.
+    (move-immediate rax
+                   (loop for tn-ref = args then (tn-ref-across tn-ref)
+                      while tn-ref
+                      count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
+                                'float-registers)))
+    (inst call function)
+    ;; To give the debugger a clue. XX not really internal-error?
+    (note-this-location vop :internal-error)
+    ;; Sign-extend s-b-32 return values.
+    (dolist (res (if (listp results)
+                    results
+                    (list results)))
+      (let ((tn (tn-ref-tn res)))             
+       (when (eq (sb!c::tn-primitive-type tn)
+                 (primitive-type-or-lose 'signed-byte-32))
+         (inst movsxd tn (make-random-tn :kind :normal
+                                         :sc (sc-or-lose 'dword-reg)
+                                         :offset (tn-offset tn))))))
+    ;; FLOAT15 needs to contain FP zero in Lispland
+    (inst xor rcx rcx)
+    (inst movd (make-random-tn :kind :normal 
+                              :sc (sc-or-lose 'double-reg)
+                              :offset float15-offset)
+         rcx)))
  
  (define-vop (alloc-number-stack-space)
    (:info amount)
  
  (define-vop (alloc-number-stack-space)
    (:info amount)
diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp

index f1ce595..eb4f7f4 100644 (file)
--- a/src/compiler/x86-64/call.lisp
+++ b/src/compiler/x86-64/call.lisp
@@ -204,6 +204,7 @@
     ((<= nvals register-arg-count)
      (let ((regs-defaulted (gen-label)))
        (note-this-location vop :unknown-return)
     ((<= nvals register-arg-count)
      (let ((regs-defaulted (gen-label)))
        (note-this-location vop :unknown-return)
+      (inst nop)
        (inst jmp-short regs-defaulted)
        ;; Default the unsupplied registers.
        (let* ((2nd-tn-ref (tn-ref-across values))
        (inst jmp-short regs-defaulted)
        ;; Default the unsupplied registers.
        (let* ((2nd-tn-ref (tn-ref-across values))
@@ -228,6 +229,7 @@
           (default-stack-slots (gen-label)))
        (note-this-location vop :unknown-return)
        ;; Branch off to the MV case.
           (default-stack-slots (gen-label)))
        (note-this-location vop :unknown-return)
        ;; Branch off to the MV case.
+      (inst nop)
        (inst jmp-short regs-defaulted)
        ;; Do the single value case.
        ;; Default the register args
        (inst jmp-short regs-defaulted)
        ;; Do the single value case.
        ;; Default the register args
@@ -285,6 +287,7 @@
           (count-okay (gen-label)))
        (note-this-location vop :unknown-return)
        ;; Branch off to the MV case.
           (count-okay (gen-label)))
        (note-this-location vop :unknown-return)
        ;; Branch off to the MV case.
+      (inst nop)
        (inst jmp-short regs-defaulted)
  
        ;; Default the register args, and set up the stack as if we
        (inst jmp-short regs-defaulted)
  
        ;; Default the register args, and set up the stack as if we
@@ -382,6 +385,7 @@
    (declare (type tn args nargs start count))
    (let ((variable-values (gen-label))
         (done (gen-label)))
    (declare (type tn args nargs start count))
    (let ((variable-values (gen-label))
         (done (gen-label)))
+    (inst nop)
      (inst jmp-short variable-values)
  
      (cond ((location= start (first *register-arg-tns*))
      (inst jmp-short variable-values)
  
      (cond ((location= start (first *register-arg-tns*))
@@ -443,6 +447,7 @@
    (:args (fp)
          (nfp)
          (args :more t))
    (:args (fp)
          (nfp)
          (args :more t))
+  (:temporary (:sc unsigned-reg) return-label)
    (:results (values :more t))
    (:save-p t)
    (:move-args :local-call)
    (:results (values :more t))
    (:save-p t)
    (:move-args :local-call)
@@ -464,8 +469,8 @@
         ((sap-stack)
          #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
                        (tn-offset ret-tn))
         ((sap-stack)
          #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
                        (tn-offset ret-tn))
-        (storew (make-fixup nil :code-object return)
-                rbp-tn (- (1+ (tn-offset ret-tn)))))
+        (inst lea return-label (make-fixup nil :code-object return))
+        (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
         ((sap-reg)
          (inst lea ret-tn (make-fixup nil :code-object return)))))
  
         ((sap-reg)
          (inst lea ret-tn (make-fixup nil :code-object return)))))
  
@@ -482,6 +487,7 @@
    (:args (fp)
          (nfp)
          (args :more t))
    (:args (fp)
          (nfp)
          (args :more t))
+  (:temporary (:sc unsigned-reg) return-label)
    (:save-p t)
    (:move-args :local-call)
    (:info save callee target)
    (:save-p t)
    (:move-args :local-call)
    (:info save callee target)
@@ -503,8 +509,8 @@
          #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
                        (tn-offset ret-tn))
          ;; 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)))))
+        (inst lea return-label (make-fixup nil :code-object return))
+        (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
@@ -528,6 +534,7 @@
    (:args (fp)
          (nfp)
          (args :more t))
    (:args (fp)
          (nfp)
          (args :more t))
+  (:temporary (:sc unsigned-reg) return-label)
    (:results (res :more t))
    (:move-args :local-call)
    (:save-p t)
    (:results (res :more t))
    (:move-args :local-call)
    (:save-p t)
@@ -551,8 +558,8 @@
          #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
                        (tn-offset ret-tn))
          ;; Stack
          #+nil (format t "*known-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)))))
+        (inst lea return-label (make-fixup nil :code-object return))
+        (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
         ((sap-reg)
          ;; Register
          (inst lea ret-tn (make-fixup nil :code-object return)))))
@@ -894,6 +901,7 @@
          (ret-addr))
    (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
    (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
          (ret-addr))
    (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
    (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
+  (:temporary (:sc unsigned-reg) call-target)
  ;  (:ignore ret-addr old-fp)
    (:generator 75
      ;; Move these into the passing locations if they are not already there.
  ;  (:ignore ret-addr old-fp)
    (:generator 75
      ;; Move these into the passing locations if they are not already there.
@@ -910,8 +918,11 @@
             (error "tail-call-variable: ret-addr not on stack in standard save location?"))
  
  
             (error "tail-call-variable: ret-addr not on stack in standard save location?"))
  
  
+    (inst lea call-target
+         (make-ea :qword
+                  :disp (make-fixup 'tail-call-variable :assembly-routine)))
      ;; And jump to the assembly routine.
      ;; And jump to the assembly routine.
-    (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))
+    (inst jmp call-target)))
  \f
  ;;;; unknown values return
  
  \f
  ;;;; unknown values return
  
@@ -1031,6 +1042,7 @@
    (: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 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 unsigned-reg) return-asm)
    (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
                    :from (:eval 0)) a0)
    (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
    (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
                    :from (:eval 0)) a0)
    (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
@@ -1064,7 +1076,10 @@
      (move rcx nvals)
      (move rbx rbp-tn)
      (move rbp-tn old-fp)
      (move rcx nvals)
      (move rbx rbp-tn)
      (move rbp-tn old-fp)
-    (inst jmp (make-fixup 'return-multiple :assembly-routine))
+    (inst lea return-asm
+         (make-ea :qword :disp (make-fixup 'return-multiple
+                                           :assembly-routine)))
+    (inst jmp return-asm)
      (trace-table-entry trace-table-normal)))
  \f
  ;;;; XEP hackery
      (trace-table-entry trace-table-normal)))
  \f
  ;;;; XEP hackery
@@ -1262,7 +1277,7 @@
         (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag))
         ;; Convert the count into a raw value, so that we can use the
         ;; LOOP instruction.
         (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag))
         ;; Convert the count into a raw value, so that we can use the
         ;; LOOP instruction.
-       (inst shr rcx (1- n-word-bytes))
+       (inst shr rcx (1- n-lowtag-bits))
         ;; Set decrement mode (successive args at lower addresses)
         (inst std)
         ;; Set up the result.
         ;; Set decrement mode (successive args at lower addresses)
         (inst std)
         ;; Set up the result.
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp

index a6290c8..87c5e9c 100644 (file)
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -24,31 +24,28 @@
  (define-vop (set-slot)
    (:args (object :scs (descriptor-reg))
          (value :scs (descriptor-reg any-reg immediate)))
  (define-vop (set-slot)
    (:args (object :scs (descriptor-reg))
          (value :scs (descriptor-reg any-reg immediate)))
+  (:temporary (:sc descriptor-reg) temp)
    (:info name offset lowtag)
    (:ignore name)
    (:results)
    (:generator 1
    (:info name offset lowtag)
    (:ignore name)
    (:results)
    (:generator 1
-     (if (sc-is value immediate)
+    (if (sc-is value immediate)
         (let ((val (tn-value value)))
         (let ((val (tn-value value)))
-          (etypecase val
-             (integer
-              (inst mov
-                    (make-ea :dword :base object
-                             :disp (- (* offset n-word-bytes) lowtag))
-                    (fixnumize val)))
-             (symbol
-              (inst mov
-                    (make-ea :dword :base object
-                             :disp (- (* offset n-word-bytes) lowtag))
-                    (+ nil-value (static-symbol-offset val))))
-             (character
-              (inst mov
-                    (make-ea :dword :base object
-                             :disp (- (* offset n-word-bytes) lowtag))
-                    (logior (ash (char-code val) n-widetag-bits)
-                            base-char-widetag)))))
-       ;; Else, value not immediate.
-       (storew value object offset lowtag))))
+         (move-immediate (make-ea :qword
+                                  :base object
+                                  :disp (- (* offset n-word-bytes)
+                                           lowtag))
+                         (etypecase val
+                           (integer
+                            (fixnumize val))
+                           (symbol
+                            (+ nil-value (static-symbol-offset val)))
+                           (character
+                            (logior (ash (char-code val) n-widetag-bits)
+                                    character-widetag)))
+                         temp))
+       ;; Else, value not immediate.
+       (storew value object offset lowtag))))
  \f
  
  
  \f
  
  
diff --git a/src/compiler/x86-64/char.lisp b/src/compiler/x86-64/char.lisp

index 684a88a..bbd1fa4 100644 (file)
--- a/src/compiler/x86-64/char.lisp
+++ b/src/compiler/x86-64/char.lisp
@@ -14,89 +14,130 @@
  ;;;; moves and coercions
  
  ;;; Move a tagged char to an untagged representation.
  ;;;; 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)))
+#!+sb-unicode
+(define-vop (move-to-character)
+  (:args (x :scs (any-reg descriptor-reg) :target y
+           :load-if (not (location= x y))))
+  (:results (y :scs (character-reg)
+              :load-if (not (location= x y))))
+  (:note "character untagging")
+  (:generator 1
+    (move y x)
+    (inst shr y n-widetag-bits)))
+#!-sb-unicode
+(define-vop (move-to-character)
+  (:args (x :scs (any-reg control-stack)))
+  (:results (y :scs (character-reg #+nil character-stack)))
    (:note "character untagging")
    (:generator 1
    (: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))
+    (let ((y-wide-tn (make-random-tn
+                     :kind :normal
+                     :sc (sc-or-lose 'any-reg)
+                     :offset (tn-offset y))))
+      (move y-wide-tn x)
+      (inst shr y-wide-tn 8)
+      (inst and y-wide-tn #xff))))
+(define-move-vop move-to-character :move
+  (any-reg #!-sb-unicode control-stack) 
+  (character-reg))
  
  ;;; Move an untagged char to a tagged representation.
  
  ;;; 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)))
+#!+sb-unicode
+(define-vop (move-from-character)
+  (:args (x :scs (character-reg)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "character tagging")
+  (:generator 1
+    (inst imul y x (ash 1 n-widetag-bits))
+    (inst or y character-widetag)))
+#!-sb-unicode
+(define-vop (move-from-character)
+  (:args (x :scs (character-reg character-stack)))
+  (:results (y :scs (any-reg descriptor-reg #+nil control-stack)))
    (:note "character tagging")
    (:generator 1
    (:note "character tagging")
    (:generator 1
-    (move ah x)                                ; Maybe move char byte.
-    (inst mov al base-char-widetag)    ; 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)
+    (move (make-random-tn :kind :normal :sc (sc-or-lose 'character-reg)
+                         :offset (tn-offset y))
+         x)
+    (inst shl y n-widetag-bits)
+    (inst or y character-widetag)
+    (inst and y #xffff)))
+(define-move-vop move-from-character :move
+  (character-reg) 
+  (any-reg descriptor-reg #!-sb-unicode control-stack))
+
+;;; Move untagged character values.
+(define-vop (character-move)
    (:args (x :target y
    (:args (x :target y
-           :scs (base-char-reg)
+           :scs (character-reg)
             :load-if (not (location= x y))))
             :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg base-char-stack)
+  (:results (y :scs (character-reg character-stack)
                :load-if (not (location= x y))))
    (:note "character move")
    (:effects)
    (:affected)
    (:generator 0
      (move y x)))
                :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))
+(define-move-vop character-move :move
+  (character-reg) (character-reg character-stack))
  
  
-;;; Move untagged base-char arguments/return-values.
-(define-vop (move-base-char-arg)
+;;; Move untagged character arguments/return-values.
+(define-vop (move-character-arg)
    (:args (x :target y
    (:args (x :target y
-           :scs (base-char-reg))
+           :scs (character-reg))
          (fp :scs (any-reg)
          (fp :scs (any-reg)
-            :load-if (not (sc-is y base-char-reg))))
+            :load-if (not (sc-is y character-reg))))
    (:results (y))
    (:note "character arg move")
    (:generator 0
      (sc-case y
    (:results (y))
    (:note "character arg move")
    (:generator 0
      (sc-case y
-      (base-char-reg
+      (character-reg
         (move y x))
         (move y x))
-      (base-char-stack
+      (character-stack
+       #!-sb-unicode
         (inst mov
         (inst mov
-            (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
-            x)))))
-(define-move-vop move-base-char-arg :move-arg
-  (any-reg base-char-reg) (base-char-reg))
-
-;;; Use standard MOVE-ARG + coercion to move an untagged base-char
+            ;; FIXME: naked 8 (should be... what?  n-register-bytes?
+            ;; n-word-bytes?  Dunno.
+            (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 8)))
+            x)
+       #!+sb-unicode
+       (if (= (tn-offset fp) esp-offset)
+          (storew x fp (tn-offset y)) ; c-call
+          (storew x fp (- (1+ (tn-offset y)))))))))
+(define-move-vop move-character-arg :move-arg
+  (any-reg character-reg) (character-reg))
+
+;;; Use standard MOVE-ARG + coercion to move an untagged character
  ;;; to a descriptor passing location.
  (define-move-vop move-arg :move-arg
  ;;; to a descriptor passing location.
  (define-move-vop move-arg :move-arg
-  (base-char-reg) (any-reg descriptor-reg))
+  (character-reg) (any-reg descriptor-reg))
  \f
  ;;;; other operations
  
  (define-vop (char-code)
    (:translate char-code)
    (:policy :fast-safe)
  \f
  ;;;; 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)
+  (:args (ch :scs (character-reg character-stack)))
+  (:arg-types character)
    (:results (res :scs (unsigned-reg)))
    (:result-types positive-fixnum)
    (:generator 1
    (:results (res :scs (unsigned-reg)))
    (:result-types positive-fixnum)
    (:generator 1
-    (inst movzx res ch)))
+    #!-sb-unicode
+    (inst movzx res ch)
+    #!+sb-unicode
+    (inst mov res ch)))
  
  
+#!+sb-unicode
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (unsigned-reg unsigned-stack)))
+  (:arg-types positive-fixnum)
+  (:results (res :scs (character-reg)))
+  (:result-types character)
+  (:generator 1
+    (inst mov res code)))
+#!-sb-unicode
  (define-vop (code-char)
    (:translate code-char)
    (:policy :fast-safe)
  (define-vop (code-char)
    (:translate code-char)
    (:policy :fast-safe)
@@ -105,19 +146,19 @@
    (:temporary (:sc unsigned-reg :offset rax-offset :target res
                    :from (:argument 0) :to (:result 0))
               eax)
    (:temporary (:sc unsigned-reg :offset rax-offset :target res
                    :from (:argument 0) :to (:result 0))
               eax)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
+  (:results (res :scs (character-reg)))
+  (:result-types character)
    (:generator 1
      (move eax code)
      (move res al-tn)))
  \f
    (:generator 1
      (move eax code)
      (move res al-tn)))
  \f
-;;; 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)
+;;; comparison of CHARACTERs
+(define-vop (character-compare)
+  (:args (x :scs (character-reg character-stack))
+        (y :scs (character-reg)
+           :load-if (not (and (sc-is x character-reg)
+                              (sc-is y character-stack)))))
+  (:arg-types character character)
    (:conditional)
    (:info target not-p)
    (:policy :fast-safe)
    (:conditional)
    (:info target not-p)
    (:policy :fast-safe)
@@ -127,21 +168,21 @@
      (inst cmp x y)
      (inst jmp (if not-p not-condition condition) target)))
  
      (inst cmp x y)
      (inst jmp (if not-p not-condition condition) target)))
  
-(define-vop (fast-char=/base-char base-char-compare)
+(define-vop (fast-char=/character character-compare)
    (:translate char=)
    (:variant :e :ne))
  
    (:translate char=)
    (:variant :e :ne))
  
-(define-vop (fast-char</base-char base-char-compare)
+(define-vop (fast-char</character character-compare)
    (:translate char<)
    (:variant :b :nb))
  
    (:translate char<)
    (:variant :b :nb))
  
-(define-vop (fast-char>/base-char base-char-compare)
+(define-vop (fast-char>/character character-compare)
    (:translate char>)
    (:variant :a :na))
  
    (:translate char>)
    (:variant :a :na))
  
-(define-vop (base-char-compare/c)
-  (:args (x :scs (base-char-reg base-char-stack)))
-  (:arg-types base-char (:constant base-char))
+(define-vop (character-compare/c)
+  (:args (x :scs (character-reg character-stack)))
+  (:arg-types character (:constant character))
    (:conditional)
    (:info target not-p y)
    (:policy :fast-safe)
    (:conditional)
    (:info target not-p y)
    (:policy :fast-safe)
@@ -151,14 +192,14 @@
      (inst cmp x (sb!xc:char-code y))
      (inst jmp (if not-p not-condition condition) target)))
  
      (inst cmp x (sb!xc:char-code y))
      (inst jmp (if not-p not-condition condition) target)))
  
-(define-vop (fast-char=/base-char/c base-char-compare/c)
+(define-vop (fast-char=/character/c character-compare/c)
    (:translate char=)
    (:variant :e :ne))
  
    (:translate char=)
    (:variant :e :ne))
  
-(define-vop (fast-char</base-char/c base-char-compare/c)
+(define-vop (fast-char</character/c character-compare/c)
    (:translate char<)
    (:variant :b :nb))
  
    (:translate char<)
    (:variant :b :nb))
  
-(define-vop (fast-char>/base-char/c base-char-compare/c)
+(define-vop (fast-char>/character/c character-compare/c)
    (:translate char>)
    (:variant :a :na))
    (:translate char>)
    (:variant :a :na))
diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp

index 2b3f28c..9c018cf 100644 (file)
--- a/src/compiler/x86-64/float.lisp
+++ b/src/compiler/x86-64/float.lisp
@@ -31,6 +31,7 @@
      (ea-for-xf-desc tn complex-double-float-imag-slot)))
  
  (macrolet ((ea-for-xf-stack (tn kind)
      (ea-for-xf-desc tn complex-double-float-imag-slot)))
  
  (macrolet ((ea-for-xf-stack (tn kind)
+            (declare (ignore kind))
              `(make-ea
                :qword :base rbp-tn
                :disp (- (* (+ (tn-offset ,tn) 1)
              `(make-ea
                :qword :base rbp-tn
                :disp (- (* (+ (tn-offset ,tn) 1)
@@ -77,66 +78,29 @@
  ;;;; move functions
  
  ;;; X is source, Y is destination.
  ;;;; move functions
  
  ;;; X is source, Y is destination.
+
+(define-move-fun (load-fp-zero 1) (vop x y)
+  ((fp-single-zero) (single-reg)
+   (fp-double-zero) (double-reg))
+  (identity x) ; KLUDGE: IDENTITY as IGNORABLE...
+  (inst movq y fp-double-zero-tn))
+
  (define-move-fun (load-single 2) (vop x y)
    ((single-stack) (single-reg))
    (inst movss y (ea-for-sf-stack x)))
  
  (define-move-fun (load-single 2) (vop x y)
    ((single-stack) (single-reg))
    (inst movss y (ea-for-sf-stack x)))
  
-;;; got this far 20040627
-
  (define-move-fun (store-single 2) (vop x y)
    ((single-reg) (single-stack))
  (define-move-fun (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))))
+  (inst movss (ea-for-sf-stack y) x))
  
  (define-move-fun (load-double 2) (vop x y)
    ((double-stack) (double-reg))
  
  (define-move-fun (load-double 2) (vop x y)
    ((double-stack) (double-reg))
-  (with-empty-tn@fp-top(y)
-     (inst fldd (ea-for-df-stack x))))
+  (inst movsd y (ea-for-df-stack x)))
  
  (define-move-fun (store-double 2) (vop x y)
    ((double-reg) (double-stack))
  
  (define-move-fun (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))))
-
-
-
-;;; 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.
-(eval-when (:compile-toplevel :execute)
-  (setf *read-default-float-format* 'double-float))
-(define-move-fun (load-fp-constant 2) (vop x y)
-  ((fp-constant) (single-reg double-reg))
-  (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
-    (with-empty-tn@fp-top(y)
-      (cond ((zerop value)
-            (inst fldz))
-           ((= value 1e0)
-            (inst fld1))
-           ((= value (coerce pi *read-default-float-format*))
-            (inst fldpi))
-           ((= value (log 10e0 2e0))
-            (inst fldl2t))
-           ((= value (log 2.718281828459045235360287471352662e0 2e0))
-            (inst fldl2e))
-           ((= value (log 2e0 10e0))
-            (inst fldlg2))
-           ((= value (log 2e0 2.718281828459045235360287471352662e0))
-            (inst fldln2))
-           (t (warn "ignoring bogus i387 constant ~A" value))))))
+  (inst movsd  (ea-for-df-stack y) x))
+
  (eval-when (:compile-toplevel :execute)
    (setf *read-default-float-format* 'single-float))
  \f
  (eval-when (:compile-toplevel :execute)
    (setf *read-default-float-format* 'single-float))
  \f
@@ -160,77 +124,50 @@
  (define-move-fun (load-complex-single 2) (vop x y)
    ((complex-single-stack) (complex-single-reg))
    (let ((real-tn (complex-single-reg-real-tn y)))
  (define-move-fun (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))))
+    (inst movss real-tn (ea-for-csf-real-stack x)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
-    (with-empty-tn@fp-top (imag-tn)
-      (inst fld (ea-for-csf-imag-stack x)))))
+    (inst movss imag-tn (ea-for-csf-imag-stack x))))
  
  (define-move-fun (store-complex-single 2) (vop x y)
    ((complex-single-reg) (complex-single-stack))
  
  (define-move-fun (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)))
+  (let ((real-tn (complex-single-reg-real-tn x))
+       (imag-tn (complex-single-reg-imag-tn x)))
+    (inst movss (ea-for-csf-real-stack y) real-tn)
+    (inst movss (ea-for-csf-imag-stack y) imag-tn)))
  
  (define-move-fun (load-complex-double 2) (vop x y)
    ((complex-double-stack) (complex-double-reg))
    (let ((real-tn (complex-double-reg-real-tn y)))
  
  (define-move-fun (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))))
+    (inst movsd real-tn (ea-for-cdf-real-stack x)))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
-    (with-empty-tn@fp-top(imag-tn)
-      (inst fldd (ea-for-cdf-imag-stack x)))))
+    (inst movsd imag-tn (ea-for-cdf-imag-stack x))))
  
  (define-move-fun (store-complex-double 2) (vop x y)
    ((complex-double-reg) (complex-double-stack))
  
  (define-move-fun (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)))
+  (let ((real-tn (complex-double-reg-real-tn x))
+       (imag-tn (complex-double-reg-imag-tn x)))
+    (inst movsd (ea-for-cdf-real-stack y) real-tn)
+    (inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
  
  \f
  ;;;; move VOPs
  
  ;;; float register to register moves
  
  \f
  ;;;; 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))
+(macrolet ((frob (vop sc)
+            `(progn
+               (define-vop (,vop)
+                 (:args (x :scs (,sc)
+                           :target y
+                           :load-if (not (location= x y))))
+                 (:results (y :scs (,sc)
+                              :load-if (not (location= x y))))
+                 (:note "float move")
+                 (:generator 0
+                   (unless (location= y x)
+                     (inst movq y x))))
+               (define-move-vop ,vop :move (,sc) (,sc)))))
+  (frob single-move single-reg)
+  (frob double-move double-reg))
  
  ;;; complex float register to register moves
  (define-vop (complex-float-move)
  
  ;;; complex float register to register moves
  (define-vop (complex-float-move)
@@ -241,21 +178,14 @@
       (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.
       (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)))))
+       ;; (It would be better to put the imagpart in the top half of the 
+       ;; register, or something, but let's worry about that later)
+       (let ((x-real (complex-single-reg-real-tn x))
+            (y-real (complex-single-reg-real-tn y)))
+        (inst movq y-real x-real))
+       (let ((x-imag (complex-single-reg-imag-tn x))
+            (y-imag (complex-single-reg-imag-tn y)))
+        (inst movq y-imag x-imag)))))
  
  (define-vop (complex-single-move complex-float-move)
    (:args (x :scs (complex-single-reg) :target y
  
  (define-vop (complex-single-move complex-float-move)
    (:args (x :scs (complex-single-reg) :target y
@@ -283,8 +213,7 @@
       (with-fixed-allocation (y
                              single-float-widetag
                              single-float-size node)
       (with-fixed-allocation (y
                              single-float-widetag
                              single-float-size node)
-       (with-tn@fp-top(x)
-        (inst fst (ea-for-sf-desc y))))))
+       (inst movss (ea-for-sf-desc y) x))))
  (define-move-vop move-from-single :move
    (single-reg) (descriptor-reg))
  
  (define-move-vop move-from-single :move
    (single-reg) (descriptor-reg))
  
@@ -298,11 +227,11 @@
                              double-float-widetag
                              double-float-size
                              node)
                              double-float-widetag
                              double-float-size
                              node)
-       (with-tn@fp-top(x)
-        (inst fstd (ea-for-df-desc y))))))
+       (inst movsd (ea-for-df-desc y) x))))
  (define-move-vop move-from-double :move
    (double-reg) (descriptor-reg))
  
  (define-move-vop move-from-double :move
    (double-reg) (descriptor-reg))
  
+#+nil
  (define-vop (move-from-fp-constant)
    (:args (x :scs (fp-constant)))
    (:results (y :scs (descriptor-reg)))
  (define-vop (move-from-fp-constant)
    (:args (x :scs (fp-constant)))
    (:results (y :scs (descriptor-reg)))
@@ -312,6 +241,7 @@
         (1f0 (load-symbol-value y *fp-constant-1f0*))
         (0d0 (load-symbol-value y *fp-constant-0d0*))
         (1d0 (load-symbol-value y *fp-constant-1d0*)))))
         (1f0 (load-symbol-value y *fp-constant-1f0*))
         (0d0 (load-symbol-value y *fp-constant-0d0*))
         (1d0 (load-symbol-value y *fp-constant-1d0*)))))
+#+nil
  (define-move-vop move-from-fp-constant :move
    (fp-constant) (descriptor-reg))
  
  (define-move-vop move-from-fp-constant :move
    (fp-constant) (descriptor-reg))
  
@@ -321,8 +251,7 @@
    (:results (y :scs (single-reg)))
    (:note "pointer to float coercion")
    (:generator 2
    (: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)))))
+    (inst movss y (ea-for-sf-desc x))))
  (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
  
  (define-vop (move-to-double)
  (define-move-vop move-to-single :move (descriptor-reg) (single-reg))
  
  (define-vop (move-to-double)
@@ -330,8 +259,7 @@
    (:results (y :scs (double-reg)))
    (:note "pointer to float coercion")
    (:generator 2
    (: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)))))
+    (inst movsd y (ea-for-df-desc x))))
  (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
  
  \f
  (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
  
  \f
@@ -348,11 +276,9 @@
                              complex-single-float-size
                              node)
         (let ((real-tn (complex-single-reg-real-tn x)))
                              complex-single-float-size
                              node)
         (let ((real-tn (complex-single-reg-real-tn x)))
-        (with-tn@fp-top(real-tn)
-          (inst fst (ea-for-csf-real-desc y))))
+        (inst movss (ea-for-csf-real-desc y) real-tn))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
-        (with-tn@fp-top(imag-tn)
-          (inst fst (ea-for-csf-imag-desc y)))))))
+        (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
  (define-move-vop move-from-complex-single :move
    (complex-single-reg) (descriptor-reg))
  
  (define-move-vop move-from-complex-single :move
    (complex-single-reg) (descriptor-reg))
  
@@ -367,11 +293,9 @@
                              complex-double-float-size
                              node)
         (let ((real-tn (complex-double-reg-real-tn x)))
                              complex-double-float-size
                              node)
         (let ((real-tn (complex-double-reg-real-tn x)))
-        (with-tn@fp-top(real-tn)
-          (inst fstd (ea-for-cdf-real-desc y))))
+        (inst movsd (ea-for-cdf-real-desc y) real-tn))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
-        (with-tn@fp-top(imag-tn)
-          (inst fstd (ea-for-cdf-imag-desc y)))))))
+        (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
  (define-move-vop move-from-complex-double :move
    (complex-double-reg) (descriptor-reg))
  
  (define-move-vop move-from-complex-double :move
    (complex-double-reg) (descriptor-reg))
  
@@ -384,18 +308,22 @@
                   (:note "pointer to complex float coercion")
                   (:generator 2
                     (let ((real-tn (complex-double-reg-real-tn y)))
                   (: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)))))))
+                     ,@(ecase
+                        format
+                        (:single
+                         '((inst movss real-tn (ea-for-csf-real-desc x))))
+                        (:double
+                         '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
                     (let ((imag-tn (complex-double-reg-imag-tn y)))
                     (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)))))))))
+                     ,@(ecase
+                        format
+                        (:single
+                         '((inst movss imag-tn (ea-for-csf-imag-desc x))))
+                        (:double 
+                         '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
                 (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))
+  (frob move-to-complex-single complex-single-reg :single)
+  (frob move-to-complex-double complex-double-reg :double))
  \f
  ;;;; the move argument vops
  ;;;;
  \f
  ;;;; the move argument vops
  ;;;;
@@ -411,38 +339,29 @@
                              :load-if (not (sc-is y ,sc))))
                   (:results (y))
                   (:note "float argument move")
                              :load-if (not (sc-is y ,sc))))
                   (:results (y))
                   (:note "float argument move")
-                 (:generator ,(case format (:single 2) (:double 3) (:long 4))
+                 (:generator ,(case format (:single 2) (:double 3) )
                     (sc-case y
                       (,sc
                        (unless (location= x y)
                     (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)))))
+                        (inst movq y x)))
                       (,stack-sc
                        (if (= (tn-offset fp) esp-offset)
                            (let* ((offset (* (tn-offset y) n-word-bytes))
                                   (ea (make-ea :dword :base fp :disp offset)))
                       (,stack-sc
                        (if (= (tn-offset fp) esp-offset)
                            (let* ((offset (* (tn-offset y) n-word-bytes))
                                   (ea (make-ea :dword :base fp :disp offset)))
-                            (with-tn@fp-top(x)
-                               ,@(ecase format
-                                        (:single '((inst fst ea)))
-                                        (:double '((inst fstd ea))))))
+                            ,@(ecase format
+                                     (:single '((inst movss ea x)))
+                                     (:double '((inst movsd ea x)))))
                            (let ((ea (make-ea
                                       :dword :base fp
                                       :disp (- (* (+ (tn-offset y)
                                                      ,(case format
                                                             (:single 1)
                            (let ((ea (make-ea
                                       :dword :base fp
                                       :disp (- (* (+ (tn-offset y)
                                                      ,(case format
                                                             (:single 1)
-                                                           (:double 2)
-                                                           (:long 3)))
+                                                           (:double 2) ))
                                                   n-word-bytes)))))
                              (with-tn@fp-top(x)
                                ,@(ecase format
                                                   n-word-bytes)))))
                              (with-tn@fp-top(x)
                                ,@(ecase format
-                                   (:single '((inst fst  ea)))
-                                   (:double '((inst fstd ea)))))))))))
+                                   (:single '((inst movss ea x)))
+                                   (:double '((inst movsd ea x)))))))))))
                 (define-move-vop ,name :move-arg
                   (,sc descriptor-reg) (,sc)))))
    (frob move-single-float-arg single-reg single-stack :single)
                 (define-move-vop ,name :move-arg
                   (,sc descriptor-reg) (,sc)))))
    (frob move-single-float-arg single-reg single-stack :single)
@@ -457,53 +376,35 @@
                              :load-if (not (sc-is y ,sc))))
                   (:results (y))
                   (:note "complex float argument move")
                              :load-if (not (sc-is y ,sc))))
                   (:results (y))
                   (:note "complex float argument move")
-                 (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
+                 (:generator ,(ecase format (:single 2) (:double 3))
                     (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)))
                     (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))))
+                          (inst movsd y-real x-real))
                          (let ((x-imag (complex-double-reg-imag-tn x))
                                (y-imag (complex-double-reg-imag-tn y)))
                          (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))))
+                          (inst movsd y-imag x-imag))))
                       (,stack-sc
                        (let ((real-tn (complex-double-reg-real-tn x)))
                       (,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))))))
-                              (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)))))
-                               (inst fxch real-tn))))
+                        ,@(ecase format
+                                 (:single
+                                  '((inst movss
+                                     (ea-for-csf-real-stack y fp)
+                                     real-tn)))
+                                 (:double
+                                  '((inst movsd
+                                     (ea-for-cdf-real-stack y fp)
+                                     real-tn)))))
                        (let ((imag-tn (complex-double-reg-imag-tn x)))
                        (let ((imag-tn (complex-double-reg-imag-tn x)))
-                        (inst fxch imag-tn)
                          ,@(ecase format
                          ,@(ecase format
-                            (:single
-                             '((inst fst (ea-for-csf-imag-stack y fp))))
-                            (:double
-                             '((inst fstd (ea-for-cdf-imag-stack y fp)))))
-                        (inst fxch imag-tn))))))
+                                 (:single
+                                  '((inst movss
+                                     (ea-for-csf-imag-stack y fp) imag-tn)))
+                                 (:double
+                                  '((inst movsd
+                                     (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
                 (define-move-vop ,name :move-arg
                   (,sc descriptor-reg) (,sc)))))
    (frob move-complex-single-float-arg
                 (define-move-vop ,name :move-arg
                   (,sc descriptor-reg) (,sc)))))
    (frob move-complex-single-float-arg
@@ -519,690 +420,183 @@
  \f
  ;;;; arithmetic VOPs
  
  \f
  ;;;; 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)
-       #!-long-float (declare (ignore lcost lname))
-       `(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)
-                         (inst fstp fr0)
-                         (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)))
-              (maybe-fp-wait node vop))
-             ;; 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)
-                        (inst fstp fr0)
-                        (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)))
-              (maybe-fp-wait node vop))
-             ;; 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
-                   (inst fstp fr0)
-                   (inst fld (ea-for-sf-stack x)))
-                  (descriptor-reg
-                   (inst fstp fr0)
-                   (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))
-                        (maybe-fp-wait node))
-                       (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)
-                         (inst fstp fr0)
-                         (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)))
-              (maybe-fp-wait node vop))
-             ;; 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)
-                         (inst fstp fr0)
-                         (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)))
-              (maybe-fp-wait node vop))
-             ;; 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
-                   (inst fstp fr0)
-                   (inst fldd (ea-for-df-stack x)))
-                  (descriptor-reg
-                   (inst fstp fr0)
-                   (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))
-                        (maybe-fp-wait node))
-                       (t
-                        (inst fst r))))
-                (double-stack
-                 (inst fstd (ea-for-df-stack 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))
+(define-vop (float-op)
+  (:args (x) (y))
+  (:results (r))
+  (:policy :fast-safe)
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(macrolet ((frob (name sc ptype)
+            `(define-vop (,name float-op)
+               (:args (x :scs (,sc))
+                      (y :scs (,sc)))
+               (:results (r :scs (,sc)))
+               (:arg-types ,ptype ,ptype)
+               (:result-types ,ptype))))
+  (frob single-float-op single-reg single-float)
+  (frob double-float-op double-reg double-float))
+
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+            `(progn
+               (define-vop (,sname single-float-op)
+                   (:translate ,op)
+                 (:results (r :scs (single-reg)))
+                 (:temporary (:sc single-reg) tmp)
+                 (:generator ,scost
+                    (inst movss tmp x)
+                   (inst ,sinst tmp y)
+                   (inst movss r tmp)))
+               (define-vop (,dname double-float-op)
+                 (:translate ,op)
+                 (:results (r :scs (double-reg)))
+                 (:temporary (:sc single-reg) tmp)
+                 (:generator ,dcost
+                    (inst movsd tmp x)
+                   (inst ,dinst tmp y)
+                   (inst movsd r tmp))))))
+  (frob + addss +/single-float 2 addsd +/double-float 2)
+  (frob - subss -/single-float 2 subsd -/double-float 2)
+  (frob * mulss */single-float 4 mulsd */double-float 5)
+  (frob / divss //single-float 12 divsd //double-float 19))
+
+
  \f
  \f
-(macrolet ((frob (name inst translate sc type)
+(macrolet ((frob ((name translate sc type) &body body)
              `(define-vop (,name)
              `(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)
-
-  (frob %negate/single-float fchs %negate single-reg single-float)
-  (frob %negate/double-float fchs %negate double-reg double-float))
+                 (:args (x :scs (,sc)))
+               (:results (y :scs (,sc)))
+               (:translate ,translate)
+               (:policy :fast-safe)
+               (:arg-types ,type)
+               (:result-types ,type)
+               (:temporary (:sc any-reg) hex8)
+               (:temporary
+                (:sc ,sc) xmm)
+               (:note "inline float arithmetic")
+               (:vop-var vop)
+               (:save-p :compute-only)
+               (:generator 1
+                           (note-this-location vop :internal-error)
+                           ;; we should be able to do this better.  what we 
+                           ;; really would like to do is use the target as the
+                           ;; temp whenever it's not also the source
+                           (unless (location= x y)
+                             (inst movq y x))
+                           ,@body))))
+  (frob (%negate/double-float %negate double-reg double-float)
+       (inst lea hex8 (make-ea :qword :disp 1))
+       (inst ror hex8 1)               ; #x8000000000000000
+       (inst movd xmm hex8)
+       (inst xorpd y xmm))
+  (frob (%negate/single-float %negate single-reg single-float)
+       (inst lea hex8 (make-ea :qword :disp 1))
+       (inst rol hex8 31)
+       (inst movd xmm hex8)
+       (inst xorps y xmm))
+  (frob (abs/double-float abs  double-reg double-float)
+       (inst mov hex8 -1)
+       (inst shr hex8 1)
+       (inst movd xmm hex8)
+       (inst andpd y xmm))
+  (frob (abs/single-float abs  single-reg single-float)
+       (inst mov hex8 -1)
+       (inst shr hex8 33)
+       (inst movd xmm hex8)
+       (inst andps y xmm)))
  \f
  ;;;; comparison
  
  \f
  ;;;; comparison
  
-(define-vop (=/float)
-  (:args (x) (y))
-  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+(define-vop (float-compare)
    (:conditional)
    (:info target not-p)
    (:policy :fast-safe)
    (:vop-var vop)
    (:save-p :compute-only)
    (: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))
-      ;; y is in ST0; x is in another reg.
-      ((zerop (tn-offset y))
-       (inst fucom x))
-      ;; x and y are the same register, not ST0
-      ((location= x y)
-       (inst fxch x)
-       (inst fucom fr0-tn)
-       (inst fxch x))
-      ;; x and y are different registers, neither ST0.
-      (t
-       (inst fxch x)
-       (inst fucom y)
-       (inst fxch x)))
-     (inst fnstsw)                     ; status word to ax
-     (inst and ah-tn #x45)             ; C3 C2 C0
-     (inst cmp ah-tn #x40)
-     (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (=/single-float =/float)
-  (:translate =)
-  (:args (x :scs (single-reg))
-        (y :scs (single-reg)))
-  (:arg-types single-float single-float))
+  (:note "inline float comparison"))
  
  
-(define-vop (=/double-float =/float)
-  (:translate =)
-  (:args (x :scs (double-reg))
-        (y :scs (double-reg)))
-  (:arg-types double-float double-float))
+;;; comiss and comisd can cope with one or other arg in memory: we
+;;; could (should, indeed) extend these to cope with descriptor args
+;;; and stack args
  
  
-(define-vop (<single-float)
-  (: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 eax-offset :from :eval) temp)
+(define-vop (single-float-compare float-compare)
+  (:args (x :scs (single-reg)) (y :scs (single-reg)))
    (:conditional)
    (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:ignore temp)
-  (:generator 3
-    ;; Handle a few special cases.
-    (cond
-     ;; 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))
-
-     ;; general case when y is not in ST0
-     (t
-      ;; x to ST0
-      (sc-case x
-        (single-reg
-         (unless (zerop (tn-offset x))
-                 (copy-fp-reg-to-fr0 x)))
-        ((single-stack descriptor-reg)
-         (inst fstp fr0)
-         (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
-      (inst cmp ah-tn #x01)))
-    (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (<double-float)
-  (: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 eax-offset :from :eval) temp)
+  (:arg-types single-float single-float))
+(define-vop (double-float-compare float-compare)
+  (:args (x :scs (double-reg)) (y :scs (double-reg)))
    (:conditional)
    (:conditional)
+  (:arg-types double-float double-float))
+
+(define-vop (=/single-float single-float-compare)
+    (:translate =)
    (:info target not-p)
    (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:ignore temp)
+  (:vop-var vop)
    (:generator 3
    (:generator 3
-    ;; Handle a few special cases
-    (cond
-     ;; y is 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))
-
-     ;; General case when y is not in ST0.
-     (t
-      ;; x to ST0
-      (sc-case x
-        (double-reg
-         (unless (zerop (tn-offset x))
-                 (copy-fp-reg-to-fr0 x)))
-        ((double-stack descriptor-reg)
-         (inst fstp fr0)
-         (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
-      (inst cmp ah-tn #x01)))
-    (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (>single-float)
-  (: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 eax-offset :from :eval) temp)
-  (:conditional)
+    (note-this-location vop :internal-error)
+    (inst comiss x y)
+    ;; if PF&CF, there was a NaN involved => not equal
+    ;; otherwise, ZF => equal
+    (cond (not-p
+          (inst jmp :p target)
+          (inst jmp :ne target))
+         (t
+          (let ((not-lab (gen-label)))
+            (inst jmp :p not-lab)
+            (inst jmp :e target)
+            (emit-label not-lab))))))
+
+(define-vop (=/double-float double-float-compare)
+    (:translate =)
    (:info target not-p)
    (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:ignore temp)
+  (:vop-var vop)
    (:generator 3
    (:generator 3
-    ;; Handle a few special cases.
-    (cond
-     ;; 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)
-      (inst cmp ah-tn #x01))
-
-     ;; general case when y is not in ST0
-     (t
-      ;; x to ST0
-      (sc-case x
-        (single-reg
-         (unless (zerop (tn-offset x))
-                 (copy-fp-reg-to-fr0 x)))
-        ((single-stack descriptor-reg)
-         (inst fstp fr0)
-         (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)))
-    (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (>double-float)
-  (: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 eax-offset :from :eval) temp)
-  (:conditional)
+    (note-this-location vop :internal-error)
+    (inst comisd x y)
+    (cond (not-p
+          (inst jmp :p target)
+          (inst jmp :ne target))
+         (t
+          (let ((not-lab (gen-label)))
+            (inst jmp :p not-lab)
+            (inst jmp :e target)
+            (emit-label not-lab))))))
+
+;; XXX all of these probably have bad NaN behaviour
+(define-vop (<double-float double-float-compare)
+  (:translate <)
    (:info target not-p)
    (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:ignore temp)
-  (:generator 3
-    ;; Handle a few special cases.
-    (cond
-     ;; y is 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)
-      (inst cmp ah-tn #x01))
-
-     ;; general case when y is not in ST0
-     (t
-      ;; x to ST0
-      (sc-case x
-        (double-reg
-         (unless (zerop (tn-offset x))
-                 (copy-fp-reg-to-fr0 x)))
-        ((double-stack descriptor-reg)
-         (inst fstp fr0)
-         (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)))
-    (inst jmp (if not-p :ne :e) target)))
-
-;;; Comparisons with 0 can use the FTST instruction.
-
-(define-vop (float-test)
-  (:args (x))
-  (:temporary (:sc word-reg :offset eax-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
    (:generator 2
-     (note-this-location vop :internal-error)
-     (cond
-      ;; x is in ST0
-      ((zerop (tn-offset x))
-       (inst ftst))
-      ;; x not ST0
-      (t
-       (inst fxch x)
-       (inst ftst)
-       (inst fxch x)))
-     (inst fnstsw)                     ; status word to ax
-     (inst and ah-tn #x45)             ; C3 C2 C0
-     (unless (zerop code)
-       (inst cmp ah-tn code))
-     (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (=0/single-float float-test)
-  (:translate =)
-  (:args (x :scs (single-reg)))
-  (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  (:variant #x40))
-(define-vop (=0/double-float float-test)
-  (:translate =)
-  (:args (x :scs (double-reg)))
-  (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  (:variant #x40))
-
-(define-vop (<0/single-float float-test)
-  (:translate <)
-  (:args (x :scs (single-reg)))
-  (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  (:variant #x01))
-(define-vop (<0/double-float float-test)
+    (inst comisd x y)
+    (inst jmp (if not-p :nc :c) target)))
+
+(define-vop (<single-float single-float-compare)
    (:translate <)
    (:translate <)
-  (:args (x :scs (double-reg)))
-  (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  (:variant #x01))
+  (:info target not-p)
+  (:generator 2
+    (inst comiss x y)
+    (inst jmp (if not-p :nc :c) target)))
  
  
-(define-vop (>0/single-float float-test)
+(define-vop (>double-float double-float-compare)
    (:translate >)
    (:translate >)
-  (:args (x :scs (single-reg)))
-  (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  (:variant #x00))
-(define-vop (>0/double-float float-test)
+  (:info target not-p)
+  (:generator 2
+    (inst comisd x y)
+    (inst jmp (if not-p :na :a) target)))
+
+(define-vop (>single-float single-float-compare)
    (:translate >)
    (:translate >)
-  (:args (x :scs (double-reg)))
-  (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  (:variant #x00))
+  (:info target not-p)
+  (:generator 2
+    (inst comiss x y)
+    (inst jmp (if not-p :na :a) target)))
+
  
  \f
  ;;;; conversion
  
  
  \f
  ;;;; conversion
  
-(macrolet ((frob (name translate to-sc to-type)
+(macrolet ((frob (name translate inst to-sc to-type)
              `(define-vop (,name)
                 (:args (x :scs (signed-stack signed-reg) :target temp))
                 (:temporary (:sc signed-stack) temp)
              `(define-vop (,name)
                 (:args (x :scs (signed-stack signed-reg) :target temp))
                 (:temporary (:sc signed-stack) temp)
@@ -1218,17 +612,16 @@
                   (sc-case x
                     (signed-reg
                      (inst mov temp x)
                   (sc-case x
                     (signed-reg
                      (inst mov temp x)
-                    (with-empty-tn@fp-top(y)
-                      (note-this-location vop :internal-error)
-                      (inst fild temp)))
+                    (note-this-location vop :internal-error)
+                    (inst ,inst y temp))
                     (signed-stack
                     (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))
+                    (note-this-location vop :internal-error)
+                    (inst ,inst y x)))))))
+  (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
+  (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
  
  
-(macrolet ((frob (name translate to-sc to-type)
+#+nil
+(macrolet ((frob (name translate inst to-sc to-type)
              `(define-vop (,name)
                 (:args (x :scs (unsigned-reg)))
                 (:results (y :scs (,to-sc)))
              `(define-vop (,name)
                 (:args (x :scs (unsigned-reg)))
                 (:results (y :scs (,to-sc)))
@@ -1240,18 +633,11 @@
                 (:vop-var vop)
                 (:save-p :compute-only)
                 (:generator 6
                 (: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 :dword :base rsp-tn)))
-                (inst add rsp-tn 16)))))
-  (frob %single-float/unsigned %single-float single-reg single-float)
-  (frob %double-float/unsigned %double-float double-reg double-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)
+                 (inst ,inst y x)))))
+  (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
+  (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
+
+(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
              `(define-vop (,name)
                (:args (x :scs (,from-sc) :target y))
                (:results (y :scs (,to-sc)))
              `(define-vop (,name)
                (:args (x :scs (,from-sc) :target y))
                (:results (y :scs (,to-sc)))
@@ -1264,34 +650,18 @@
                (:save-p :compute-only)
                (:generator 2
                 (note-this-location vop :internal-error)
                (: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
+               (inst ,inst y x)))))
+  (frob %single-float/double-float %single-float cvtsd2ss double-reg
         double-float single-reg single-float)
  
         double-float single-reg single-float)
  
-  (frob %double-float/single-float %double-float single-reg single-float
-       double-reg double-float))
+  (frob %double-float/single-float %double-float cvtss2sd 
+       single-reg single-float double-reg double-float))
  
  
-(macrolet ((frob (trans from-sc from-type round-p)
+(macrolet ((frob (trans inst from-sc from-type round-p)
+             (declare (ignore round-p))
              `(define-vop (,(symbolicate trans "/" from-type))
                (:args (x :scs (,from-sc)))
              `(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)))
+              (:temporary (:sc any-reg) temp-reg)
                (:results (y :scs (signed-reg)))
                (:arg-types ,from-type)
                (:result-types signed-num)
                (:results (y :scs (signed-reg)))
                (:arg-types ,from-type)
                (:result-types signed-num)
@@ -1301,33 +671,20 @@
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 5
                (: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)
-
-  (frob %unary-round single-reg single-float t)
-  (frob %unary-round double-reg double-float t))
-
+                (sc-case y
+                         (signed-stack
+                          (inst ,inst temp-reg x)
+                          (move y temp-reg))
+                         (signed-reg
+                          (inst ,inst y x)
+                          ))))))
+  (frob %unary-truncate cvttss2si single-reg single-float nil)
+  (frob %unary-truncate cvttsd2si double-reg double-float nil)
+
+  (frob %unary-round cvtss2si single-reg single-float t)
+  (frob %unary-round cvtsd2si double-reg double-float t))
+
+#+nil ;; will we need this?
  (macrolet ((frob (trans from-sc from-type round-p)
              `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
                (:args (x :scs (,from-sc) :target fr0))
  (macrolet ((frob (trans from-sc from-type round-p)
              `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
                (:args (x :scs (,from-sc) :target fr0))
@@ -1379,7 +736,7 @@
                                       (sc-is res single-stack)
                                       (location= bits res))))))
    (:results (res :scs (single-reg single-stack)))
                                       (sc-is res single-stack)
                                       (location= bits res))))))
    (:results (res :scs (single-reg single-stack)))
-  (:temporary (:sc signed-stack) stack-temp)
+ ; (:temporary (:sc signed-stack) stack-temp)
    (:arg-types signed-num)
    (:result-types single-float)
    (:translate make-single-float)
    (:arg-types signed-num)
    (:result-types single-float)
    (:translate make-single-float)
@@ -1396,31 +753,25 @@
         (single-reg
         (sc-case bits
           (signed-reg
         (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)))
+          (inst movd res bits))
           (signed-stack
           (signed-stack
-          (with-empty-tn@fp-top(res)
-             (inst fld bits))))))))
+          (inst movd res bits)))))))
  
  (define-vop (make-double-float)
    (:args (hi-bits :scs (signed-reg))
          (lo-bits :scs (unsigned-reg)))
    (:results (res :scs (double-reg)))
  
  (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)
+  (:temporary (:sc unsigned-reg) temp)
    (:arg-types signed-num unsigned-num)
    (:result-types double-float)
    (:translate make-double-float)
    (:policy :fast-safe)
    (:vop-var vop)
    (:generator 2
    (: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 :dword :base rbp-tn
-                           :disp (- (* (1+ offset) n-word-bytes))))))))
+    (move temp hi-bits)
+    (inst shl temp 32)
+    (inst or temp lo-bits)
+    (inst movd res temp)))
  
  (define-vop (single-float-bits)
    (:args (float :scs (single-reg descriptor-reg)
  
  (define-vop (single-float-bits)
    (:args (float :scs (single-reg descriptor-reg)
@@ -1437,11 +788,10 @@
        (signed-reg
         (sc-case float
          (single-reg
        (signed-reg
         (sc-case float
          (single-reg
-         (with-tn@fp-top(float)
-           (inst fst stack-temp)
-           (inst mov bits stack-temp)))
+         (inst movss stack-temp float)
+         (move bits stack-temp))
          (single-stack
          (single-stack
-         (inst mov bits float))
+         (move bits float))
          (descriptor-reg
           (loadw
            bits float single-float-value-slot
          (descriptor-reg
           (loadw
            bits float single-float-value-slot
@@ -1449,14 +799,16 @@
        (signed-stack
         (sc-case float
          (single-reg
        (signed-stack
         (sc-case float
          (single-reg
-         (with-tn@fp-top(float)
-           (inst fst bits))))))))
+         (inst movss bits float)))))
+    ;; Sign-extend
+    (inst shl bits 32)
+    (inst sar bits 32)))
  
  (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)))
  
  (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)
+  (:temporary (:sc signed-stack :from :argument :to :result) temp)
    (:arg-types double-float)
    (:result-types signed-num)
    (:translate double-float-high-bits)
    (:arg-types double-float)
    (:result-types signed-num)
    (:translate double-float-high-bits)
@@ -1465,23 +817,20 @@
    (:generator 5
       (sc-case float
         (double-reg
    (:generator 5
       (sc-case float
         (double-reg
-       (with-tn@fp-top(float)
-         (let ((where (make-ea :dword :base rbp-tn
-                               :disp (- (* (+ 2 (tn-offset temp))
-                                           n-word-bytes)))))
-           (inst fstd where)))
-       (loadw hi-bits rbp-tn (- (1+ (tn-offset temp)))))
+       (inst movsd temp float)
+       (move hi-bits temp))
         (double-stack
         (double-stack
-       (loadw hi-bits rbp-tn (- (1+ (tn-offset float)))))
+       (loadw hi-bits ebp-tn (- (tn-offset float))))
         (descriptor-reg
         (descriptor-reg
-       (loadw hi-bits float (1+ double-float-value-slot)
-              other-pointer-lowtag)))))
+       (loadw hi-bits float double-float-value-slot
+              other-pointer-lowtag)))
+     (inst sar hi-bits 32)))
  
  (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)))
  
  (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)
+  (:temporary (:sc signed-stack :from :argument :to :result) temp)
    (:arg-types double-float)
    (:result-types unsigned-num)
    (:translate double-float-low-bits)
    (:arg-types double-float)
    (:result-types unsigned-num)
    (:translate double-float-low-bits)
@@ -1490,17 +839,15 @@
    (:generator 5
       (sc-case float
         (double-reg
    (:generator 5
       (sc-case float
         (double-reg
-       (with-tn@fp-top(float)
-         (let ((where (make-ea :dword :base rbp-tn
-                               :disp (- (* (+ 2 (tn-offset temp))
-                                           n-word-bytes)))))
-           (inst fstd where)))
-       (loadw lo-bits rbp-tn (- (+ 2 (tn-offset temp)))))
+       (inst movsd temp float)
+       (move lo-bits temp))
         (double-stack
         (double-stack
-       (loadw lo-bits rbp-tn (- (+ 2 (tn-offset float)))))
+       (loadw lo-bits ebp-tn (- (tn-offset float))))
         (descriptor-reg
         (loadw lo-bits float double-float-value-slot
         (descriptor-reg
         (loadw lo-bits float double-float-value-slot
-              other-pointer-lowtag)))))
+              other-pointer-lowtag)))
+     (inst shl lo-bits 32)
+     (inst shr lo-bits 32)))
  
  \f
  ;;;; float mode hackery
  
  \f
  ;;;; float mode hackery
@@ -1558,1086 +905,6 @@
     (move res new)))
  \f
  
     (move res new)))
  \f
  
-(progn
-
-;;; Let's 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)
-              (:ignore 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)
-              (: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))
-                      (maybe-fp-wait node))
-                     (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)
-  (:generator 5
-    (note-this-location vop :internal-error)
-    (case (tn-offset x)
-       (0
-       (inst fstp fr1))
-       (1
-       (inst fstp fr0))
-       (t
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (inst fldd (make-random-tn :kind :normal
-                                  :sc (sc-or-lose 'double-reg)
-                                  :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 eax-offset
-                                :from :eval :to :result) eax)
-               (: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 eax)
-               (: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))
-
-
-
-;;; 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 eax-offset
-                            :from :argument :to :result) eax)
-               (: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 eax)
-               (: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 fr0)               ; 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 eax-offset
-                  :from :argument :to :result) eax)
-  (:results (y :scs (double-reg)))
-  (:arg-types double-float)
-  (:result-types double-float)
-  (:ignore eax)
-  (:policy :fast-safe)
-  (:note "inline tan function")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:ignore eax)
-  (:generator 5
-    (note-this-location vop :internal-error)
-    (case (tn-offset x)
-       (0
-       (inst fstp fr1))
-       (1
-       (inst fstp fr0))
-       (t
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (inst fldd (make-random-tn :kind :normal
-                                  :sc (sc-or-lose 'double-reg)
-                                  :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
-               (inst fstp fr0)
-               (inst fldl2e)
-               (inst fmul x))))
-       ((double-stack descriptor-reg)
-        (inst fstp fr0)
-        (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 eax-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.
-     (inst fstp fr0)               ; -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 eax-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)
-  (: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.
-     (inst fstp fr0)               ; -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)
-     (inst fstp fr0)
-     (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
-            (inst fstp fr0)
-            (inst fldln2)
-            (inst fxch fr1))
-           (t
-            ;; x is in a FP reg, not fr0 or fr1
-            (inst fstp fr0)
-            (inst fstp fr0)
-            (inst fldln2)
-            (inst fldd (make-random-tn :kind :normal
-                                       :sc (sc-or-lose 'double-reg)
-                                       :offset (1- (tn-offset x))))))
-        (inst fyl2x))
-       ((double-stack descriptor-reg)
-        (inst fstp fr0)
-        (inst fstp fr0)
-        (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
-            (inst fstp fr0)
-            (inst fldlg2)
-            (inst fxch fr1))
-           (t
-            ;; x is in a FP reg, not fr0 or fr1
-            (inst fstp fr0)
-            (inst fstp fr0)
-            (inst fldlg2)
-            (inst fldd (make-random-tn :kind :normal
-                                       :sc (sc-or-lose 'double-reg)
-                                       :offset (1- (tn-offset x))))))
-        (inst fyl2x))
-       ((double-stack descriptor-reg)
-        (inst fstp fr0)
-        (inst fstp fr0)
-        (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-desc x)))))
-      ;; Neither x or y are in either fr0 or fr1
-      (t
-       ;; Load y then x
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (sc-case y
-         (double-reg
-          (inst fldd (make-random-tn :kind :normal
-                                     :sc (sc-or-lose 'double-reg)
-                                     :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)
-                                     :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")
-  (: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
-          (inst fstp fr0)
-          (sc-case y
-            (signed-reg
-             (inst mov temp y)
-             (inst fild temp))
-            (signed-stack
-             (inst fild y)))
-          (inst fxch fr1))
-         (t
-          (inst fstp fr0)
-          (inst fstp fr0)
-          (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)
-                                    :offset (1- (tn-offset x)))))))
-       ((double-stack descriptor-reg)
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (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)
-  (: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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-desc x)))))
-      ;; Neither x or y are in either fr0 or fr1
-      (t
-       ;; Load y then x
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (sc-case y
-         (double-reg
-          (inst fldd (make-random-tn :kind :normal
-                                     :sc (sc-or-lose 'double-reg)
-                                     :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)
-                                     :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 eax-offset :from :eval) temp)
-  (:results (y :scs (double-reg)))
-  (:arg-types double-float)
-  (:result-types double-float)
-  (:policy :fast-safe)
-  (:note "inline log1p function")
-  (:ignore temp)
-  (:generator 5
-     ;; x is in a FP reg, not fr0, fr1.
-     (inst fstp fr0)
-     (inst fstp fr0)
-     (inst fldd (make-random-tn :kind :normal
-                               :sc (sc-or-lose 'double-reg)
-                               :offset (- (tn-offset x) 2)))
-     ;; Check the range
-     (inst push #x3e947ae1)    ; Constant 0.29
-     (inst fabs)
-     (inst fld (make-ea :dword :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)
-                                :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)
-                               :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 (member :pentium-style-fyl2xp1 *backend-subfeatures*))
-  (:note "inline log1p with limited x range function")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 4
-     (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
-            (inst fstp fr0)
-            (inst fldln2)
-            (inst fxch fr1))
-           (t
-            ;; x is in a FP reg, not fr0 or fr1
-            (inst fstp fr0)
-            (inst fstp fr0)
-            (inst fldln2)
-            (inst fldd (make-random-tn :kind :normal
-                                       :sc (sc-or-lose 'double-reg)
-                                       :offset (1- (tn-offset x)))))))
-       ((double-stack descriptor-reg)
-        (inst fstp fr0)
-        (inst fstp fr0)
-        (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)
-  (: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
-            (inst fstp fr0))
-           (t
-            ;; x is in a FP reg, not fr0 or fr1
-            (inst fstp fr0)
-            (inst fstp fr0)
-            (inst fldd (make-random-tn :kind :normal
-                                       :sc (sc-or-lose 'double-reg)
-                                       :offset (- (tn-offset x) 2))))))
-       ((double-stack descriptor-reg)
-        (inst fstp fr0)
-        (inst fstp fr0)
-        (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)))
-       (inst fstp fr0))
-      ;; x not in fr0 or fr1
-      (t
-       ;; Load x then 1.0
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (sc-case x
-         (double-reg
-          (inst fldd (make-random-tn :kind :normal
-                                     :sc (sc-or-lose 'double-reg)
-                                     :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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-desc y)))))
-      ((and (sc-is x double-reg) (zerop (tn-offset x))
-           (sc-is y double-reg) (zerop (tn-offset x)))
-       ;; copy x to fr1
-       (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack x)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (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
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-stack y)))
-         (descriptor-reg
-          (inst fstp fr0)
-          (inst fldd (ea-for-df-desc y)))))
-      ;; Neither y or x are in either fr0 or fr1
-      (t
-       ;; Load x then y
-       (inst fstp fr0)
-       (inst fstp fr0)
-       (sc-case x
-         (double-reg
-          (inst fldd (make-random-tn :kind :normal
-                                     :sc (sc-or-lose 'double-reg)
-                                     :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)
-                                     :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
-\f
-
  ;;;; complex float VOPs
  
  (define-vop (make-complex-single-float)
  ;;;; complex float VOPs
  
  (define-vop (make-complex-single-float)
@@ -2654,35 +921,15 @@
    (:generator 5
      (sc-case r
        (complex-single-reg
    (:generator 5
      (sc-case r
        (complex-single-reg
-       (let ((r-real (complex-double-reg-real-tn r)))
+       (let ((r-real (complex-single-reg-real-tn r)))
          (unless (location= real r-real)
          (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)))
+          (inst movss r-real real)))
+       (let ((r-imag (complex-single-reg-imag-tn r)))
          (unless (location= imag r-imag)
          (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))))))
+          (inst movss r-imag imag))))
        (complex-single-stack
        (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)))))
+       (inst movss (ea-for-csf-real-stack r) real)
+       (inst movss (ea-for-csf-imag-stack r) imag)))))
  
  (define-vop (make-complex-double-float)
    (:translate complex)
  
  (define-vop (make-complex-double-float)
    (:translate complex)
@@ -2700,33 +947,13 @@
        (complex-double-reg
         (let ((r-real (complex-double-reg-real-tn r)))
          (unless (location= real r-real)
        (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)))))
+          (inst movsd r-real real)))
         (let ((r-imag (complex-double-reg-imag-tn r)))
          (unless (location= imag r-imag)
         (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))))))
+          (inst movsd r-imag imag))))
        (complex-double-stack
        (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)))))
+       (inst movsd (ea-for-cdf-real-stack r) real)
+       (inst movsd (ea-for-cdf-imag-stack r) imag)))))
  
  (define-vop (complex-float-value)
    (:args (x :target r))
  
  (define-vop (complex-float-value)
    (:args (x :target r))
@@ -2740,14 +967,9 @@
                                   :sc (sc-or-lose 'double-reg)
                                   :offset (+ offset (tn-offset x)))))
              (unless (location= value-tn r)
                                   :sc (sc-or-lose 'double-reg)
                                   :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))))))
+              (if (sc-is x complex-single-reg)
+                  (inst movss r value-tn)
+                  (inst movsd r value-tn)))))
           ((sc-is r single-reg)
            (let ((ea (sc-case x
                        (complex-single-stack
           ((sc-is r single-reg)
            (let ((ea (sc-case x
                        (complex-single-stack
@@ -2758,8 +980,7 @@
                         (ecase offset
                           (0 (ea-for-csf-real-desc x))
                           (1 (ea-for-csf-imag-desc x)))))))
                         (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))))
+            (inst movss r ea)))
           ((sc-is r double-reg)
            (let ((ea (sc-case x
                        (complex-double-stack
           ((sc-is r double-reg)
            (let ((ea (sc-case x
                        (complex-double-stack
@@ -2770,8 +991,7 @@
                         (ecase offset
                           (0 (ea-for-cdf-real-desc x))
                           (1 (ea-for-cdf-imag-desc x)))))))
                         (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))))
+            (inst movsd r ea)))
           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
  
  (define-vop (realpart/complex-single-float complex-float-value)
           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
  
  (define-vop (realpart/complex-single-float complex-float-value)
diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp

index 0ae887b..4b8fd6c 100644 (file)
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -22,6 +22,9 @@
  ;;; registers only.  r8-15 are handled separately
  (deftype reg () '(unsigned-byte 3))
  
  ;;; registers only.  r8-15 are handled separately
  (deftype reg () '(unsigned-byte 3))
  
+;; This includes legacy records and r8-16
+(deftype full-reg () '(unsigned-byte 4))
+
  ;;; default word size for the chip: if the operand size !=:dword
  ;;; we need to output #x66 (or REX) prefix
  (def!constant +default-operand-size+ :dword)
  ;;; default word size for the chip: if the operand size !=:dword
  ;;; we need to output #x66 (or REX) prefix
  (def!constant +default-operand-size+ :dword)
@@ -40,7 +43,7 @@
    :dword)
  
  (defparameter *byte-reg-names*
    :dword)
  
  (defparameter *byte-reg-names*
-  #(al cl dl bl ah ch dh bh))
+  #(al cl dl bl sil dil r8b r9b r10b r11b r14b r15b))
  (defparameter *word-reg-names*
    #(ax cx dx bx sp bp si di))
  (defparameter *dword-reg-names*
  (defparameter *word-reg-names*
    #(ax cx dx bx sp bp si di))
  (defparameter *dword-reg-names*
@@ -49,7 +52,8 @@
    #(rax rcx rdx rbx rsp rbp rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
  
  (defun print-reg-with-width (value width stream dstate)
    #(rax rcx rdx rbx rsp rbp rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
  
  (defun print-reg-with-width (value width stream dstate)
-  (declare (ignore dstate))
+  (declare (ignore dstate)
+          (type full-reg value))
    (princ (aref (ecase width
                  (:byte *byte-reg-names*)
                  (:word *word-reg-names*)
    (princ (aref (ecase width
                  (:byte *byte-reg-names*)
                  (:word *word-reg-names*)
@@ -61,67 +65,80 @@
    )
  
  (defun print-reg (value stream dstate)
    )
  
  (defun print-reg (value stream dstate)
-  (declare (type reg value)
+  (declare (type full-reg value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
    (print-reg-with-width value
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
    (print-reg-with-width value
-                       (sb!disassem:dstate-get-prop dstate 'width)
+                       (or (sb!disassem:dstate-get-prop dstate 'reg-width)
+                           *default-address-size*)
                         stream
                         dstate))
  
  (defun print-word-reg (value stream dstate)
                         stream
                         dstate))
  
  (defun print-word-reg (value stream dstate)
-  (declare (type reg value)
+  (declare (type (or full-reg list) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (print-reg-with-width value
-                       (or (sb!disassem:dstate-get-prop dstate 'word-width)
-                           +default-operand-size+)
-                       stream
-                       dstate))
+  (print-reg-with-width
+   (if (consp value) (car value) value)
+   (or (sb!disassem:dstate-get-prop dstate 'reg-width)
+       +default-operand-size+)
+   stream
+   dstate))
  
  (defun print-byte-reg (value stream dstate)
  
  (defun print-byte-reg (value stream dstate)
-  (declare (type reg value)
+  (declare (type full-reg value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
    (print-reg-with-width value :byte stream dstate))
  
  (defun print-addr-reg (value stream dstate)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
    (print-reg-with-width value :byte stream dstate))
  
  (defun print-addr-reg (value stream dstate)
-  (declare (type reg value)
+  (declare (type full-reg value)
+          (type stream stream)
+          (type sb!disassem:disassem-state dstate))
+  (print-reg-with-width value 
+                       (or (sb!disassem:dstate-get-prop dstate 'reg-width)
+                           *default-address-size*)
+                       stream dstate))
+
+(defun print-rex-reg/mem (value stream dstate)
+  (declare (type (or list full-reg) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (print-reg-with-width value *default-address-size* stream dstate))
+  (if (typep value 'full-reg)
+      (print-reg value stream dstate)
+    (print-mem-access value stream nil dstate)))
  
  (defun print-reg/mem (value stream dstate)
  
  (defun print-reg/mem (value stream dstate)
-  (declare (type (or list reg) value)
+  (declare (type (or list full-reg) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (if (typep value 'reg)
+  (if (typep value 'full-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)
        (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)
+  (declare (type (or list full-reg) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (if (typep value 'reg)
+  (if (typep value 'full-reg)
        (print-reg value stream dstate)
        (print-reg value stream dstate)
-      (print-mem-access value stream t dstate)))
+    (print-mem-access value stream t dstate)))
  
  (defun print-byte-reg/mem (value stream dstate)
  
  (defun print-byte-reg/mem (value stream dstate)
-  (declare (type (or list reg) value)
+  (declare (type (or list full-reg) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (if (typep value 'reg)
+  (if (typep value 'full-reg)
        (print-byte-reg value stream dstate)
        (print-mem-access value stream t dstate)))
  
  (defun print-word-reg/mem (value stream dstate)
        (print-byte-reg value stream dstate)
        (print-mem-access value stream t dstate)))
  
  (defun print-word-reg/mem (value stream dstate)
-  (declare (type (or list reg) value)
+  (declare (type (or list full-reg) value)
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
            (type stream stream)
            (type sb!disassem:disassem-state dstate))
-  (if (typep value 'reg)
+  (if (typep value 'full-reg)
        (print-word-reg value stream dstate)
        (print-mem-access value stream nil dstate)))
  
        (print-word-reg value stream dstate)
        (print-mem-access value stream nil dstate)))
  
@@ -129,6 +146,22 @@
    (declare (ignore dstate))
    (sb!disassem:princ16 value stream))
  
    (declare (ignore dstate))
    (sb!disassem:princ16 value stream))
  
+(defun prefilter-word-reg (value dstate)
+  (declare (type (or full-reg list) value))
+  (if (atom value)
+      value
+    (let ((reg (first value))
+         (rex.wrxb (second value)))
+      (declare (type (or null (unsigned-byte 4)) rex.wrxb)
+              (type (unsigned-byte 3) reg))
+       (setf (sb!disassem:dstate-get-prop dstate 'reg-width)
+             (if (and rex.wrxb (plusp (logand rex.wrxb #b1000)))
+                 :qword
+               +default-operand-size+))
+       (if (plusp (logand rex.wrxb #b0100))
+           (+ 8 reg)
+         reg))))
+  
  ;;; 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
  ;;; 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
@@ -136,44 +169,59 @@
  (defun prefilter-reg/mem (value dstate)
    (declare (type list value)
            (type sb!disassem:disassem-state dstate))
  (defun prefilter-reg/mem (value dstate)
    (declare (type list value)
            (type sb!disassem:disassem-state dstate))
-  (let ((mod (car value))
-       (r/m (cadr value)))
+  (let ((mod (first value))
+       (r/m (second value))
+       (rex.wrxb (third value)))
      (declare (type (unsigned-byte 2) mod)
      (declare (type (unsigned-byte 2) mod)
-            (type (unsigned-byte 3) r/m))
-    (cond ((= mod #b11)
-          ;; registers
-          r/m)
-         ((= r/m #b100)
-          ;; sib byte
-          (let ((sib (sb!disassem:read-suffix 8 dstate)))
-            (declare (type (unsigned-byte 8) sib))
-            (let ((base-reg (ldb (byte 3 0) sib))
-                  (index-reg (ldb (byte 3 3) sib))
-                  (index-scale (ldb (byte 2 6) sib)))
-              (declare (type (unsigned-byte 3) base-reg index-reg)
-                       (type (unsigned-byte 2) index-scale))
-              (let* ((offset
-                      (case mod
-                        (#b00
-                         (if (= base-reg #b101)
-                             (sb!disassem:read-signed-suffix 32 dstate)
-                             nil))
-                        (#b01
-                         (sb!disassem:read-signed-suffix 8 dstate))
-                        (#b10
-                         (sb!disassem:read-signed-suffix 32 dstate)))))
-                (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
-                      offset
-                      (if (= index-reg #b100) nil index-reg)
-                      (ash 1 index-scale))))))
-         ((and (= mod #b00) (= r/m #b101))
-          (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
-         ((= mod #b00)
-          (list r/m))
-         ((= mod #b01)
-          (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
+            (type (unsigned-byte 3) r/m)
+            (type (or null (unsigned-byte 4)) rex.wrxb))
+    
+    (setf (sb!disassem:dstate-get-prop dstate 'reg-width)
+         (if (and rex.wrxb (plusp (logand rex.wrxb #b1000)))
+             :qword
+           +default-operand-size+))
+
+    (let ((full-reg (if (and rex.wrxb (plusp (logand rex.wrxb #b0001)))
+                       (progn
+                         (setf (sb!disassem:dstate-get-prop dstate 'reg-width)
+                               :qword)
+                         (+ 8 r/m) )
+                     r/m)))
+      (declare (type full-reg full-reg))
+      (cond ((= mod #b11)
+            ;; registers
+            full-reg)
+           ((= r/m #b100)
+            ;; sib byte
+            (let ((sib (sb!disassem:read-suffix 8 dstate)))
+              (declare (type (unsigned-byte 8) sib))
+              (let ((base-reg (ldb (byte 3 0) sib))
+                    (index-reg (ldb (byte 3 3) sib))
+                    (index-scale (ldb (byte 2 6) sib)))
+                (declare (type (unsigned-byte 3) base-reg index-reg)
+                         (type (unsigned-byte 2) index-scale))
+                (let* ((offset
+                        (case mod
+                              (#b00
+                               (if (= base-reg #b101)
+                                   (sb!disassem:read-signed-suffix 32 dstate)
+                                 nil))
+                              (#b01
+                               (sb!disassem:read-signed-suffix 8 dstate))
+                              (#b10
+                               (sb!disassem:read-signed-suffix 32 dstate)))))
+                  (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+                        offset
+                        (if (= index-reg #b100) nil index-reg)
+                        (ash 1 index-scale))))))
+           ((and (= mod #b00) (= r/m #b101))
+            (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
+           ((= mod #b00)
+            (list full-reg))
+           ((= mod #b01)
+          (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
           (t                            ; (= mod #b10)
           (t                            ; (= mod #b10)
-          (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
+          (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
  
  
  ;;; This is a sort of bogus prefilter that just stores the info globally for
  
  
  ;;; This is a sort of bogus prefilter that just stores the info globally for
@@ -181,16 +229,17 @@
  (defun prefilter-width (value dstate)
    (setf (sb!disassem:dstate-get-prop dstate 'width)
         (if (zerop value)
  (defun prefilter-width (value dstate)
    (setf (sb!disassem:dstate-get-prop dstate 'width)
         (if (zerop value)
-           :byte
-           (let ((word-width
+           (setf (sb!disassem:dstate-get-prop dstate 'reg-width)
+                 :byte)
+           (let ((reg-width
                    ;; set by a prefix instruction
                    ;; set by a prefix instruction
-                  (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                  (or (sb!disassem:dstate-get-prop dstate 'reg-width)
                        +default-operand-size+)))
                        +default-operand-size+)))
-             (when (not (eql word-width +default-operand-size+))
+             (when (not (eql reg-width +default-operand-size+))
                 ;; Reset it.
                 ;; Reset it.
-               (setf (sb!disassem:dstate-get-prop dstate 'word-width)
+               (setf (sb!disassem:dstate-get-prop dstate 'reg-width)
                       +default-operand-size+))
                       +default-operand-size+))
-             word-width))))
+             reg-width))))
  
  (defun read-address (value dstate)
    (declare (ignore value))             ; always nil anyway
  
  (defun read-address (value dstate)
    (declare (ignore value))             ; always nil anyway
@@ -201,6 +250,7 @@
      (:byte 8)
      (:word 16)
      (:dword 32)
      (:byte 8)
      (:word 16)
      (:dword 32)
+    (:qword 64)
      (:float 32)
      (:double 64)))
  
      (:float 32)
      (:double 64)))
  
@@ -236,7 +286,10 @@
    :printer #'print-addr-reg)
  
  (sb!disassem:define-arg-type word-reg
    :printer #'print-addr-reg)
  
  (sb!disassem:define-arg-type word-reg
-  :printer #'print-word-reg)
+  :prefilter #'prefilter-word-reg
+  :printer (lambda (value stream dstate)
+            (print-word-reg value stream dstate)))
+
  
  (sb!disassem:define-arg-type imm-addr
    :prefilter #'read-address
  
  (sb!disassem:define-arg-type imm-addr
    :prefilter #'read-address
@@ -246,13 +299,16 @@
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
                (sb!disassem:read-suffix
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
                (sb!disassem:read-suffix
-               (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+               (width-bits
+                (or (sb!disassem:dstate-get-prop dstate 'width)
+                    *default-address-size*))
                 dstate)))
  
  (sb!disassem:define-arg-type signed-imm-data
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
                 dstate)))
  
  (sb!disassem:define-arg-type signed-imm-data
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
-              (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+              (let ((width (or (sb!disassem:dstate-get-prop dstate 'width)
+                               *default-address-size*)))
                  (sb!disassem:read-signed-suffix (width-bits width) dstate))))
  
  (sb!disassem:define-arg-type signed-imm-byte
                  (sb!disassem:read-signed-suffix (width-bits width) dstate))))
  
  (sb!disassem:define-arg-type signed-imm-byte
@@ -269,7 +325,7 @@
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
                (let ((width
    :prefilter (lambda (value dstate)
                (declare (ignore value)) ; always nil anyway
                (let ((width
-                     (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                     (or (sb!disassem:dstate-get-prop dstate 'reg-width)
                           +default-operand-size+)))
                  (sb!disassem:read-suffix (width-bits width) dstate))))
  
                           +default-operand-size+)))
                  (sb!disassem:read-suffix (width-bits width) dstate))))
  
@@ -294,6 +350,15 @@
    :prefilter #'prefilter-reg/mem
    :printer #'print-word-reg/mem)
  
    :prefilter #'prefilter-reg/mem
    :printer #'print-word-reg/mem)
  
+(sb!disassem:define-arg-type rex-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-rex-reg/mem)
+(sb!disassem:define-arg-type sized-rex-reg/mem
+  ;; Same as reg/mem, but prints an explicit size indicator for
+  ;; memory references.
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-sized-reg/mem)
+
  ;;; added by jrd
  (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  (defun print-fp-reg (value stream dstate)
  ;;; added by jrd
  (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  (defun print-fp-reg (value stream dstate)
@@ -315,11 +380,11 @@
                  (or (null value)
                      (and (numberp value) (zerop value))) ; zzz jrd
                  (princ 'b stream)
                  (or (null value)
                      (and (numberp value) (zerop value))) ; zzz jrd
                  (princ 'b stream)
-                (let ((word-width
+                (let ((reg-width
                         ;; set by a prefix instruction
                         ;; set by a prefix instruction
-                       (or (sb!disassem:dstate-get-prop dstate 'word-width)
+                       (or (sb!disassem:dstate-get-prop dstate 'reg-width)
                             +default-operand-size+)))
                             +default-operand-size+)))
-                  (princ (schar (symbol-name word-width) 0) stream)))))
+                  (princ (schar (symbol-name reg-width) 0) stream)))))
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *conditions*
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *conditions*
@@ -379,6 +444,15 @@
    (accum :type 'accum)
    (imm))
  
    (accum :type 'accum)
    (imm))
  
+(sb!disassem:define-instruction-format (rex-simple 16)
+  (rex  :field (byte 4 4) :value #b0100)
+  (wrxb  :field (byte 4 0))
+  (op    :field (byte 7 9))
+  (width :field (byte 1 8) :type 'width)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
  ;;; Same as simple, but with direction bit
  (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
    (op :field (byte 6 2))
  ;;; Same as simple, but with direction bit
  (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
    (op :field (byte 6 2))
@@ -392,6 +466,12 @@
                                                         :tab accum ", " imm))
    (imm :type 'imm-data))
  
                                                         :tab accum ", " imm))
    (imm :type 'imm-data))
  
+(sb!disassem:define-instruction-format (rex-accum-imm 16
+                                    :include 'rex-simple
+                                    :default-printer '(:name
+                                                       :tab accum ", " imm))
+  (imm :type 'imm-data))
+
  (sb!disassem:define-instruction-format (reg-no-width 8
                                      :default-printer '(:name :tab reg))
    (op   :field (byte 5 3))
  (sb!disassem:define-instruction-format (reg-no-width 8
                                      :default-printer '(:name :tab reg))
    (op   :field (byte 5 3))
@@ -400,6 +480,26 @@
    (accum :type 'word-accum)
    (imm))
  
    (accum :type 'word-accum)
    (imm))
  
+(sb!disassem:define-instruction-format (rex-reg-no-width 16
+                                    :default-printer '(:name :tab reg))
+  (rex   :field (byte 4 4)  :value #b0100)
+  (op   :field (byte 5 11))
+  (reg   :fields (list (byte 3 8) (byte 4 0)) :type 'word-reg)
+  ;; optional fields
+  (accum :type 'word-accum)
+  (imm))
+
+(sb!disassem:define-instruction-format (modrm-reg-no-width 24
+                                    :default-printer '(:name :tab reg))
+  (rex   :field (byte 4 4)  :value #b0100)
+  (ff   :field (byte 8 8)  :value #b11111111)
+  (mod  :field (byte 2 22))
+  (modrm-reg :field (byte 3 19))
+  (reg   :fields (list (byte 3 16) (byte 4 0)) :type 'word-reg)
+  ;; optional fields
+  (accum :type 'word-accum)
+  (imm))
+
  ;;; adds a width field to reg-no-width
  (sb!disassem:define-instruction-format (reg 8
                                         :default-printer '(:name :tab reg))
  ;;; adds a width field to reg-no-width
  (sb!disassem:define-instruction-format (reg 8
                                         :default-printer '(:name :tab reg))
@@ -411,6 +511,16 @@
    (imm)
    )
  
    (imm)
    )
  
+(sb!disassem:define-instruction-format (rex-reg 16
+                                       :default-printer '(:name :tab reg))
+  (rex   :field (byte 4 4)  :value #b0100)
+  (op    :field (byte 5 11))
+  (reg   :field (byte 3 8) :type 'reg)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm)
+  )
+
  ;;; Same as reg, but with direction bit
  (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
    (op  :field (byte 3 5))
  ;;; Same as reg, but with direction bit
  (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
    (op  :field (byte 3 5))
@@ -431,6 +541,17 @@
    ;; optional fields
    (imm))
  
    ;; optional fields
    (imm))
  
+(sb!disassem:define-instruction-format (rex-reg-reg/mem 24
+                                       :default-printer
+                                       `(:name :tab reg ", " reg/mem))
+  (rex    :field (byte 4 4)  :value #b0100)
+  (op      :field (byte 8 8))
+  (reg/mem :fields (list (byte 2 22) (byte 3 16) (byte 4 0))
+          :type 'rex-reg/mem)
+  (reg     :field (byte 3 19)  :type 'reg)
+  ;; optional fields
+  (imm))
+
  ;;; same as reg-reg/mem, but with direction bit
  (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
                                         :include 'reg-reg/mem
  ;;; same as reg-reg/mem, but with direction bit
  (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
                                         :include 'reg-reg/mem
@@ -441,6 +562,16 @@
    (op  :field (byte 6 2))
    (dir :field (byte 1 1)))
  
    (op  :field (byte 6 2))
    (dir :field (byte 1 1)))
  
+(sb!disassem:define-instruction-format (rex-reg-reg/mem-dir 24
+                                       :include 'rex-reg-reg/mem
+                                       :default-printer
+                                       `(:name
+                                         :tab
+                                         ,(swap-if 'dir 'reg/mem ", " 'reg)))
+  (rex    :field (byte 4 4)  :value #b0100)
+  (op  :field (byte 6 10))
+  (dir :field (byte 1 9)))
+
  ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
  (sb!disassem:define-instruction-format (reg/mem 16
                                         :default-printer '(:name :tab reg/mem))
  ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
  (sb!disassem:define-instruction-format (reg/mem 16
                                         :default-printer '(:name :tab reg/mem))
@@ -451,6 +582,14 @@
    ;; optional fields
    (imm))
  
    ;; optional fields
    (imm))
  
+(sb!disassem:define-instruction-format (rex-reg/mem 24
+                                       :default-printer '(:name :tab reg/mem))
+  (rex    :field (byte 4 4)  :value #b0100)
+  (op     :fields (list (byte 8 8) (byte 3 19)))
+  (reg/mem :fields (list (byte 2 22) (byte 3 16) (byte 4 0)) :type 'sized-rex-reg/mem)
+  ;; optional fields
+  (imm))
+
  ;;; Same as reg/mem, but with the immediate value occurring by default,
  ;;; and with an appropiate printer.
  (sb!disassem:define-instruction-format (reg/mem-imm 16
  ;;; Same as reg/mem, but with the immediate value occurring by default,
  ;;; and with an appropiate printer.
  (sb!disassem:define-instruction-format (reg/mem-imm 16
@@ -460,6 +599,13 @@
    (reg/mem :type 'sized-reg/mem)
    (imm     :type 'imm-data))
  
    (reg/mem :type 'sized-reg/mem)
    (imm     :type 'imm-data))
  
+(sb!disassem:define-instruction-format (rex-reg/mem-imm 24
+                                       :include 'rex-reg/mem
+                                       :default-printer
+                                       '(:name :tab reg/mem ", " imm))
+  (reg/mem :type 'sized-rex-reg/mem)
+  (imm     :type 'imm-data))
+
  ;;; Same as reg/mem, but with using the accumulator in the default printer
  (sb!disassem:define-instruction-format
      (accum-reg/mem 16
  ;;; Same as reg/mem, but with using the accumulator in the default printer
  (sb!disassem:define-instruction-format
      (accum-reg/mem 16
@@ -480,6 +626,20 @@
    ;; optional fields
    (imm))
  
    ;; optional fields
    (imm))
  
+;;; Same as reg-reg/mem, but with a prefix of #xf2 0f
+(sb!disassem:define-instruction-format (xmm-ext-reg-reg/mem 32
+                                       :default-printer
+                                       `(:name :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)   :value #xf2)
+  (prefix2  :field (byte 8 8)  :value #x0f)
+  (op      :field (byte 7 17))
+  (width   :field (byte 1 16)  :type 'width)
+  (reg/mem :fields (list (byte 2 30) (byte 3 24))
+                               :type 'reg/mem)
+  (reg     :field (byte 3 27)  :type 'reg)
+  ;; optional fields
+  (imm))
+
  ;;; reg-no-width with #x0f prefix
  (sb!disassem:define-instruction-format (ext-reg-no-width 16
                                         :default-printer '(:name :tab reg))
  ;;; reg-no-width with #x0f prefix
  (sb!disassem:define-instruction-format (ext-reg-no-width 16
                                         :default-printer '(:name :tab reg))
@@ -563,6 +723,10 @@
                                      :include 'simple
                                      :default-printer '(:name width)))
  
                                      :include 'simple
                                      :default-printer '(:name width)))
  
+(sb!disassem:define-instruction-format (rex-string-op 16
+                                    :include 'rex-simple
+                                    :default-printer '(:name width)))
+
  (sb!disassem:define-instruction-format (short-cond-jump 16)
    (op    :field (byte 4 4))
    (cc   :field (byte 4 0) :type 'condition-code)
  (sb!disassem:define-instruction-format (short-cond-jump 16)
    (op    :field (byte 4 4))
    (cc   :field (byte 4 0) :type 'condition-code)
@@ -678,19 +842,23 @@
  (defun emit-relative-fixup (segment fixup)
    (note-fixup segment :relative fixup)
    (emit-dword segment (or (fixup-offset fixup) 0)))
  (defun emit-relative-fixup (segment fixup)
    (note-fixup segment :relative fixup)
    (emit-dword segment (or (fixup-offset fixup) 0)))
+
  \f
  ;;;; the effective-address (ea) structure
  
  (defun reg-tn-encoding (tn)
    (declare (type tn tn))
  \f
  ;;;; the effective-address (ea) structure
  
  (defun reg-tn-encoding (tn)
    (declare (type tn tn))
-  (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+  (aver (member  (sb-name (sc-sb (tn-sc tn))) '(registers float-registers)))
    ;; ea only has space for three bits of register number: regs r8
    ;; and up are selected by a REX prefix byte which caller is responsible
    ;; for having emitted where necessary already
    ;; ea only has space for three bits of register number: regs r8
    ;; and up are selected by a REX prefix byte which caller is responsible
    ;; for having emitted where necessary already
-  (let ((offset (mod (tn-offset tn) 16)))
-    (logior (ash (logand offset 1) 2)
-           (ash offset -1))))
-
+  (cond ((fp-reg-tn-p tn)
+        (mod (tn-offset tn) 8))
+       (t
+        (let ((offset (mod (tn-offset tn) 16)))
+          (logior (ash (logand offset 1) 2)
+                  (ash offset -1))))))
+  
  (defstruct (ea (:constructor make-ea (size &key base index scale disp))
                (:copier nil))
    ;; note that we can represent an EA qith a QWORD size, but EMIT-EA
  (defstruct (ea (:constructor make-ea (size &key base index scale disp))
                (:copier nil))
    ;; note that we can represent an EA qith a QWORD size, but EMIT-EA
@@ -730,13 +898,55 @@
             (format stream "+~A" (ea-disp ea))))
          (write-char #\] stream))))
  
             (format stream "+~A" (ea-disp ea))))
          (write-char #\] stream))))
  
+(defun emit-constant-tn-rip (segment constant-tn reg)
+  ;; AMD64 doesn't currently have a code object register to use as a
+  ;; base register for constant access. Instead we use RIP-relative
+  ;; addressing. The offset from the SIMPLE-FUN-HEADER to the instruction
+  ;; is passed to the backpatch callback. In addition we need the offset
+  ;; from the start of the function header to the slot in the CODE-HEADER
+  ;; that stores the constant. Since we don't know where the code header
+  ;; starts, instead count backwards from the function header.
+  (let* ((2comp (component-info *component-being-compiled*))
+        (constants (ir2-component-constants 2comp))
+        (len (length constants))
+        ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
+        ;; If there are an even amount of constants, there will be
+        ;; an extra qword of padding before the function header, which
+        ;; needs to be adjusted for. XXX: This will break if new slots
+        ;; are added to the code header.
+        (offset (* (- (+ len (if (evenp len)
+                                 1
+                                 2))
+                      (tn-offset constant-tn))
+                   n-word-bytes)))
+    ;; RIP-relative addressing
+    (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+    (emit-back-patch segment
+                    4
+                    (lambda (segment posn)
+                      ;; The addressing is relative to end of instruction,
+                      ;; i.e. the end of this dword. Hence the + 4.
+                      (emit-dword segment (+ 4 (- (+ offset posn)))))))
+  (values))
+
+(defun emit-label-rip (segment fixup reg)
+  (let ((label (fixup-offset fixup)))
+    ;; RIP-relative addressing
+    (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+    (emit-back-patch segment
+                    4
+                    (lambda (segment posn)
+                      (emit-dword segment (- (label-position label)
+                                             (+ posn 4))))))
+  (values))
+
  (defun emit-ea (segment thing reg &optional allow-constants)
    (etypecase thing
      (tn
       ;; this would be eleganter if we had a function that would create
       ;; an ea given a tn
       (ecase (sb-name (sc-sb (tn-sc thing)))
  (defun emit-ea (segment thing reg &optional allow-constants)
    (etypecase thing
      (tn
       ;; this would be eleganter if we had a function that would create
       ;; an ea given a tn
       (ecase (sb-name (sc-sb (tn-sc thing)))
-       (registers
+       ((registers float-registers)
         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
         (stack
         ;; Convert stack tns into an index off RBP.
         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
         (stack
         ;; Convert stack tns into an index off RBP.
@@ -749,15 +959,10 @@
                  (emit-dword segment disp)))))
         (constant
         (unless allow-constants
                  (emit-dword segment disp)))))
         (constant
         (unless allow-constants
+         ;; Why?
           (error
            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
           (error
            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
-       (emit-mod-reg-r/m-byte segment #b00 reg #b100)
-       (emit-sib-byte segment 1 4 5)   ;no base, no index
-       (emit-absolute-fixup segment
-                            (make-fixup nil
-                                        :code-object
-                                        (- (* (tn-offset thing) n-word-bytes)
-                                           other-pointer-lowtag))))))
+       (emit-constant-tn-rip segment thing reg))))
      (ea
       (let* ((base (ea-base thing))
             (index (ea-index thing))
      (ea
       (let* ((base (ea-base thing))
             (index (ea-index thing))
@@ -797,9 +1002,13 @@
                   (emit-absolute-fixup segment disp)
                   (emit-dword segment disp))))))
      (fixup
                   (emit-absolute-fixup segment disp)
                   (emit-dword segment disp))))))
      (fixup
-     (emit-mod-reg-r/m-byte segment #b00 reg #b100)
-     (emit-sib-byte segment 0 #b100 #b101)
-     (emit-absolute-fixup segment thing))))
+     (typecase (fixup-offset thing)
+       (label
+       (emit-label-rip segment thing reg))
+       (t
+       (emit-mod-reg-r/m-byte segment #b00 reg #b100)
+       (emit-sib-byte segment 0 #b100 #b101)
+       (emit-absolute-fixup segment thing))))))
  
  (defun fp-reg-tn-p (thing)
    (and (tn-p thing)
  
  (defun fp-reg-tn-p (thing)
    (and (tn-p thing)
@@ -864,7 +1073,6 @@
       (and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
      (t nil)))
  
       (and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
      (t nil)))
  
-
  (defun register-p (thing)
    (and (tn-p thing)
         (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
  (defun register-p (thing)
    (and (tn-p thing)
         (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
@@ -872,6 +1080,7 @@
  (defun accumulator-p (thing)
    (and (register-p thing)
         (= (tn-offset thing) 0)))
  (defun accumulator-p (thing)
    (and (register-p thing)
         (= (tn-offset thing) 0)))
+
  \f
  ;;;; utilities
  
  \f
  ;;;; utilities
  
@@ -884,23 +1093,32 @@
      (emit-byte segment +operand-size-prefix-byte+)))
  
  (defun maybe-emit-rex-prefix (segment operand-size r x b)
      (emit-byte segment +operand-size-prefix-byte+)))
  
  (defun maybe-emit-rex-prefix (segment operand-size r x b)
-  (labels ((if-hi (r)       ;; offset of r8 is 16
-            (if (and r (> (tn-offset r) 15)) 1 0)))
+  (labels ((if-hi (r)
+            (if (and r (> (tn-offset r)
+                          ;; offset of r8 is 16, offset of xmm8 is 8
+                          (if (fp-reg-tn-p r)
+                              7
+                              15)))
+                1
+                0)))
      (let ((rex-w (if (eq operand-size :qword) 1 0))
           (rex-r (if-hi r))
           (rex-x (if-hi x))
           (rex-b (if-hi b)))
      (let ((rex-w (if (eq operand-size :qword) 1 0))
           (rex-r (if-hi r))
           (rex-x (if-hi x))
           (rex-b (if-hi b)))
-      (when (not (zerop (logior rex-w rex-r rex-x rex-b)))
+      (when (or (eq operand-size :byte) ;; REX needed to access SIL/DIL
+               (not (zerop (logior rex-w rex-r rex-x rex-b))))
         (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
  
         (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
  
-(defun maybe-emit-rex-for-ea (segment ea reg)
+(defun maybe-emit-rex-for-ea (segment ea reg &key operand-size)
    (let ((ea-p (ea-p ea)))              ;emit-ea can also be called with a tn
    (let ((ea-p (ea-p ea)))              ;emit-ea can also be called with a tn
-    (maybe-emit-rex-prefix segment (operand-size ea) reg 
+    (maybe-emit-rex-prefix segment
+                          (or operand-size (operand-size ea))
+                          reg
                            (and ea-p (ea-index ea))
                            (cond (ea-p (ea-base ea))
                                  ((and (tn-p ea)
                            (and ea-p (ea-index ea))
                            (cond (ea-p (ea-base ea))
                                  ((and (tn-p ea)
-                                      (eql (sb-name (sc-sb (tn-sc ea))) 
-                                           'registers))
+                                      (member (sb-name (sc-sb (tn-sc ea))) 
+                                              '(float-registers registers)))
                                   ea)
                                  (t nil)))))
  
                                   ea)
                                  (t nil)))))
  
@@ -927,6 +1145,13 @@
         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
      (ea
       (ea-size thing))
         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
      (ea
       (ea-size thing))
+    (fixup
+     ;; GNA.  Guess who spelt "flavor" correctly first time round?
+     ;; There's a strong argument in my mind to change all uses of
+     ;; "flavor" to "kind": and similarly with some misguided uses of
+     ;; "type" here and there.  -- CSR, 2005-01-06.
+     (case (fixup-flavor thing)
+       ((:foreign-dataref) :qword)))
      (t
       nil)))
  
      (t
       nil)))
  
@@ -964,13 +1189,17 @@
    ;; immediate to register
    (:printer reg ((op #b1011) (imm nil :type 'imm-data))
             '(:name :tab reg ", " imm))
    ;; immediate to register
    (:printer reg ((op #b1011) (imm nil :type 'imm-data))
             '(:name :tab reg ", " imm))
+  (:printer rex-reg ((op #b10111) (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)))
    ;; 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)))
+  (:printer rex-reg-reg/mem-dir ((op #b100010)))
    ;; immediate to register/memory
    (:printer reg/mem-imm ((op '(#b1100011 #b000))))
    ;; immediate to register/memory
    (:printer reg/mem-imm ((op '(#b1100011 #b000))))
+  (:printer rex-reg/mem-imm ((op '(#b1100011 #b000))))
  
    (:emitter
     (let ((size (matching-operand-size dst src)))
  
    (:emitter
     (let ((size (matching-operand-size dst src)))
@@ -984,14 +1213,6 @@
                                            #b10111)
                                        (reg-tn-encoding dst))
                    (emit-sized-immediate segment size src (eq size :qword)))
                                            #b10111)
                                        (reg-tn-encoding dst))
                    (emit-sized-immediate segment size src (eq size :qword)))
-                 ((and (fixup-p src) (accumulator-p dst))
-                  (maybe-emit-rex-prefix segment (operand-size src)
-                                         nil nil nil)
-                  (emit-byte segment
-                             (if (eq size :byte)
-                                 #b10100000
-                                 #b10100001))
-                  (emit-absolute-fixup segment src (eq size :qword)))
                   (t
                    (maybe-emit-rex-for-ea segment src dst)
                    (emit-byte segment
                   (t
                    (maybe-emit-rex-for-ea segment src dst)
                    (emit-byte segment
@@ -999,10 +1220,6 @@
                                   #b10001010
                                   #b10001011))
                    (emit-ea segment src (reg-tn-encoding dst) t))))
                                   #b10001010
                                   #b10001011))
                    (emit-ea segment src (reg-tn-encoding dst) t))))
-          ((and (fixup-p dst) (accumulator-p src))
-           (maybe-emit-rex-prefix segment size nil nil nil)
-           (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
-           (emit-absolute-fixup segment dst (eq size :qword)))
            ((integerp src)
             ;; C7 only deals with 32 bit immediates even if register is 
             ;; 64 bit: only b8-bf use 64 bit immediates
            ((integerp src)
             ;; C7 only deals with 32 bit immediates even if register is 
             ;; 64 bit: only b8-bf use 64 bit immediates
@@ -1021,6 +1238,15 @@
             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
             (emit-ea segment dst (reg-tn-encoding src)))
            ((fixup-p src)
             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
             (emit-ea segment dst (reg-tn-encoding src)))
            ((fixup-p src)
+           ;; Generally we can't MOV a fixupped value into an EA, since
+           ;; MOV on non-registers can only take a 32-bit immediate arg.
+           ;; Make an exception for :FOREIGN fixups (pretty much just
+           ;; the runtime asm, since other foreign calls go through the
+           ;; the linkage table) and for linkage table references, since
+           ;; these should always end up in low memory.
+           (aver (or (eq (fixup-flavor src) :foreign)
+                     (eq (fixup-flavor src) :foreign-dataref)
+                     (eq (ea-size dst) :dword)))
             (maybe-emit-rex-for-ea segment dst nil)
             (emit-byte segment #b11000111)
             (emit-ea segment dst #b000)
             (maybe-emit-rex-for-ea segment dst nil)
             (emit-byte segment #b11000111)
             (emit-ea segment dst #b000)
@@ -1044,12 +1270,14 @@
         (ecase src-size
          (:byte
           (maybe-emit-operand-size-prefix segment :dword)
         (ecase src-size
          (:byte
           (maybe-emit-operand-size-prefix segment :dword)
-         (maybe-emit-rex-for-ea segment src dst)
+         (maybe-emit-rex-for-ea segment src dst
+                                :operand-size (operand-size dst))
           (emit-byte segment #b00001111)
           (emit-byte segment opcode)
           (emit-ea segment src (reg-tn-encoding dst)))
          (:word
           (emit-byte segment #b00001111)
           (emit-byte segment opcode)
           (emit-ea segment src (reg-tn-encoding dst)))
          (:word
-         (maybe-emit-rex-for-ea segment src dst)
+         (maybe-emit-rex-for-ea segment src dst
+                                :operand-size (operand-size dst))
           (emit-byte segment #b00001111)
           (emit-byte segment (logior opcode 1))
           (emit-ea segment src (reg-tn-encoding dst)))
           (emit-byte segment #b00001111)
           (emit-byte segment (logior opcode 1))
           (emit-ea segment src (reg-tn-encoding dst)))
@@ -1080,14 +1308,16 @@
  
  ;;; this is not a real amd64 instruction, of course
  (define-instruction movzxd (segment dst src)
  
  ;;; this is not a real amd64 instruction, of course
  (define-instruction movzxd (segment dst src)
-  (:printer reg-reg/mem ((op #x63) (reg nil :type 'word-reg)))
+  ; (:printer reg-reg/mem ((op #x63) (reg nil :type 'word-reg)))
    (:emitter (emit-move-with-extension segment dst src nil)))
  
  (define-instruction push (segment src)
    ;; register
    (:printer reg-no-width ((op #b01010)))
    (:emitter (emit-move-with-extension segment dst src nil)))
  
  (define-instruction push (segment src)
    ;; register
    (:printer reg-no-width ((op #b01010)))
+  (:printer rex-reg-no-width ((op #b01010)))
    ;; register/memory
    (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
    ;; register/memory
    (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
+  (:printer rex-reg/mem ((op '(#b11111111 #b110))))
    ;; immediate
    (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
             '(:name :tab imm))
    ;; immediate
    (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
             '(:name :tab imm))
@@ -1105,10 +1335,6 @@
                  ;; whether it expects 32 or 64 bit immediate here
                  (emit-byte segment #b01101000)
                  (emit-dword segment src))))
                  ;; whether it expects 32 or 64 bit immediate here
                  (emit-byte segment #b01101000)
                  (emit-dword segment src))))
-        ((fixup-p src)
-         ;; Interpret the fixup as an immediate dword to push.
-         (emit-byte segment #b01101000)
-         (emit-absolute-fixup segment src))
          (t
           (let ((size (operand-size src)))
             (aver (not (eq size :byte)))
          (t
           (let ((size (operand-size src)))
             (aver (not (eq size :byte)))
@@ -1127,7 +1353,9 @@
  
  (define-instruction pop (segment dst)
    (:printer reg-no-width ((op #b01011)))
  
  (define-instruction pop (segment dst)
    (:printer reg-no-width ((op #b01011)))
+  (:printer rex-reg-no-width ((op #b01011)))
    (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
    (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
+  (:printer rex-reg/mem ((op '(#b10001111 #b000))))
    (:emitter
     (let ((size (operand-size dst)))
       (aver (not (eq size :byte)))
    (:emitter
     (let ((size (operand-size dst)))
       (aver (not (eq size :byte)))
@@ -1154,11 +1382,14 @@
       (maybe-emit-operand-size-prefix segment size)
       (labels ((xchg-acc-with-something (acc something)
                 (if (and (not (eq size :byte)) (register-p something))
       (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))
+                   (progn
+                     (maybe-emit-rex-for-ea segment acc something)
+                     (emit-byte-with-reg segment
+                                         #b10010
+                                         (reg-tn-encoding something)))
                     (xchg-reg-with-something acc something)))
               (xchg-reg-with-something (reg something)
                     (xchg-reg-with-something acc something)))
               (xchg-reg-with-something (reg something)
+               (maybe-emit-rex-for-ea segment something reg)
                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
                 (emit-ea segment something (reg-tn-encoding reg))))
         (cond ((accumulator-p operand1)
                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
                 (emit-ea segment something (reg-tn-encoding reg))))
         (cond ((accumulator-p operand1)
@@ -1173,10 +1404,12 @@
               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
  
  (define-instruction lea (segment dst src)
               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
  
  (define-instruction lea (segment dst src)
+  (:printer rex-reg-reg/mem ((op #b10001101)))
    (:printer reg-reg/mem ((op #b1000110) (width 1)))
    (:emitter
    (:printer reg-reg/mem ((op #b1000110) (width 1)))
    (:emitter
-   (aver (or  (dword-reg-p dst)  (qword-reg-p dst)))
-   (maybe-emit-rex-for-ea segment src dst)
+   (aver (or (dword-reg-p dst) (qword-reg-p dst)))
+   (maybe-emit-rex-for-ea segment src dst
+                         :operand-size :qword)
     (emit-byte segment #b10001101)
     (emit-ea segment src (reg-tn-encoding dst))))
  
     (emit-byte segment #b10001101)
     (emit-ea segment src (reg-tn-encoding dst))))
  
@@ -1279,7 +1512,8 @@
              (emit-byte segment #b10000011)
              (emit-ea segment dst opcode allow-constants)
              (emit-byte segment src))
              (emit-byte segment #b10000011)
              (emit-ea segment dst opcode allow-constants)
              (emit-byte segment src))
-           ((accumulator-p dst)
+           ((accumulator-p dst)  
+            (maybe-emit-rex-for-ea segment dst nil)
              (emit-byte segment
                         (dpb opcode
                              (byte 3 3)
              (emit-byte segment
                         (dpb opcode
                              (byte 3 3)
@@ -1312,10 +1546,15 @@
  (eval-when (:compile-toplevel :execute)
    (defun arith-inst-printer-list (subop)
      `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
  (eval-when (:compile-toplevel :execute)
    (defun arith-inst-printer-list (subop)
      `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
+      (rex-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
        (reg/mem-imm ((op (#b1000000 ,subop))))
        (reg/mem-imm ((op (#b1000000 ,subop))))
+      (rex-reg/mem-imm ((op (#b10000001 ,subop))))
        (reg/mem-imm ((op (#b1000001 ,subop))
                     (imm nil :type signed-imm-byte)))
        (reg/mem-imm ((op (#b1000001 ,subop))
                     (imm nil :type signed-imm-byte)))
-      (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
+      (rex-reg/mem-imm ((op (#b10000011 ,subop))
+                   (imm nil :type signed-imm-byte)))
+      (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
+      (rex-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
    )
  
  (define-instruction add (segment dst src)
    )
  
  (define-instruction add (segment dst src)
@@ -1339,7 +1578,10 @@
    (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
  
  (define-instruction inc (segment dst)
    (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
  
  (define-instruction inc (segment dst)
+  ;; Register
+  (:printer modrm-reg-no-width ((modrm-reg #b000)))
    ;; Register/Memory
    ;; Register/Memory
+  ;; (:printer rex-reg/mem ((op '(#b11111111 #b001))))
    (:printer reg/mem ((op '(#b1111111 #b000))))
    (:emitter
     (let ((size (operand-size dst)))
    (:printer reg/mem ((op '(#b1111111 #b000))))
    (:emitter
     (let ((size (operand-size dst)))
@@ -1354,13 +1596,14 @@
  
  (define-instruction dec (segment dst)
    ;; Register.
  
  (define-instruction dec (segment dst)
    ;; Register.
-  (:printer reg-no-width ((op #b01001)))
+  (:printer modrm-reg-no-width ((modrm-reg #b001)))
    ;; Register/Memory
    (:printer reg/mem ((op '(#b1111111 #b001))))
    (:emitter
     (let ((size (operand-size dst)))
       (maybe-emit-operand-size-prefix segment size)
    ;; Register/Memory
    (:printer reg/mem ((op '(#b1111111 #b001))))
    (:emitter
     (let ((size (operand-size dst)))
       (maybe-emit-operand-size-prefix segment size)
-     (cond ((and (not (eq size :byte)) (register-p dst))
+     (cond #+nil
+          ((and (not (eq size :byte)) (register-p dst))
             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
            (t
             (maybe-emit-rex-for-ea segment dst nil)
             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
            (t
             (maybe-emit-rex-for-ea segment dst nil)
@@ -1376,26 +1619,6 @@
       (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
       (emit-ea segment dst #b011))))
  
       (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
  (define-instruction mul (segment dst src)
    (:printer accum-reg/mem ((op '(#b1111011 #b100))))
    (:emitter
@@ -1471,19 +1694,6 @@
       (emit-byte segment #x0f)
       (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst)))))
  
       (emit-byte segment #x0f)
       (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst)))))
  
-
-(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
  ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
  (define-instruction cbw (segment)
    (:emitter
@@ -1511,7 +1721,6 @@
  
  ;;; CQO -- Convert Quad or Octaword. RDX:RAX <- sign_xtnd(RAX)
  (define-instruction cqo (segment)
  
  ;;; CQO -- Convert Quad or Octaword. RDX:RAX <- sign_xtnd(RAX)
  (define-instruction cqo (segment)
-  (:printer byte ((op #b10011001)))
    (:emitter
     (maybe-emit-rex-prefix segment :qword nil nil nil)
     (emit-byte segment #b10011001)))
    (:emitter
     (maybe-emit-rex-prefix segment :qword nil nil nil)
     (emit-byte segment #b10011001)))
@@ -1550,9 +1759,15 @@
    (defun shift-inst-printer-list (subop)
      `((reg/mem ((op (#b1101000 ,subop)))
                (:name :tab reg/mem ", 1"))
    (defun shift-inst-printer-list (subop)
      `((reg/mem ((op (#b1101000 ,subop)))
                (:name :tab reg/mem ", 1"))
+      (rex-reg/mem ((op (#b1101000 ,subop)))
+                  (:name :tab reg/mem ", 1"))
        (reg/mem ((op (#b1101001 ,subop)))
                (:name :tab reg/mem ", " 'cl))
        (reg/mem ((op (#b1101001 ,subop)))
                (:name :tab reg/mem ", " 'cl))
+      (rex-reg/mem ((op (#b1101001 ,subop)))
+              (:name :tab reg/mem ", " 'cl))
        (reg/mem-imm ((op (#b1100000 ,subop))
        (reg/mem-imm ((op (#b1100000 ,subop))
+                   (imm nil :type signed-imm-byte)))
+      (rex-reg/mem-imm ((op (#b11000001 ,subop))
                     (imm nil :type signed-imm-byte))))))
  
  (define-instruction rol (segment dst amount)
                     (imm nil :type signed-imm-byte))))))
  
  (define-instruction rol (segment dst amount)
@@ -1638,13 +1853,17 @@
  
  (define-instruction test (segment this that)
    (:printer accum-imm ((op #b1010100)))
  
  (define-instruction test (segment this that)
    (:printer accum-imm ((op #b1010100)))
+  (:printer rex-accum-imm ((op #b1010100)))
    (:printer reg/mem-imm ((op '(#b1111011 #b000))))
    (:printer reg/mem-imm ((op '(#b1111011 #b000))))
+  (:printer rex-reg/mem-imm ((op '(#b11110111 #b000))))
    (:printer reg-reg/mem ((op #b1000010)))
    (:printer reg-reg/mem ((op #b1000010)))
+  (:printer rex-reg-reg/mem ((op #b10000101)))
    (: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)
    (: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)
+                    (maybe-emit-rex-for-ea segment something nil)
                      (emit-byte segment
                                 (if (eq size :byte) #b10101000 #b10101001))
                      (emit-sized-immediate segment size immed))
                      (emit-byte segment
                                 (if (eq size :byte) #b10101000 #b10101001))
                      (emit-sized-immediate segment size immed))
@@ -1694,6 +1913,7 @@
  
  (define-instruction cmps (segment size)
    (:printer string-op ((op #b1010011)))
  
  (define-instruction cmps (segment size)
    (:printer string-op ((op #b1010011)))
+  (:printer rex-string-op ((op #b1010011)))
    (:emitter
     (maybe-emit-operand-size-prefix segment size)
     (maybe-emit-rex-prefix segment size nil nil nil)
    (:emitter
     (maybe-emit-operand-size-prefix segment size)
     (maybe-emit-rex-prefix segment size nil nil nil)
@@ -1701,6 +1921,7 @@
  
  (define-instruction ins (segment acc)
    (:printer string-op ((op #b0110110)))
  
  (define-instruction ins (segment acc)
    (:printer string-op ((op #b0110110)))
+  (:printer rex-string-op ((op #b0110110)))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
@@ -1710,6 +1931,7 @@
  
  (define-instruction lods (segment acc)
    (:printer string-op ((op #b1010110)))
  
  (define-instruction lods (segment acc)
    (:printer string-op ((op #b1010110)))
+  (:printer rex-string-op ((op #b1010110)))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
@@ -1719,6 +1941,7 @@
  
  (define-instruction movs (segment size)
    (:printer string-op ((op #b1010010)))
  
  (define-instruction movs (segment size)
    (:printer string-op ((op #b1010010)))
+  (:printer rex-string-op ((op #b1010010)))
    (:emitter
     (maybe-emit-operand-size-prefix segment size)
     (maybe-emit-rex-prefix segment size nil nil nil)
    (:emitter
     (maybe-emit-operand-size-prefix segment size)
     (maybe-emit-rex-prefix segment size nil nil nil)
@@ -1726,6 +1949,7 @@
  
  (define-instruction outs (segment acc)
    (:printer string-op ((op #b0110111)))
  
  (define-instruction outs (segment acc)
    (:printer string-op ((op #b0110111)))
+  (:printer rex-string-op ((op #b0110111)))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
@@ -1735,6 +1959,7 @@
  
  (define-instruction scas (segment acc)
    (:printer string-op ((op #b1010111)))
  
  (define-instruction scas (segment acc)
    (:printer string-op ((op #b1010111)))
+  (:printer rex-string-op ((op #b1010111)))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
@@ -1744,6 +1969,7 @@
  
  (define-instruction stos (segment acc)
    (:printer string-op ((op #b1010101)))
  
  (define-instruction stos (segment acc)
    (:printer string-op ((op #b1010101)))
+  (:printer rex-string-op ((op #b1010101)))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
    (:emitter
     (let ((size (operand-size acc)))
       (aver (accumulator-p acc))
@@ -1853,6 +2079,7 @@
    (:emitter
     (typecase where
       (label
    (:emitter
     (typecase where
       (label
+      (maybe-emit-rex-for-ea segment where nil)
        (emit-byte segment #b11101000) ; 32 bit relative
        (emit-back-patch segment
                        4
        (emit-byte segment #b11101000) ; 32 bit relative
        (emit-back-patch segment
                        4
@@ -1861,9 +2088,11 @@
                                      (- (label-position where)
                                         (+ posn 4))))))
       (fixup
                                      (- (label-position where)
                                         (+ posn 4))))))
       (fixup
+      (maybe-emit-rex-for-ea segment where nil)
        (emit-byte segment #b11101000)
        (emit-relative-fixup segment where))
       (t
        (emit-byte segment #b11101000)
        (emit-relative-fixup segment where))
       (t
+      (maybe-emit-rex-for-ea segment where nil)
        (emit-byte segment #b11111111)
        (emit-ea segment where #b010)))))
  
        (emit-byte segment #b11111111)
        (emit-ea segment where #b010)))))
  
@@ -1925,6 +2154,7 @@
          (t
           (unless (or (ea-p where) (tn-p where))
                   (error "don't know what to do with ~A" where))
          (t
           (unless (or (ea-p where) (tn-p where))
                   (error "don't know what to do with ~A" where))
+         (maybe-emit-rex-for-ea segment where nil)
           (emit-byte segment #b11111111)
           (emit-ea segment where #b100)))))
  
           (emit-byte segment #b11111111)
           (emit-ea segment where #b100)))))
  
@@ -2860,4 +3090,286 @@
    (:emitter
     (emit-byte segment #b11011001)
     (emit-byte segment #b11101101)))
    (:emitter
     (emit-byte segment #b11011001)
     (emit-byte segment #b11101101)))
- 
\ No newline at end of file
+
+;; new xmm insns required by sse float 
+;; movsd andpd comisd comiss
+
+(define-instruction movsd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (cond ((typep src 'tn) 
+         (emit-byte segment #xf2)
+         (maybe-emit-rex-for-ea segment dst src)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x11)
+         (emit-ea segment dst (reg-tn-encoding src)))
+        (t
+         (emit-byte segment #xf2)
+         (maybe-emit-rex-for-ea segment src dst)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x10)
+         (emit-ea segment src (reg-tn-encoding dst))))))
+
+(define-instruction movss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (cond ((tn-p src)
+         (emit-byte segment #xf3)
+         (maybe-emit-rex-for-ea segment dst src)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x11)
+         (emit-ea segment dst (reg-tn-encoding src)))
+        (t
+         (emit-byte segment #xf3)
+         (maybe-emit-rex-for-ea segment src dst)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x10)
+         (emit-ea segment src (reg-tn-encoding dst))))))
+
+(define-instruction andpd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #x66)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x54)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction andps (segment dst src)
+  (:emitter
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x54)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction comisd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #x66)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2f)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction comiss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2f)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+;;  movd movq xorp xord
+
+;; we only do the xmm version of movd
+(define-instruction movd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (cond ((typep dst 'tn)
+         (emit-byte segment #x66)
+         (maybe-emit-rex-for-ea segment src dst)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x6e)
+         (emit-ea segment src (reg-tn-encoding dst)))
+        (t
+         (emit-byte segment #x66)
+         (maybe-emit-rex-for-ea segment dst src)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x7e)
+         (emit-ea segment dst (reg-tn-encoding src))))))
+
+(define-instruction movq (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (cond ((typep dst 'tn)
+         (emit-byte segment #xf3)
+         (maybe-emit-rex-for-ea segment src dst)
+         (emit-byte segment #x0f)
+         (emit-byte segment #x7e)
+         (emit-ea segment src (reg-tn-encoding dst)))
+        (t
+         (emit-byte segment #x66)
+         (maybe-emit-rex-for-ea segment dst src)
+         (emit-byte segment #x0f)
+         (emit-byte segment #xd6)
+         (emit-ea segment dst (reg-tn-encoding src))))))
+
+(define-instruction xorpd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #x66)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x57)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction xorps (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x57)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtsd2si (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2d)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtsd2ss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5a)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtss2si (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2d)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtss2sd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5a)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtsi2ss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2a)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtsi2sd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2a)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtdq2pd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #xe6)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvtdq2ps (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5b)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+;; CVTTSD2SI CVTTSS2SI
+
+(define-instruction cvttsd2si (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2c)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cvttss2si (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x2c)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction addsd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x58)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction addss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x58)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction divsd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5e)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction divss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5e)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction mulsd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x59)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction mulss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x59)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction subsd (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf2)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5c)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction subss (segment dst src)
+;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+  (:emitter
+   (emit-byte segment #xf3)
+   (maybe-emit-rex-for-ea segment src dst)
+   (emit-byte segment #x0f)
+   (emit-byte segment #x5c)
+   (emit-ea segment src (reg-tn-encoding dst))))
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp

index aa4944d..933b11c 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -48,6 +48,8 @@
  
  (defmacro make-ea-for-object-slot (ptr slot lowtag)
    `(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  
  (defmacro make-ea-for-object-slot (ptr slot lowtag)
    `(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
+(defmacro make-ea-for-object-slot-half (ptr slot lowtag)
+  `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
  
  (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
    `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
  
  (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
    `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
@@ -58,9 +60,10 @@
                  (not (typep ,value 
                              '(or (signed-byte 32) (unsigned-byte 32)))))
             (multiple-value-bind (lo hi) (dwords-for-quad ,value)
                  (not (typep ,value 
                              '(or (signed-byte 32) (unsigned-byte 32)))))
             (multiple-value-bind (lo hi) (dwords-for-quad ,value)
-             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) lo)
-             (inst mov (make-ea-for-object-slot ,ptr (floor (+ ,slot 0.5))
-                                                ,lowtag)   hi)))
+             (inst mov (make-ea-for-object-slot-half
+                        ,ptr ,slot ,lowtag) lo)
+             (inst mov (make-ea-for-object-slot-half
+                        ,ptr (+ ,slot 1/2) ,lowtag) hi)))
            (t
             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
  
            (t
             (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
  
@@ -150,10 +153,65 @@
  ;;; This macro should only be used inside a pseudo-atomic section,
  ;;; which should also cover subsequent initialization of the
  ;;; object.
  ;;; This macro should only be used inside a pseudo-atomic section,
  ;;; which should also cover subsequent initialization of the
  ;;; object.
+(defun allocation-tramp (alloc-tn size &optional ignored)
+  (declare (ignore ignored))
+  (inst push size)
+  (inst lea r13-tn (make-ea :qword
+                           :disp (make-fixup (extern-alien-name "alloc_tramp")
+                                             :foreign)))
+  (inst call r13-tn)
+  (inst pop alloc-tn)
+  (values))
+
+(defun allocation (alloc-tn size &optional ignored)
+  (declare (ignore ignored))
+  (let ((not-inline (gen-label))
+       (done (gen-label))
+       ;; Yuck.
+       (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
+       (free-pointer
+        (make-ea :qword :disp 
+                 #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
+                 #!-sb-thread (make-fixup (extern-alien-name "boxed_region")
+                                          :foreign)
+                 :scale 1))            ; thread->alloc_region.free_pointer
+       (end-addr 
+        (make-ea :qword :disp
+                 #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
+                 #!-sb-thread (make-fixup (extern-alien-name "boxed_region")
+                                          :foreign 8)
+                 :scale 1)))           ; thread->alloc_region.end_addr
+    (cond (in-elsewhere
+          (allocation-tramp alloc-tn size))
+         (t
+          (unless (and (tn-p size) (location= alloc-tn size))
+            (inst mov alloc-tn size))
+          #!+sb-thread (inst fs-segment-prefix)
+          (inst add alloc-tn free-pointer)
+          #!+sb-thread (inst fs-segment-prefix)
+          (inst cmp end-addr alloc-tn)
+          (inst jmp :be NOT-INLINE)
+          #!+sb-thread (inst fs-segment-prefix)
+          (inst xchg free-pointer alloc-tn)
+          (emit-label DONE)
+          (assemble (*elsewhere*)
+            (emit-label NOT-INLINE)
+            (cond ((numberp size)
+                   (allocation-tramp alloc-tn size))
+                  (t
+                   (inst sub alloc-tn free-pointer)
+                   (allocation-tramp alloc-tn alloc-tn)))
+            (inst jmp DONE))
+          (values)))))
+
+#+nil
  (defun allocation (alloc-tn size &optional ignored)
    (declare (ignore ignored))
    (inst push size)
  (defun allocation (alloc-tn size &optional ignored)
    (declare (ignore ignored))
    (inst push size)
-  (inst call (make-fixup (extern-alien-name "alloc_tramp") :foreign))
+  (inst lea r13-tn (make-ea :qword
+                           :disp (make-fixup (extern-alien-name "alloc_tramp")
+                                             :foreign)))
+  (inst call r13-tn)
    (inst pop alloc-tn)
    (values))
  
    (inst pop alloc-tn)
    (values))
  
@@ -167,7 +225,7 @@
      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
             ,result-tn)
      (inst lea ,result-tn
      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
             ,result-tn)
      (inst lea ,result-tn
-     (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
+         (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
      ,@forms))
  \f
  ;;;; error code
      ,@forms))
  \f
  ;;;; error code
diff --git a/src/compiler/x86-64/memory.lisp b/src/compiler/x86-64/memory.lisp

index ca8c2e2..bd529b2 100644 (file)
--- a/src/compiler/x86-64/memory.lisp
+++ b/src/compiler/x86-64/memory.lisp
@@ -95,28 +95,24 @@
  (define-vop (slot-set)
    (:args (object :scs (descriptor-reg))
          (value :scs (descriptor-reg any-reg immediate)))
  (define-vop (slot-set)
    (:args (object :scs (descriptor-reg))
          (value :scs (descriptor-reg any-reg immediate)))
+  (:temporary (:sc unsigned-reg) temp)
    (:variant-vars base lowtag)
    (:info offset)
    (:generator 4
       (if (sc-is value immediate)
          (let ((val (tn-value value)))
    (: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 :dword :base object
-                            :disp (- (* (+ base offset) n-word-bytes) lowtag))
-                   (fixnumize val)))
-            (symbol
-             (inst mov
-                   (make-ea :dword :base object
-                            :disp (- (* (+ base offset) n-word-bytes) lowtag))
-                   (+ nil-value (static-symbol-offset val))))
-            (character
-             (inst mov
-                   (make-ea :dword :base object
-                            :disp (- (* (+ base offset) n-word-bytes) lowtag))
-                   (logior (ash (char-code val) n-widetag-bits)
-                           base-char-widetag)))))
+          (move-immediate (make-ea :qword :base object
+                                   :disp (- (* (+ base offset) n-word-bytes)
+                                            lowtag))
+                          (etypecase val
+                            (integer
+                             (fixnumize val))
+                            (symbol
+                             (+ nil-value (static-symbol-offset val)))
+                            (character
+                             (logior (ash (char-code val) n-widetag-bits)
+                                     character-widetag)))
+                          temp))
          ;; Else, value not immediate.
          (storew value object (+ base offset) lowtag))))
  
          ;; Else, value not immediate.
          (storew value object (+ base offset) lowtag))))
  
diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp

index 856c7fe..7e750fb 100644 (file)
--- a/src/compiler/x86-64/move.lisp
+++ b/src/compiler/x86-64/move.lisp
@@ -24,14 +24,14 @@
         (load-symbol y val))
        (character
         (inst mov y (logior (ash (char-code val) n-widetag-bits)
         (load-symbol y val))
        (character
         (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                          base-char-widetag))))))
+                          character-widetag))))))
  
  (define-move-fun (load-number 1) (vop x y)
    ((immediate) (signed-reg unsigned-reg))
    (inst mov y (tn-value x)))
  
  
  (define-move-fun (load-number 1) (vop x y)
    ((immediate) (signed-reg unsigned-reg))
    (inst mov y (tn-value x)))
  
-(define-move-fun (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
+(define-move-fun (load-character 1) (vop x y)
+  ((immediate) (character-reg))
    (inst mov y (char-code (tn-value x))))
  
  (define-move-fun (load-system-area-pointer 1) (vop x y)
    (inst mov y (char-code (tn-value x))))
  
  (define-move-fun (load-system-area-pointer 1) (vop x y)
@@ -44,7 +44,7 @@
  
  (define-move-fun (load-stack 5) (vop x y)
    ((control-stack) (any-reg descriptor-reg)
  
  (define-move-fun (load-stack 5) (vop x y)
    ((control-stack) (any-reg descriptor-reg)
-   (base-char-stack) (base-char-reg)
+   (character-stack) (character-reg)
     (sap-stack) (sap-reg)
     (signed-stack) (signed-reg)
     (unsigned-stack) (unsigned-reg))
     (sap-stack) (sap-reg)
     (signed-stack) (signed-reg)
     (unsigned-stack) (unsigned-reg))
@@ -52,7 +52,7 @@
  
  (define-move-fun (store-stack 5) (vop x y)
    ((any-reg descriptor-reg) (control-stack)
  
  (define-move-fun (store-stack 5) (vop x y)
    ((any-reg descriptor-reg) (control-stack)
-   (base-char-reg) (base-char-stack)
+   (character-reg) (character-stack)
     (sap-reg) (sap-stack)
     (signed-reg) (signed-stack)
     (unsigned-reg) (unsigned-stack))
     (sap-reg) (sap-stack)
     (signed-reg) (signed-stack)
     (unsigned-reg) (unsigned-stack))
@@ -67,6 +67,7 @@
                (not (or (location= x y)
                         (and (sc-is x any-reg descriptor-reg immediate)
                              (sc-is y control-stack))))))
                (not (or (location= x y)
                         (and (sc-is x any-reg descriptor-reg immediate)
                              (sc-is y control-stack))))))
+  (:temporary (:sc unsigned-reg) temp)
    (:effects)
    (:affected)
    (:generator 0
    (:effects)
    (:affected)
    (:generator 0
@@ -77,19 +78,13 @@
             (integer
              (if (and (zerop val) (sc-is y any-reg descriptor-reg))
                  (inst xor y y)
             (integer
              (if (and (zerop val) (sc-is y any-reg descriptor-reg))
                  (inst xor y y)
-                (multiple-value-bind (lo hi) (dwords-for-quad (fixnumize val))
-                  (cond ((zerop hi)
-                         (inst mov y lo))
-                        (t
-                         (inst mov y hi)
-                         (inst shl y 32)
-                         (inst or y lo))))))
+                (move-immediate y (fixnumize val) temp)))
             (symbol
              (inst mov y (+ nil-value (static-symbol-offset val))))
             (character
              (inst mov y (logior (ash (char-code val) n-widetag-bits)
             (symbol
              (inst mov y (+ nil-value (static-symbol-offset val))))
             (character
              (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                                base-char-widetag)))))
-      (move y x))))
+                                character-widetag)))))
+       (move y x))))
  
  (define-move-vop move :move
    (any-reg descriptor-reg immediate)
  
  (define-move-vop move :move
    (any-reg descriptor-reg immediate)
@@ -100,6 +95,22 @@
  ;;; few of the values in a continuation to fall out.
  (primitive-type-vop move (:check) t)
  
  ;;; few of the values in a continuation to fall out.
  (primitive-type-vop move (:check) t)
  
+(defun move-immediate (target val &optional tmp-tn)
+  (cond
+    ;; If target is a register, we can just mov it there directly
+    ((and (tn-p target)
+         (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
+     (inst mov target val))
+    ;; Likewise if the value is small enough.
+    ((typep val '(signed-byte 31))
+     (inst mov target val))
+    ;; Otherwise go through the temporary register
+    (tmp-tn
+     (inst mov tmp-tn val)
+     (inst mov target tmp-tn))
+    (t
+     (error "~A is not a register, no temporary given, and immediate ~A too large" target val))))
+
  ;;; The MOVE-ARG VOP is used for moving descriptor values into
  ;;; another frame for argument or known value passing.
  ;;;
  ;;; The MOVE-ARG VOP is used for moving descriptor values into
  ;;; another frame for argument or known value passing.
  ;;;
@@ -124,16 +135,12 @@
                ((or (signed-byte 29) (unsigned-byte 29))
                 (inst mov y (fixnumize val)))
                (integer
                ((or (signed-byte 29) (unsigned-byte 29))
                 (inst mov y (fixnumize val)))
                (integer
-               (multiple-value-bind (lo hi)
-                   (dwords-for-quad (fixnumize val))
-                 (inst mov y hi)
-                 (inst shl y 32)
-                 (inst or y lo)))
+               (move-immediate y (fixnumize val)))
                (symbol
                 (load-symbol y val))
                (character
                 (inst mov y (logior (ash (char-code val) n-widetag-bits)
                (symbol
                 (load-symbol y val))
                (character
                 (inst mov y (logior (ash (char-code val) n-widetag-bits)
-                                   base-char-widetag)))))
+                                   character-widetag)))))
            (move y x)))
        ((control-stack)
         (if (sc-is x immediate)
            (move y x)))
        ((control-stack)
         (if (sc-is x immediate)
@@ -148,7 +155,7 @@
                             fp (tn-offset y)))
                    (character
                     (storew (logior (ash (char-code val) n-widetag-bits)
                             fp (tn-offset y)))
                    (character
                     (storew (logior (ash (char-code val) n-widetag-bits)
-                                   base-char-widetag)
+                                   character-widetag)
                             fp (tn-offset y))))
                ;; Lisp stack
                (etypecase val
                             fp (tn-offset y))))
                ;; Lisp stack
                (etypecase val
@@ -159,7 +166,7 @@
                           fp (- (1+ (tn-offset y)))))
                  (character
                   (storew (logior (ash (char-code val) n-widetag-bits)
                           fp (- (1+ (tn-offset y)))))
                  (character
                   (storew (logior (ash (char-code val) n-widetag-bits)
-                                 base-char-widetag)
+                                 character-widetag)
                           fp (- (1+ (tn-offset y))))))))
          (if (= (tn-offset fp) esp-offset)
              ;; C-call
                           fp (- (1+ (tn-offset y))))))))
          (if (= (tn-offset fp) esp-offset)
              ;; C-call
@@ -263,29 +270,6 @@
  
  ;;; 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.
  
  ;;; 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.
-;;;
-;;; KLUDGE: I assume this is suppressed in favor of the "faster inline
-;;; version" below. (See also mysterious comment "we don't want a VOP
-;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in
-;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916
-#+nil
-(define-vop (move-from-signed)
-  (:args (x :scs (signed-reg unsigned-reg) :target eax))
-  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
-  (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
-             ebx)
-  (:temporary (:sc unsigned-reg :offset ecx-offset
-                  :from (:argument 0) :to (:result 0)) ecx)
-  (:ignore ecx)
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:note "signed word to integer coercion")
-  (:generator 20
-    (move eax x)
-    (inst call (make-fixup 'move-from-signed :assembly-routine))
-    (move y ebx)))
-;;; Faster inline version,
-;;; KLUDGE: Do we really want the faster inline version? It's sorta big.
-;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916
  (define-vop (move-from-signed)
    (:args (x :scs (signed-reg unsigned-reg) :to :result))
    (:results (y :scs (any-reg descriptor-reg) :from :argument))
  (define-vop (move-from-signed)
    (:args (x :scs (signed-reg unsigned-reg) :to :result))
    (:results (y :scs (any-reg descriptor-reg) :from :argument))
@@ -342,7 +326,8 @@
          ;; 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.
          ;; 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)
+        (inst cmp y 63)
+        (inst jmp :l one-word-bignum)
          ;; two word bignum
          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
                                   n-widetag-bits)
          ;; two word bignum
          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
                                   n-widetag-bits)
diff --git a/src/compiler/x86-64/nlx.lisp b/src/compiler/x86-64/nlx.lisp

index 57e7748..f177bb2 100644 (file)
--- a/src/compiler/x86-64/nlx.lisp
+++ b/src/compiler/x86-64/nlx.lisp
@@ -79,8 +79,8 @@
      (load-tl-symbol-value temp *current-unwind-protect-block*)
      (storew temp block unwind-block-current-uwp-slot)
      (storew rbp-tn block unwind-block-current-cont-slot)
      (load-tl-symbol-value temp *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)))
+    (inst lea temp (make-fixup nil :code-object entry-label))
+    (storew temp 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
  
  ;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
  ;;; tag, and link the block into the CURRENT-CATCH list
@@ -95,8 +95,8 @@
      (load-tl-symbol-value temp *current-unwind-protect-block*)
      (storew temp block  unwind-block-current-uwp-slot)
      (storew rbp-tn block  unwind-block-current-cont-slot)
      (load-tl-symbol-value temp *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)
+    (inst lea temp (make-fixup nil :code-object entry-label))
+    (storew temp block catch-block-entry-pc-slot)
      (storew tag block catch-block-tag-slot)
      (load-tl-symbol-value temp *current-catch-block*)
      (storew temp block catch-block-previous-catch-slot)
      (storew tag block catch-block-tag-slot)
      (load-tl-symbol-value temp *current-catch-block*)
      (storew temp block catch-block-previous-catch-slot)
@@ -211,7 +211,7 @@
      ;; Copy them down.
      (inst std)
      (inst rep)
      ;; Copy them down.
      (inst std)
      (inst rep)
-    (inst movs :dword)
+    (inst movs :qword)
  
      DONE
      ;; Reset the CSP at last moved arg.
  
      DONE
      ;; Reset the CSP at last moved arg.
diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp

index ae33140..60d9d83 100644 (file)
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -99,18 +99,21 @@
  \f
  ;;;; description of the target address space
  
  \f
  ;;;; description of the target address space
  
-;;; where to put the different spaces.  untested (copied from x86, in fact)
+;;; where to put the different spaces.
  
  
+(def!constant read-only-space-start     #x20000000)
+(def!constant read-only-space-end       #x27ff0000)
  
  
-(def!constant read-only-space-start #x01000000)
-(def!constant read-only-space-end   #x037ff000)
+(def!constant static-space-start        #x40000000)
+(def!constant static-space-end          #x47fff000)
  
  
-(def!constant static-space-start    #x05000000)
-(def!constant static-space-end      #x07fff000)
+(def!constant dynamic-space-start   #x1000000000)
+(def!constant dynamic-space-end     #x11ffff0000)
  
  
-(def!constant dynamic-space-start   #x09000000)
-(def!constant dynamic-space-end     #x29000000)
+(def!constant linkage-table-space-start #x60000000)
+(def!constant linkage-table-space-end   #x63fff000)
  
  
+(def!constant linkage-table-entry-size 16)
  \f
  ;;;; other miscellaneous constants
  
  \f
  ;;;; other miscellaneous constants
  
@@ -169,6 +172,7 @@
      sub-gc
      sb!kernel::internal-error
      sb!kernel::control-stack-exhausted-error
      sub-gc
      sb!kernel::internal-error
      sb!kernel::control-stack-exhausted-error
+    sb!kernel::undefined-alien-error
      sb!di::handle-breakpoint
      fdefinition-object
      #!+sb-thread sb!thread::handle-thread-exit
      sb!di::handle-breakpoint
      fdefinition-object
      #!+sb-thread sb!thread::handle-thread-exit
diff --git a/src/compiler/x86-64/pred.lisp b/src/compiler/x86-64/pred.lisp

index 6babdd8..01d1d9a 100644 (file)
--- a/src/compiler/x86-64/pred.lisp
+++ b/src/compiler/x86-64/pred.lisp
@@ -33,6 +33,7 @@
          (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)))))
          (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)))))
+  (:temporary (:sc descriptor-reg) temp)
    (:conditional)
    (:info target not-p)
    (:policy :fast-safe)
    (:conditional)
    (:info target not-p)
    (:policy :fast-safe)
@@ -45,12 +46,18 @@
           (integer
            (if (and (zerop val) (sc-is x any-reg descriptor-reg))
                (inst test x x) ; smaller
           (integer
            (if (and (zerop val) (sc-is x any-reg descriptor-reg))
                (inst test x x) ; smaller
-            (inst cmp x (fixnumize val))))
+            (let ((fixnumized (fixnumize val)))
+              (if (typep fixnumized
+                         '(or (signed-byte 32) (unsigned-byte 31)))
+                  (inst cmp x fixnumized)
+                (progn
+                  (inst mov temp fixnumized)
+                  (inst cmp x temp))))))
           (symbol
            (inst cmp x (+ nil-value (static-symbol-offset val))))
           (character
            (inst cmp x (logior (ash (char-code val) n-widetag-bits)
           (symbol
            (inst cmp x (+ nil-value (static-symbol-offset val))))
           (character
            (inst cmp x (logior (ash (char-code val) n-widetag-bits)
-                              base-char-widetag))))))
+                              character-widetag))))))
       ((sc-is x immediate) ; and y not immediate
        ;; Swap the order to fit the compare instruction.
        (let ((val (tn-value x)))
       ((sc-is x immediate) ; and y not immediate
        ;; Swap the order to fit the compare instruction.
        (let ((val (tn-value x)))
@@ -58,12 +65,18 @@
           (integer
            (if (and (zerop val) (sc-is y any-reg descriptor-reg))
                (inst test y y) ; smaller
           (integer
            (if (and (zerop val) (sc-is y any-reg descriptor-reg))
                (inst test y y) ; smaller
-            (inst cmp y (fixnumize val))))
+            (let ((fixnumized (fixnumize val)))
+              (if (typep fixnumized
+                         '(or (signed-byte 32) (unsigned-byte 31)))
+                  (inst cmp y fixnumized)
+                (progn
+                  (inst mov temp fixnumized)
+                  (inst cmp y temp))))))
           (symbol
            (inst cmp y (+ nil-value (static-symbol-offset val))))
           (character
            (inst cmp y (logior (ash (char-code val) n-widetag-bits)
           (symbol
            (inst cmp y (+ nil-value (static-symbol-offset val))))
           (character
            (inst cmp y (logior (ash (char-code val) n-widetag-bits)
-                              base-char-widetag))))))
+                              character-widetag))))))
        (t
         (inst cmp x y)))
  
        (t
         (inst cmp x y)))
  
diff --git a/src/compiler/x86-64/sap.lisp b/src/compiler/x86-64/sap.lisp

index 2189b1e..0c7c99e 100644 (file)
--- a/src/compiler/x86-64/sap.lisp
+++ b/src/compiler/x86-64/sap.lisp
@@ -112,6 +112,7 @@
    (:results (res :scs (sap-reg) :from (:argument 0)
                  :load-if (not (location= ptr res))))
    (:result-types system-area-pointer)
    (:results (res :scs (sap-reg) :from (:argument 0)
                  :load-if (not (location= ptr res))))
    (:result-types system-area-pointer)
+  (:temporary (:sc signed-reg) temp)
    (:policy :fast-safe)
    (:generator 1
      (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
    (:policy :fast-safe)
    (:generator 1
      (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
@@ -120,15 +121,26 @@
              (signed-reg
               (inst lea res (make-ea :qword :base ptr :index offset :scale 1)))
              (immediate
              (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))))))
+             (let ((value (tn-value offset)))
+               (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
+                      (inst lea res (make-ea :qword :base ptr :disp value)))
+                     (t
+                      (inst mov temp value)
+                      (inst lea res (make-ea :qword :base ptr
+                                             :index temp
+                                             :scale 1))))))))
           (t
            (move res ptr)
            (sc-case offset
              (signed-reg
               (inst add res offset))
              (immediate
           (t
            (move res ptr)
            (sc-case offset
              (signed-reg
               (inst add res offset))
              (immediate
-             (inst add res (tn-value offset))))))))
+             (let ((value (tn-value offset)))
+               (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
+                      (inst add res (tn-value offset)))
+                     (t
+                      (inst mov temp value)
+                      (inst add res temp))))))))))
  
  (define-vop (pointer-)
    (:translate sap-)
  
  (define-vop (pointer-)
    (:translate sap-)
diff --git a/src/compiler/x86-64/show.lisp b/src/compiler/x86-64/show.lisp

index bc475e4..f0e0201 100644 (file)
--- a/src/compiler/x86-64/show.lisp
+++ b/src/compiler/x86-64/show.lisp
@@ -22,11 +22,16 @@
                :from :eval
                :to (:result 0))
               rax)
                :from :eval
                :to (:result 0))
               rax)
+  (:temporary (:sc unsigned-reg) call-target)
    (:results (result :scs (descriptor-reg)))
    (:save-p t)
    (:generator 100
      (inst push object)
      (inst lea rax (make-fixup (extern-alien-name "debug_print") :foreign))
    (:results (result :scs (descriptor-reg)))
    (:save-p t)
    (:generator 100
      (inst push object)
      (inst lea rax (make-fixup (extern-alien-name "debug_print") :foreign))
-    (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
+    (inst lea call-target
+         (make-ea :qword
+                  :disp (make-fixup (extern-alien-name "call_into_c")
+                                    :foreign)))
+    (inst call call-target)
      (inst add rsp-tn n-word-bytes)
      (move result rax)))
      (inst add rsp-tn n-word-bytes)
      (move result rax)))
diff --git a/src/compiler/x86-64/static-fn.lisp b/src/compiler/x86-64/static-fn.lisp

index 1842dff..20e808e 100644 (file)
--- a/src/compiler/x86-64/static-fn.lisp
+++ b/src/compiler/x86-64/static-fn.lisp
@@ -71,6 +71,7 @@
                     static-fun-template)
         (:args ,@(args))
         ,@(temps)
                     static-fun-template)
         (:args ,@(args))
         ,@(temps)
+       (:temporary (:sc unsigned-reg) call-target)
         (:results ,@(results))
         (:generator ,(+ 50 num-args num-results)
          ,@(moves (temp-names) (arg-names))
         (:results ,@(results))
         (:generator ,(+ 50 num-args num-results)
          ,@(moves (temp-names) (arg-names))
@@ -111,9 +112,14 @@
          ;; longer executed? Does it not depend on the
          ;; 1+3=4=fdefn_raw_address_offset relationship above?
          ;; Is something else going on?)
          ;; longer executed? Does it not depend on the
          ;; 1+3=4=fdefn_raw_address_offset relationship above?
          ;; Is something else going on?)
-        (inst call (make-ea :qword
-                            :disp (+ nil-value
-                                     (static-fun-offset function))))
+
+        ;; Need to load the target address into a register, since
+        ;; immediate call arguments are just a 32-bit displacement,
+        ;; which obviously can't work with >4G spaces.
+        (inst mov call-target
+              (make-ea :qword
+                       :disp (+ nil-value (static-fun-offset function))))
+        (inst call call-target)
          ,(collect ((bindings) (links))
                    (do ((temp (temp-names) (cdr temp))
                         (name 'values (gensym))
          ,(collect ((bindings) (links))
                    (do ((temp (temp-names) (cdr temp))
                         (name 'values (gensym))
diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp

index c9f111d..994ce44 100644 (file)
--- a/src/compiler/x86-64/system.lisp
+++ b/src/compiler/x86-64/system.lisp
@@ -121,7 +121,7 @@
                    :from (:argument 1) :to (:result 0)) eax)
    (:generator 6
      (move eax data)
                    :from (:argument 1) :to (:result 0)) eax)
    (:generator 6
      (move eax data)
-    (inst shl eax (- n-widetag-bits 2))
+    (inst shl eax (- n-widetag-bits n-fixnum-tag-bits))
      (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
      (storew eax x 0 other-pointer-lowtag)
      (move res x)))
      (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
      (storew eax x 0 other-pointer-lowtag)
      (move res x)))
@@ -142,7 +142,7 @@
    (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
    (:generator 2
      (move res val)
    (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
    (:generator 2
      (move res val)
-    (inst shl res (- n-widetag-bits 2))
+    (inst shl res (- n-widetag-bits n-fixnum-tag-bits))
      (inst or res (sc-case type
                    (unsigned-reg type)
                    (immediate (tn-value type))))))
      (inst or res (sc-case type
                    (unsigned-reg type)
                    (immediate (tn-value type))))))
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp

index dfd41ca..46d6bc2 100644 (file)
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -13,26 +13,24 @@
  \f
  ;;;; test generation utilities
  
  \f
  ;;;; test generation utilities
  
-;;; 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 make-byte-tn (tn)
+  (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg))
+  (make-random-tn :kind :normal
+                 :sc (sc-or-lose 'byte-reg)
+                 :offset (tn-offset tn)))
+
  (defun generate-fixnum-test (value)
    "zero flag set if VALUE is fixnum"
    (let ((offset (tn-offset value)))
  (defun generate-fixnum-test (value)
    "zero flag set if VALUE is fixnum"
    (let ((offset (tn-offset value)))
-    (cond ((and (sc-is value any-reg descriptor-reg)
-               (or (= offset eax-offset) (= offset ebx-offset)
-                   (= offset ecx-offset) (= offset edx-offset)))
-          (inst test (make-random-tn :kind :normal
-                                     :sc (sc-or-lose 'byte-reg)
-                                     :offset offset)
-                7))
-         ((sc-is value control-stack)
+    ;; The x86 backend uses a pun from E[A-D]X -> [A-D]L for these
+    ;; tests. The Athlon 64 optimization guide says that this is a 
+    ;; bad idea, so it's been removed.
+    (cond ((sc-is value control-stack)
            (inst test (make-ea :byte :base rbp-tn
                                :disp (- (* (1+ offset) n-word-bytes)))
            (inst test (make-ea :byte :base rbp-tn
                                :disp (- (* (1+ offset) n-word-bytes)))
-                7))
+                sb!vm::fixnum-tag-mask))
           (t
           (t
-          (inst test value 7)))))
+          (inst test value sb!vm::fixnum-tag-mask)))))
  
  (defun %test-fixnum (value target not-p)
    (generate-fixnum-test value)
  
  (defun %test-fixnum (value target not-p)
    (generate-fixnum-test value)
@@ -46,28 +44,21 @@
  
  (defun %test-immediate (value target not-p immediate)
    ;; Code a single instruction byte test if possible.
  
  (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)
-                                    :offset offset)
-                immediate))
-         (t
-          (move rax-tn value)
-          (inst cmp al-tn immediate))))
+  (cond ((sc-is value any-reg descriptor-reg)
+        (inst cmp (make-byte-tn value) immediate))
+       (t
+        (move rax-tn value)
+        (inst cmp al-tn immediate)))
    (inst jmp (if not-p :ne :e) target))
  
    (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)
+(defun %test-lowtag (value target not-p lowtag)
+  (move rax-tn value)
+  (inst and rax-tn lowtag-mask)
+  (inst cmp rax-tn lowtag)
    (inst jmp (if not-p :ne :e) target))
  
  (defun %test-headers (value target not-p function-p headers
    (inst jmp (if not-p :ne :e) target))
  
  (defun %test-headers (value target not-p function-p headers
-                           &optional (drop-through (gen-label)) al-loaded)
+                           &optional (drop-through (gen-label)))
    (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
      (multiple-value-bind (equal less-or-equal when-true when-false)
         ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
    (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
      (multiple-value-bind (equal less-or-equal when-true when-false)
         ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
@@ -76,7 +67,7 @@
         (if not-p
             (values :ne :a drop-through target)
             (values :e :na target drop-through))
         (if not-p
             (values :ne :a drop-through target)
             (values :e :na target drop-through))
-      (%test-lowtag value when-false t lowtag al-loaded)
+      (%test-lowtag value when-false t lowtag)
        (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
        (do ((remaining headers (cdr remaining)))
           ((null remaining))
        (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
        (do ((remaining headers (cdr remaining)))
           ((null remaining))
@@ -177,49 +168,151 @@
  
  (define-vop (signed-byte-32-p type-predicate)
    (:translate signed-byte-32-p)
  
  (define-vop (signed-byte-32-p type-predicate)
    (:translate signed-byte-32-p)
-  (:generator 45
-    ;; (and (fixnum) (no bits set >32))
+  (:generator 7
+    ;; (and (fixnum) (or (no bits set >31) (all bits set >31))
      (move rax-tn value)
      (inst test rax-tn 7)
      (inst jmp :ne (if not-p target not-target))
      (move rax-tn value)
      (inst test rax-tn 7)
      (inst jmp :ne (if not-p target not-target))
-    (inst sar rax-tn (+ 32 3))
-    (inst jmp (if not-p :nz :z) target)
+    (inst sar rax-tn (+ 32 3 -1))
+    (if not-p
+       (progn
+         (inst jmp :nz target)
+         (inst jmp not-target))
+       (inst jmp :z target))
+    (inst cmp rax-tn -1)
+    (inst jmp (if not-p :ne :eq) target)
      NOT-TARGET))
  
  (define-vop (check-signed-byte-32 check-type)
      NOT-TARGET))
  
  (define-vop (check-signed-byte-32 check-type)
-  (:generator 45
+  (:generator 8
      (let ((nope (generate-error-code vop
                                      object-not-signed-byte-32-error
      (let ((nope (generate-error-code vop
                                      object-not-signed-byte-32-error
-                                    value)))
+                                    value))
+         (ok (gen-label)))
        (move rax-tn value)
        (inst test rax-tn 7)
        (inst jmp :ne nope)
        (move rax-tn value)
        (inst test rax-tn 7)
        (inst jmp :ne nope)
-      (inst sar rax-tn (+ 32 3))
-      (inst jmp :nz nope)
+      (inst sar rax-tn (+ 32 3 -1))      
+      (inst jmp :z ok)
+      (inst cmp rax-tn -1)
+      (inst jmp :ne nope)
+      (emit-label OK)
        (move result value))))
  
  
  (define-vop (unsigned-byte-32-p type-predicate)
    (:translate unsigned-byte-32-p)
        (move result value))))
  
  
  (define-vop (unsigned-byte-32-p type-predicate)
    (:translate unsigned-byte-32-p)
-  (:generator 45
+  (:generator 7
      ;; (and (fixnum) (no bits set >31))
      (move rax-tn value)
      (inst test rax-tn 7)
      (inst jmp :ne (if not-p target not-target))
      ;; (and (fixnum) (no bits set >31))
      (move rax-tn value)
      (inst test rax-tn 7)
      (inst jmp :ne (if not-p target not-target))
-    (inst sar rax-tn (+ 32 3 -1))
+    (inst shr rax-tn (+ 32 sb!vm::n-fixnum-tag-bits))
      (inst jmp (if not-p :nz :z) target)
      NOT-TARGET))
  
  (define-vop (check-unsigned-byte-32 check-type)
      (inst jmp (if not-p :nz :z) target)
      NOT-TARGET))
  
  (define-vop (check-unsigned-byte-32 check-type)
-  (:generator 45
+  (:generator 8
      (let ((nope
            (generate-error-code vop object-not-unsigned-byte-32-error value)))
        (move rax-tn value)
        (inst test rax-tn 7)
        (inst jmp :ne nope)
      (let ((nope
            (generate-error-code vop object-not-unsigned-byte-32-error value)))
        (move rax-tn value)
        (inst test rax-tn 7)
        (inst jmp :ne nope)
-      (inst sar rax-tn (+ 32 3 -1))
+      (inst shr rax-tn (+ 32 sb!vm::n-fixnum-tag-bits))
        (inst jmp :nz nope)
        (move result value))))
        (inst jmp :nz nope)
        (move result value))))
+
+;;; An (unsigned-byte 64) 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.
+(define-vop (unsigned-byte-64-p type-predicate)
+  (:translate unsigned-byte-64-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 eax-tn value)
+       (inst jmp :e fixnum)
+
+       ;; If not, is it an other pointer?
+       (inst and eax-tn lowtag-mask)
+       (inst cmp eax-tn other-pointer-lowtag)
+       (inst jmp :ne nope)
+       ;; Get the header.
+       (loadw eax-tn value 0 other-pointer-lowtag)
+       ;; Is it one?
+       (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
+       (inst jmp :e single-word)
+       ;; If it's other than two, we can't be an (unsigned-byte 64)
+       (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
+       (inst jmp :ne nope)
+       ;; Get the second digit.
+       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
+       ;; All zeros, its an (unsigned-byte 64).
+       (inst or eax-tn eax-tn)
+       (inst jmp :z yep)
+       (inst jmp nope)
+       
+       (emit-label single-word)
+       ;; Get the single digit.
+       (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
+
+       ;; positive implies (unsigned-byte 64).
+       (emit-label fixnum)
+       (inst or eax-tn eax-tn)
+       (inst jmp (if not-p :s :ns) target)
+
+       (emit-label not-target)))))
+
+(define-vop (check-unsigned-byte-64 check-type)
+  (:generator 45
+    (let ((nope
+          (generate-error-code vop object-not-unsigned-byte-64-error value))
+         (yep (gen-label))
+         (fixnum (gen-label))
+         (single-word (gen-label)))
+
+      ;; Is it a fixnum?
+      (generate-fixnum-test value)
+      (move eax-tn value)
+      (inst jmp :e fixnum)
+
+      ;; If not, is it an other pointer?
+      (inst and eax-tn lowtag-mask)
+      (inst cmp eax-tn other-pointer-lowtag)
+      (inst jmp :ne nope)
+      ;; Get the header.
+      (loadw eax-tn value 0 other-pointer-lowtag)
+      ;; Is it one?
+      (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
+      (inst jmp :e single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 64)
+      (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
+      (inst jmp :ne nope)
+      ;; Get the second digit.
+      (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
+      ;; All zeros, its an (unsigned-byte 64).
+      (inst or eax-tn eax-tn)
+      (inst jmp :z yep)
+      (inst jmp nope)
+       
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
+
+      ;; positive implies (unsigned-byte 64).
+      (emit-label fixnum)
+      (inst or eax-tn eax-tn)
+      (inst jmp :s nope)
+
+      (emit-label yep)
+      (move result value))))
  \f
  ;;;; list/symbol types
  ;;;
  \f
  ;;;; list/symbol types
  ;;;
diff --git a/src/compiler/x86-64/values.lisp b/src/compiler/x86-64/values.lisp

index e833d7b..3250a4e 100644 (file)
--- a/src/compiler/x86-64/values.lisp
+++ b/src/compiler/x86-64/values.lisp
@@ -16,6 +16,35 @@
    (:generator 1
      (move rsp-tn ptr)))
  
    (:generator 1
      (move rsp-tn ptr)))
  
+(define-vop (%%nip-values)
+  (:args (last-nipped-ptr :scs (any-reg) :target rdi)
+         (last-preserved-ptr :scs (any-reg) :target rsi)
+         (moved-ptrs :scs (any-reg) :more t))
+  (:results (r-moved-ptrs :scs (any-reg) :more t)
+            ;; same as MOVED-PTRS
+            )
+  (:temporary (:sc any-reg :offset rsi-offset) rsi)
+  (:temporary (:sc any-reg :offset rdi-offset) rdi)
+  (:ignore r-moved-ptrs)
+  (:generator 1
+    (move rdi last-nipped-ptr)
+    (move rsi last-preserved-ptr)
+    (inst sub rsi n-word-bytes)
+    (inst sub rdi n-word-bytes)
+    (inst cmp rsp-tn rsi)
+    (inst jmp :a done)
+    (inst std)
+    LOOP
+    (inst movs :qword)
+    (inst cmp rsp-tn rsi)
+    (inst jmp :be loop)
+    DONE
+    (inst lea rsp-tn (make-ea :qword :base rdi :disp n-word-bytes))
+    (inst sub rdi rsi)
+    (loop for moved = moved-ptrs then (tn-ref-across moved)
+          while moved
+          do (inst add (tn-ref-tn moved) rdi))))
+
  ;;; 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.
  ;;; 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.
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp

index 341f7eb..fd8b94b 100644 (file)
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -18,11 +18,11 @@
  ;;;; register specs
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
  ;;;; register specs
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *byte-register-names* (make-array 8 :initial-element nil))
+  (defvar *byte-register-names* (make-array 32 :initial-element nil))
    (defvar *word-register-names* (make-array 16 :initial-element nil))
    (defvar *dword-register-names* (make-array 16 :initial-element nil))
    (defvar *qword-register-names* (make-array 32 :initial-element nil))
    (defvar *word-register-names* (make-array 16 :initial-element nil))
    (defvar *dword-register-names* (make-array 16 :initial-element nil))
    (defvar *qword-register-names* (make-array 32 :initial-element nil))
-  (defvar *xmm-register-names* (make-array 16 :initial-element nil)))
+  (defvar *float-register-names* (make-array 16 :initial-element nil)))
  
  (macrolet ((defreg (name offset size)
              (let ((offset-sym (symbolicate name "-OFFSET"))
  
  (macrolet ((defreg (name offset size)
              (let ((offset-sym (symbolicate name "-OFFSET"))
@@ -49,15 +49,29 @@
    ;; 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.
    ;; Note: the encoding here is different than that used by the chip.
    ;; We use this encoding so that the compiler thinks that AX (and
    ;; EAX) overlap AL and AH instead of AL and CL.
-  (defreg al 0 :byte)
-  (defreg ah 1 :byte)
-  (defreg cl 2 :byte)
-  (defreg ch 3 :byte)
-  (defreg dl 4 :byte)
-  (defreg dh 5 :byte)
-  (defreg bl 6 :byte)
-  (defreg bh 7 :byte)
-  (defregset *byte-regs* al ah cl ch dl dh bl bh)
+  ;;
+  ;; High-byte are registers disabled on AMD64, since they can't be
+  ;; encoded for an op that has a REX-prefix and we don't want to
+  ;; add special cases into the code generation. The overlap doesn't
+  ;; therefore exist anymore, but the numbering hasn't been changed
+  ;; to reflect this.
+  (defreg al    0 :byte)
+  (defreg cl    2 :byte)
+  (defreg dl    4 :byte)
+  (defreg bl    6 :byte)
+  (defreg sil  12 :byte)
+  (defreg dil  14 :byte)
+  (defreg r8b  16 :byte)
+  (defreg r9b  18 :byte)
+  (defreg r10b 20 :byte)
+  (defreg r11b 22 :byte)
+  (defreg r12b 24 :byte)
+  (defreg r13b 26 :byte)
+  (defreg r14b 28 :byte)
+  (defreg r15b 30 :byte)
+  (defregset *byte-regs*
+      al cl dl bl sil dil r8b r9b r10b
+      r11b #+nil r12b #+nil r13b r14b r15b)
  
    ;; word registers
    (defreg ax 0 :word)
  
    ;; word registers
    (defreg ax 0 :word)
@@ -102,24 +116,24 @@
              r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15)
  
    ;; floating point registers
              r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15)
  
    ;; floating point registers
-  (defreg xmm0 0 :float)
-  (defreg xmm1 1 :float)
-  (defreg xmm2 2 :float)
-  (defreg xmm3 3 :float)
-  (defreg xmm4 4 :float)
-  (defreg xmm5 5 :float)
-  (defreg xmm6 6 :float)
-  (defreg xmm7 7 :float)
-  (defreg xmm8 8 :float)
-  (defreg xmm9 9 :float)
-  (defreg xmm10 10 :float)
-  (defreg xmm11 11 :float)
-  (defreg xmm12 12 :float)
-  (defreg xmm13 13 :float)
-  (defreg xmm14 14 :float)
-  (defreg xmm15 15 :float)
-  (defregset *xmm-regs* xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7
-            xmm8 xmm9 xmm10 xmm11 xmm12 xmm13 xmm14 xmm15)
+  (defreg float0 0 :float)
+  (defreg float1 1 :float)
+  (defreg float2 2 :float)
+  (defreg float3 3 :float)
+  (defreg float4 4 :float)
+  (defreg float5 5 :float)
+  (defreg float6 6 :float)
+  (defreg float7 7 :float)
+  (defreg float8 8 :float)
+  (defreg float9 9 :float)
+  (defreg float10 10 :float)
+  (defreg float11 11 :float)
+  (defreg float12 12 :float)
+  (defreg float13 13 :float)
+  (defreg float14 14 :float)
+  (defreg float15 15 :float)
+  (defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7
+            float8 float9 float10 float11 float12 float13 float14 float15)
  
    ;; registers used to pass arguments
    ;;
  
    ;; registers used to pass arguments
    ;;
@@ -128,7 +142,8 @@
    ;; names and offsets for registers used to pass arguments
    (eval-when (:compile-toplevel :load-toplevel :execute)
      (defparameter *register-arg-names* '(rdx rdi rsi)))
    ;; names and offsets for registers used to pass arguments
    (eval-when (:compile-toplevel :load-toplevel :execute)
      (defparameter *register-arg-names* '(rdx rdi rsi)))
-  (defregset    *register-arg-offsets* rdx rdi rsi))
+  (defregset    *register-arg-offsets* rdx rdi rsi)
+  (defregset    *c-call-register-arg-offsets* rdi rsi rdx rcx r8 r9))
  \f
  ;;;; SB definitions
  
  \f
  ;;;; SB definitions
  
@@ -140,7 +155,7 @@
  ;;; words in a dword register.
  (define-storage-base registers :finite :size 32)
  
  ;;; words in a dword register.
  (define-storage-base registers :finite :size 32)
  
-(define-storage-base xmm-registers :finite :size 16)
+(define-storage-base float-registers :finite :size 16)
  
  (define-storage-base stack :unbounded :size 8)
  (define-storage-base constant :non-packed)
  
  (define-storage-base stack :unbounded :size 8)
  (define-storage-base constant :non-packed)
@@ -191,6 +206,9 @@
    ;; non-immediate constants in the constant pool
    (constant constant)
  
    ;; non-immediate constants in the constant pool
    (constant constant)
  
+  (fp-single-zero immediate-constant)
+  (fp-double-zero immediate-constant)
+
    (immediate immediate-constant)
  
    ;;
    (immediate immediate-constant)
  
    ;;
@@ -204,7 +222,7 @@
    ;; XXX alpha backend has :element-size 2 :alignment 2 in these entries
    (signed-stack stack)                 ; (signed-byte 32)
    (unsigned-stack stack)               ; (unsigned-byte 32)
    ;; XXX alpha backend has :element-size 2 :alignment 2 in these entries
    (signed-stack stack)                 ; (signed-byte 32)
    (unsigned-stack stack)               ; (unsigned-byte 32)
-  (base-char-stack stack)              ; non-descriptor characters.
+  (character-stack stack)              ; non-descriptor characters.
    (sap-stack stack)                    ; System area pointers.
    (single-stack stack)                 ; single-floats
    (double-stack stack)
    (sap-stack stack)                    ; System area pointers.
    (single-stack stack)                 ; single-floats
    (double-stack stack)
@@ -246,12 +264,14 @@
                   :alternate-scs (control-stack))
  
    ;; non-descriptor characters
                   :alternate-scs (control-stack))
  
    ;; non-descriptor characters
-  (base-char-reg registers
-                :locations #.*byte-regs*
-                :reserve-locations (#.ah-offset #.al-offset)
+  (character-reg registers
+                :locations #!-sb-unicode #.*byte-regs*
+                           #!+sb-unicode #.*qword-regs*
+                #!-sb-unicode #!-sb-unicode
+                :reserve-locations (#.al-offset)
                  :constant-scs (immediate)
                  :save-p t
                  :constant-scs (immediate)
                  :save-p t
-                :alternate-scs (base-char-stack))
+                :alternate-scs (character-stack))
  
    ;; non-descriptor SAPs (arbitrary pointers into address space)
    (sap-reg registers
  
    ;; non-descriptor SAPs (arbitrary pointers into address space)
    (sap-reg registers
@@ -293,27 +313,27 @@
    ;; that can go in the floating point registers
  
    ;; non-descriptor SINGLE-FLOATs
    ;; that can go in the floating point registers
  
    ;; non-descriptor SINGLE-FLOATs
-  (single-reg xmm-registers
-             :locations #.(loop for i from 0 to 15 collect i)
-             :constant-scs (fp-constant)
+  (single-reg float-registers
+             :locations #.(loop for i from 0 below 15 collect i)
+             :constant-scs (fp-single-zero)
               :save-p t
               :alternate-scs (single-stack))
  
    ;; non-descriptor DOUBLE-FLOATs
               :save-p t
               :alternate-scs (single-stack))
  
    ;; non-descriptor DOUBLE-FLOATs
-  (double-reg xmm-registers
-             :locations #.(loop for i from 0 to 15 collect i)
-             :constant-scs (fp-constant)
+  (double-reg float-registers
+             :locations #.(loop for i from 0 below 15 collect i)
+             :constant-scs (fp-double-zero)
               :save-p t
               :alternate-scs (double-stack))
  
               :save-p t
               :alternate-scs (double-stack))
  
-  (complex-single-reg xmm-registers
+  (complex-single-reg float-registers
                       :locations #.(loop for i from 0 to 14 by 2 collect i)
                       :element-size 2
                       :constant-scs ()
                       :save-p t
                       :alternate-scs (complex-single-stack))
  
                       :locations #.(loop for i from 0 to 14 by 2 collect i)
                       :element-size 2
                       :constant-scs ()
                       :save-p t
                       :alternate-scs (complex-single-stack))
  
-  (complex-double-reg xmm-registers
+  (complex-double-reg float-registers
                       :locations #.(loop for i from 0 to 14 by 2 collect i)
                       :element-size 2
                       :constant-scs ()
                       :locations #.(loop for i from 0 to 14 by 2 collect i)
                       :element-size 2
                       :constant-scs ()
@@ -324,12 +344,14 @@
    (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *byte-sc-names* '(base-char-reg byte-reg base-char-stack))
+(defparameter *byte-sc-names* 
+  '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
  (defparameter *word-sc-names* '(word-reg))
  (defparameter *dword-sc-names* '(dword-reg))
  (defparameter *qword-sc-names* 
    '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
  (defparameter *word-sc-names* '(word-reg))
  (defparameter *dword-sc-names* '(dword-reg))
  (defparameter *qword-sc-names* 
    '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
-    signed-stack unsigned-stack sap-stack single-stack constant))
+    signed-stack unsigned-stack sap-stack single-stack 
+    #!+sb-unicode character-reg #!+sb-unicode character-stack constant))
  ;;; added by jrd. I guess the right thing to do is to treat floats
  ;;; as a separate size...
  ;;;
  ;;; added by jrd. I guess the right thing to do is to treat floats
  ;;; as a separate size...
  ;;;
@@ -359,10 +381,11 @@
                     r8 r9 r10 r11  r12 r13 r14 r15)
    (def-misc-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
    (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
                     r8 r9 r10 r11  r12 r13 r14 r15)
    (def-misc-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
    (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
-  (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
+  (def-misc-reg-tns byte-reg al cl dl bl sil dil r8b r9b r10b
+                   r11b r14b r15b)
    (def-misc-reg-tns single-reg 
    (def-misc-reg-tns single-reg 
-      xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7
-      xmm8 xmm9 xmm10 xmm11 xmm12 xmm13 xmm14 xmm15))
+      float0 float1 float2 float3 float4 float5 float6 float7
+      float8 float9 float10 float11 float12 float13 float14 float15))
  
  ;;; TNs for registers used to pass arguments
  (defparameter *register-arg-tns*
  
  ;;; TNs for registers used to pass arguments
  (defparameter *register-arg-tns*
@@ -436,7 +459,7 @@
                   (svref name-vec offset))
              ;; FIXME: Shouldn't this be an ERROR?
              (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
                   (svref name-vec offset))
              ;; FIXME: Shouldn't this be an ERROR?
              (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
-      (float-registers (format nil "FR~D" offset))
+      (float-registers (format nil "FLOAT~D" offset))
        (stack (format nil "S~D" offset))
        (constant (format nil "Const~D" offset))
        (immediate-constant "Immed")
        (stack (format nil "S~D" offset))
        (constant (format nil "Const~D" offset))
        (immediate-constant "Immed")
@@ -446,14 +469,27 @@
  \f
  ;;; The loader uses this to convert alien names to the form they need in
  ;;; the symbol table (for example, prepending an underscore).
  \f
  ;;; The loader uses this to convert alien names to the form they need in
  ;;; the symbol table (for example, prepending an underscore).
+\f
+;;; The loader uses this to convert alien names to the form they need in
+;;; the symbol table (for example, prepending an underscore).
  (defun extern-alien-name (name)
  (defun extern-alien-name (name)
-  (declare (type simple-base-string name))
-  ;; OpenBSD is non-ELF, and needs a _ prefix
-  #!+openbsd (concatenate 'string "_" name)
-  ;; The other (ELF) ports currently don't need any prefix
-  #!-openbsd name)
+  (declare (type string name))
+  ;; ELF ports currently don't need any prefix
+  (typecase name
+    (simple-base-string name)
+    (base-string (coerce name 'simple-base-string))
+    (t (handler-case (coerce name 'simple-base-string)
+        (type-error () (error "invalid external alien name: ~S" name))))))
  
  (defun dwords-for-quad (value)
    (let* ((lo (logand value (1- (ash 1 32))))
  
  (defun dwords-for-quad (value)
    (let* ((lo (logand value (1- (ash 1 32))))
-        (hi (ash (- value lo) -32)))
+        (hi (ash value -32)))
      (values lo hi)))
      (values lo hi)))
+
+(defun words-for-dword (value)
+  (let* ((lo (logand value (1- (ash 1 16))))
+        (hi (ash value -16)))
+    (values lo hi)))
+
+(def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code
+
diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp

index 642a535..a0983c2 100644 (file)
--- a/src/compiler/x86/array.lisp
+++ b/src/compiler/x86/array.lisp
@@ -503,122 +503,7 @@
                           (inst fstd result))
                   (inst fxch value)))))))
  
                           (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 :dword :base index :index index :scale 2))
-    (with-empty-tn@fp-top(value)
-      (inst fldl (make-ea :dword :base object :index temp :scale 1
-                         :disp (- (* vector-data-offset
-                                     n-word-bytes)
-                                  other-pointer-lowtag))))))
  
  
-#!+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 :dword :base object
-                        :disp (- (+ (* vector-data-offset
-                                       n-word-bytes)
-                                    (* 12 index))
-                                 other-pointer-lowtag))))))
-
-#!+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 :dword :base index :index index :scale 2))
-    (cond ((zerop (tn-offset value))
-          ;; Value is in ST0.
-          (store-long-float
-           (make-ea :dword :base object :index temp :scale 1
-                    :disp (- (* vector-data-offset n-word-bytes)
-                             other-pointer-lowtag)))
-          (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 :dword :base object :index temp :scale 1
-                    :disp (- (* vector-data-offset n-word-bytes)
-                             other-pointer-lowtag)))
-          (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 :dword :base object
-                                     :disp (- (+ (* vector-data-offset
-                                                    n-word-bytes)
-                                                 (* 12 index))
-                                              other-pointer-lowtag)))
-          (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 :dword :base object
-                                     :disp (- (+ (* vector-data-offset
-                                                    n-word-bytes)
-                                                 (* 12 index))
-                                              other-pointer-lowtag)))
-          (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
  
  
  ;;; complex float variants
  
@@ -925,173 +810,7 @@
        (inst fxch value-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 :dword :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 :dword :base object :index temp :scale 2
-                           :disp (- (* vector-data-offset
-                                       n-word-bytes)
-                                    other-pointer-lowtag)))))
-    (let ((imag-tn (complex-long-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fldl (make-ea :dword :base object :index temp :scale 2
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       12)
-                                    other-pointer-lowtag)))))))
  
  
-#!+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 :dword :base object
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       (* 24 index))
-                                    other-pointer-lowtag)))))
-    (let ((imag-tn (complex-long-reg-imag-tn value)))
-      (with-empty-tn@fp-top (imag-tn)
-       (inst fldl (make-ea :dword :base object
-                           :disp (- (+ (* vector-data-offset
-                                          n-word-bytes)
-                                       (* 24 index) 12)
-                                    other-pointer-lowtag)))))))
-
-#!+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 :dword :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 :dword :base object :index temp :scale 2
-                      :disp (- (* vector-data-offset n-word-bytes)
-                               other-pointer-lowtag)))
-            (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 :dword :base object :index temp :scale 2
-                      :disp (- (* vector-data-offset n-word-bytes)
-                               other-pointer-lowtag)))
-            (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 :dword :base object :index temp :scale 2
-               :disp (- (+ (* vector-data-offset n-word-bytes) 12)
-                        other-pointer-lowtag)))
-      (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 :dword :base object
-                      :disp (- (+ (* vector-data-offset
-                                     n-word-bytes)
-                                  (* 24 index))
-                               other-pointer-lowtag)))
-            (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 :dword :base object
-                      :disp (- (+ (* vector-data-offset
-                                     n-word-bytes)
-                                  (* 24 index))
-                               other-pointer-lowtag)))
-            (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 :dword :base object
-               :disp (- (+ (* vector-data-offset
-                              n-word-bytes)
-                           ;; FIXME: There are so many of these bare constants
-                           ;; (24, 12..) in the LONG-FLOAT code that it's
-                           ;; ridiculous. I should probably just delete it all
-                           ;; instead of appearing to flirt with supporting
-                           ;; this maintenance nightmare.
-                           (* 24 index) 12)
-                        other-pointer-lowtag)))
-      (unless (location= value-imag result-imag)
-       (inst fstd result-imag))
-      (inst fxch value-imag))))
  \f
  ;;; unsigned-byte-8
  (macrolet ((define-data-vector-frobs (ptype)
  \f
  ;;; unsigned-byte-8
  (macrolet ((define-data-vector-frobs (ptype)
@@ -1378,7 +1097,7 @@
      simple-character-string vector-data-offset other-pointer-lowtag
      (character-reg) character data-vector-ref)
  #!+sb-unicode
      simple-character-string vector-data-offset other-pointer-lowtag
      (character-reg) character data-vector-ref)
  #!+sb-unicode
-(define-full-setter data-vector-ref/simple-character-string
+(define-full-setter data-vector-set/simple-character-string
      simple-character-string vector-data-offset other-pointer-lowtag
      (character-reg) character data-vector-set)
  
      simple-character-string vector-data-offset other-pointer-lowtag
      (character-reg) character data-vector-set)
  
@@ -1552,22 +1271,7 @@
  (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
    (:translate %raw-set-double)
    (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
  (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
    (:translate %raw-set-double)
    (:arg-types sb!c::raw-vector (: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 sb!c::raw-vector positive-fixnum))
-#!+long-float
-(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
-  (:translate %raw-ref-long)
-  (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
-#!+long-float
-(define-vop (raw-set-double data-vector-set/simple-array-long-float)
-  (:translate %raw-set-long)
-  (:arg-types sb!c::raw-vector 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 sb!c::raw-vector (:constant (signed-byte 30)) long-float))
+
  
  ;;;; complex-float raw structure slot accessors
  
  
  ;;;; complex-float raw structure slot accessors
  
@@ -1605,27 +1309,7 @@
    (:translate %raw-set-complex-double)
    (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
               complex-double-float))
    (:translate %raw-set-complex-double)
    (:arg-types sb!c::raw-vector (: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 sb!c::raw-vector 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 sb!c::raw-vector (: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 sb!c::raw-vector 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 sb!c::raw-vector (: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.
  
  ;;; These vops are useful for accessing the bits of a vector
  ;;; irrespective of what type of vector it is.
diff --git a/src/runtime/Config.x86_64-linux b/src/runtime/Config.x86_64-linux

index 7fefc14..f78a14d 100644 (file)
--- a/src/runtime/Config.x86_64-linux
+++ b/src/runtime/Config.x86_64-linux
@@ -7,9 +7,25 @@
  # provided with absolutely no warranty. See the COPYING and CREDITS
  # files for more information.
  
  # provided with absolutely no warranty. See the COPYING and CREDITS
  # files for more information.
  
-include Config.x86-linux
+ASSEM_SRC = x86-64-assem.S ldso-stubs.S
+ARCH_SRC = x86-64-arch.c
  
  
-# Until a 64-bit port is written, tell the compiler to use 32-bit mode
+OS_SRC = linux-os.c x86-64-linux-os.c os-common.c
+# The "--Wl,--export-dynamic" flags are here to help people
+# experimenting with callbacks from C to SBCL, by allowing linkage to
+# SBCL src/runtime/*.c symbols from C. Work on this is good, but it's
+# definitely bleeding edge and not particularly stable. In particular,
+# not only are the workarounds for the GC relocating Lisp code and
+# data unstable, but even the basic calling convention might end up
+# being unstable. Unless you want to do some masochistic maintenance
+# work when new releases of SBCL come out, please don't try to build
+# real code on this until a coherent stable interface has been added.
+# (You *are* encouraged to design and implement a coherent stable
+# interface, though.:-| As far as I (WHN 2002-05-19) know, no one is
+# working on one and it would be a nice thing to have.)
+OS_LINK_FLAGS = -Wl,--export-dynamic
+OS_LIBS = -ldl
+CFLAGS =  -g -Wall -O3 -fno-omit-frame-pointer
+
+GC_SRC = gencgc.c
  
  
-CFLAGS += -m32
-OS_LINK_FLAGS += -m32
diff --git a/src/runtime/backtrace.c b/src/runtime/backtrace.c

index 83a457f..d21e488 100644 (file)
--- a/src/runtime/backtrace.c
+++ b/src/runtime/backtrace.c
@@ -28,7 +28,7 @@
  #include "genesis/primitive-objects.h"
  #include "thread.h"
  
  #include "genesis/primitive-objects.h"
  #include "thread.h"
  
-#ifndef LISP_FEATURE_X86
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
  
  /* KLUDGE: Sigh ... I know what the call frame looks like and it had
   * better not change. */
  
  /* KLUDGE: Sigh ... I know what the call frame looks like and it had
   * better not change. */
diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c

index 63383f5..1227d43 100644 (file)
--- a/src/runtime/cheneygc.c
+++ b/src/runtime/cheneygc.c
@@ -90,19 +90,19 @@ zero_stack(void)
  
  
  void *
  
  
  void *
-gc_general_alloc(int bytes, int unboxed_p, int quick_p) {
+gc_general_alloc(long bytes, int unboxed_p, int quick_p) {
      lispobj *new=new_space_free_pointer;
      new_space_free_pointer+=(bytes/N_WORD_BYTES);
      return new;
  }
  
      lispobj *new=new_space_free_pointer;
      new_space_free_pointer+=(bytes/N_WORD_BYTES);
      return new;
  }
  
-lispobj  copy_large_unboxed_object(lispobj object, int nwords) {
+lispobj  copy_large_unboxed_object(lispobj object, long nwords) {
      return copy_object(object,nwords);
  }
      return copy_object(object,nwords);
  }
-lispobj  copy_unboxed_object(lispobj object, int nwords) {
+lispobj  copy_unboxed_object(lispobj object, long nwords) {
      return copy_object(object,nwords);
  }
      return copy_object(object,nwords);
  }
-lispobj  copy_large_object(lispobj object, int nwords) {
+lispobj  copy_large_object(lispobj object, long nwords) {
      return copy_object(object,nwords);
  }
  
      return copy_object(object,nwords);
  }
  
@@ -495,47 +495,9 @@ print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
  }
  
  \f
  }
  
  \f
-/* code and code-related objects */
-
-/* FIXME (1) this could probably be defined using something like
- *  sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
- *    -  FUN_POINTER_LOWTAG
- * as I'm reasonably sure that simple_fun->code must always be the 
- * last slot in the object 
-
- * FIXME (2) it also appears in purify.c, and it has a different value
- * for SPARC users in that bit
- */
-
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
-
-/* Note: on the sparc we don't have to do anything special for fdefns, */
-/* 'cause the raw-addr has a function lowtag. */
-#ifndef LISP_FEATURE_SPARC
-static int
-scav_fdefn(lispobj *where, lispobj object)
-{
-    struct fdefn *fdefn;
-
-    fdefn = (struct fdefn *)where;
-    
-    if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) 
-       == (char *)((unsigned long)(fdefn->raw_addr))) {
-        scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
-        fdefn->raw_addr =
-            (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
-        return sizeof(struct fdefn) / sizeof(lispobj);
-    }
-    else
-        return 1;
-}
-#endif
-
-
-\f
  /* vector-like objects */
  
  /* vector-like objects */
  
-static int
+static long
  scav_vector(lispobj *where, lispobj object)
  {
      if (HeaderValue(object) == subtype_VectorValidHashing) {
  scav_vector(lispobj *where, lispobj object)
  {
      if (HeaderValue(object) == subtype_VectorValidHashing) {
@@ -552,7 +514,7 @@ scav_vector(lispobj *where, lispobj object)
  #define WEAK_POINTER_NWORDS \
         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
  
  #define WEAK_POINTER_NWORDS \
         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
  
-static int
+static long
  scav_weak_pointer(lispobj *where, lispobj object)
  {
      /* Do not let GC scavenge the value slot of the weak pointer */
  scav_weak_pointer(lispobj *where, lispobj object)
  {
      /* Do not let GC scavenge the value slot of the weak pointer */
diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c

index 12da1cb..173ae05 100644 (file)
--- a/src/runtime/dynbind.c
+++ b/src/runtime/dynbind.c
@@ -21,6 +21,7 @@
  #include "genesis/symbol.h"
  #include "genesis/binding.h"
  #include "genesis/thread.h"
  #include "genesis/symbol.h"
  #include "genesis/binding.h"
  #include "genesis/thread.h"
+#include "genesis/static-symbols.h"
  
  #if defined(BINDING_STACK_POINTER)
  #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread))
  
  #if defined(BINDING_STACK_POINTER)
  #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread))
diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c

index a7d2034..ed70962 100644 (file)
--- a/src/runtime/gc-common.c
+++ b/src/runtime/gc-common.c
@@ -81,9 +81,9 @@ set_forwarding_pointer(lispobj * pointer, lispobj newspace_copy) {
      return newspace_copy;
  }
  
      return newspace_copy;
  }
  
-int (*scavtab[256])(lispobj *where, lispobj object);
+long (*scavtab[256])(lispobj *where, lispobj object);
  lispobj (*transother[256])(lispobj object);
  lispobj (*transother[256])(lispobj object);
-int (*sizetab[256])(lispobj *where);
+long (*sizetab[256])(lispobj *where);
  struct weak_pointer *weak_pointers;
  
  unsigned long bytes_consed_between_gcs = 12*1024*1024;
  struct weak_pointer *weak_pointers;
  
  unsigned long bytes_consed_between_gcs = 12*1024*1024;
@@ -95,7 +95,7 @@ unsigned long bytes_consed_between_gcs = 12*1024*1024;
  
  /* to copy a boxed object */
  lispobj
  
  /* to copy a boxed object */
  lispobj
-copy_object(lispobj object, int nwords)
+copy_object(lispobj object, long nwords)
  {
      int tag;
      lispobj *new;
  {
      int tag;
      lispobj *new;
@@ -115,7 +115,7 @@ copy_object(lispobj object, int nwords)
      return make_lispobj(new,tag);
  }
  
      return make_lispobj(new,tag);
  }
  
-static int scav_lose(lispobj *where, lispobj object); /* forward decl */
+static long scav_lose(lispobj *where, lispobj object); /* forward decl */
  
  /* FIXME: Most calls end up going to some trouble to compute an
   * 'n_words' value for this function. The system might be a little
  
  /* FIXME: Most calls end up going to some trouble to compute an
   * 'n_words' value for this function. The system might be a little
@@ -125,8 +125,9 @@ scavenge(lispobj *start, long n_words)
  {
      lispobj *end = start + n_words;
      lispobj *object_ptr;
  {
      lispobj *end = start + n_words;
      lispobj *object_ptr;
-    int n_words_scavenged;
+    long n_words_scavenged;
      for (object_ptr = start;
      for (object_ptr = start;
+
          object_ptr < end;
          object_ptr += n_words_scavenged) {
  
          object_ptr < end;
          object_ptr += n_words_scavenged) {
  
@@ -191,7 +192,7 @@ scavenge(lispobj *start, long n_words)
  static lispobj trans_fun_header(lispobj object); /* forward decls */
  static lispobj trans_boxed(lispobj object);
  
  static lispobj trans_fun_header(lispobj object); /* forward decls */
  static lispobj trans_boxed(lispobj object);
  
-static int
+static long
  scav_fun_pointer(lispobj *where, lispobj object)
  {
      lispobj *first_pointer;
  scav_fun_pointer(lispobj *where, lispobj object)
  {
      lispobj *first_pointer;
@@ -233,7 +234,7 @@ trans_code(struct code *code)
  {
      struct code *new_code;
      lispobj first, l_code, l_new_code;
  {
      struct code *new_code;
      lispobj first, l_code, l_new_code;
-    int nheader_words, ncode_words, nwords;
+    long nheader_words, ncode_words, nwords;
      unsigned long displacement;
      lispobj fheaderl, *prev_pointer;
  
      unsigned long displacement;
      lispobj fheaderl, *prev_pointer;
  
@@ -301,7 +302,7 @@ trans_code(struct code *code)
                 
         /* fix self pointer. */
         nfheaderp->self =
                 
         /* fix self pointer. */
         nfheaderp->self =
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
             FUN_RAW_ADDR_OFFSET +
  #endif
             nfheaderl; 
             FUN_RAW_ADDR_OFFSET +
  #endif
             nfheaderl; 
@@ -311,19 +312,19 @@ trans_code(struct code *code)
         fheaderl = fheaderp->next;
         prev_pointer = &nfheaderp->next;
      }
         fheaderl = fheaderp->next;
         prev_pointer = &nfheaderp->next;
      }
-    os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
-                   ncode_words * sizeof(int));
+    os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
+                   ncode_words * sizeof(long));
  #ifdef LISP_FEATURE_GENCGC
      gencgc_apply_code_fixups(code, new_code);
  #endif
      return new_code;
  }
  
  #ifdef LISP_FEATURE_GENCGC
      gencgc_apply_code_fixups(code, new_code);
  #endif
      return new_code;
  }
  
-static int
+static long
  scav_code_header(lispobj *where, lispobj object)
  {
      struct code *code;
  scav_code_header(lispobj *where, lispobj object)
  {
      struct code *code;
-    int n_header_words, n_code_words, n_words;
+    long n_header_words, n_code_words, n_words;
      lispobj entry_point;       /* tagged pointer to entry point */
      struct simple_fun *function_ptr; /* untagged pointer to entry point */
  
      lispobj entry_point;       /* tagged pointer to entry point */
      struct simple_fun *function_ptr; /* untagged pointer to entry point */
  
@@ -365,11 +366,11 @@ trans_code_header(lispobj object)
  }
  
  
  }
  
  
-static int
+static long
  size_code_header(lispobj *where)
  {
      struct code *code;
  size_code_header(lispobj *where)
  {
      struct code *code;
-    int nheader_words, ncode_words, nwords;
+    long nheader_words, ncode_words, nwords;
  
      code = (struct code *) where;
         
  
      code = (struct code *) where;
         
@@ -381,8 +382,8 @@ size_code_header(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-#ifndef LISP_FEATURE_X86
-static int
+#ifndef LISP_FEATURE_X86 || LISP_FEATURE_X86_64
+static long
  scav_return_pc_header(lispobj *where, lispobj object)
  {
      lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x",
  scav_return_pc_header(lispobj *where, lispobj object)
  {
      lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x",
@@ -416,8 +417,8 @@ trans_return_pc_header(lispobj object)
   * objects don't move, we don't need to update anything, but we do
   * have to figure out that the function is still live. */
  
   * objects don't move, we don't need to update anything, but we do
   * have to figure out that the function is still live. */
  
-#ifdef LISP_FEATURE_X86
-static int
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+static long
  scav_closure_header(lispobj *where, lispobj object)
  {
      struct closure *closure;
  scav_closure_header(lispobj *where, lispobj object)
  {
      struct closure *closure;
@@ -436,8 +437,8 @@ scav_closure_header(lispobj *where, lispobj object)
  }
  #endif
  
  }
  #endif
  
-#ifndef LISP_FEATURE_X86
-static int
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
+static long
  scav_fun_header(lispobj *where, lispobj object)
  {
      lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
  scav_fun_header(lispobj *where, lispobj object)
  {
      lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
@@ -470,7 +471,7 @@ trans_fun_header(lispobj object)
   * instances
   */
  
   * instances
   */
  
-static int
+static long
  scav_instance_pointer(lispobj *where, lispobj object)
  {
      lispobj copy, *first_pointer;
  scav_instance_pointer(lispobj *where, lispobj object)
  {
      lispobj copy, *first_pointer;
@@ -496,7 +497,7 @@ scav_instance_pointer(lispobj *where, lispobj object)
  
  static lispobj trans_list(lispobj object);
  
  
  static lispobj trans_list(lispobj object);
  
-static int
+static long
  scav_list_pointer(lispobj *where, lispobj object)
  {
      lispobj first, *first_pointer;
  scav_list_pointer(lispobj *where, lispobj object)
  {
      lispobj first, *first_pointer;
@@ -580,7 +581,7 @@ trans_list(lispobj object)
   * scavenging and transporting other pointers
   */
  
   * scavenging and transporting other pointers
   */
  
-static int
+static long
  scav_other_pointer(lispobj *where, lispobj object)
  {
      lispobj first, *first_pointer;
  scav_other_pointer(lispobj *where, lispobj object)
  {
      lispobj first, *first_pointer;
@@ -610,13 +611,13 @@ scav_other_pointer(lispobj *where, lispobj object)
   * immediate, boxed, and unboxed objects
   */
  
   * immediate, boxed, and unboxed objects
   */
  
-static int
+static long
  size_pointer(lispobj *where)
  {
      return 1;
  }
  
  size_pointer(lispobj *where)
  {
      return 1;
  }
  
-static int
+static long
  scav_immediate(lispobj *where, lispobj object)
  {
      return 1;
  scav_immediate(lispobj *where, lispobj object)
  {
      return 1;
@@ -629,14 +630,14 @@ trans_immediate(lispobj object)
      return NIL; /* bogus return value to satisfy static type checking */
  }
  
      return NIL; /* bogus return value to satisfy static type checking */
  }
  
-static int
+static long
  size_immediate(lispobj *where)
  {
      return 1;
  }
  
  
  size_immediate(lispobj *where)
  {
      return 1;
  }
  
  
-static int
+static long
  scav_boxed(lispobj *where, lispobj object)
  {
      return 1;
  scav_boxed(lispobj *where, lispobj object)
  {
      return 1;
@@ -658,7 +659,7 @@ trans_boxed(lispobj object)
  }
  
  
  }
  
  
-static int
+static long
  size_boxed(lispobj *where)
  {
      lispobj header;
  size_boxed(lispobj *where)
  {
      lispobj header;
@@ -674,7 +675,7 @@ size_boxed(lispobj *where)
  /* Note: on the sparc we don't have to do anything special for fdefns, */
  /* 'cause the raw-addr has a function lowtag. */
  #ifndef LISP_FEATURE_SPARC
  /* Note: on the sparc we don't have to do anything special for fdefns, */
  /* 'cause the raw-addr has a function lowtag. */
  #ifndef LISP_FEATURE_SPARC
-static int
+static long
  scav_fdefn(lispobj *where, lispobj object)
  {
      struct fdefn *fdefn;
  scav_fdefn(lispobj *where, lispobj object)
  {
      struct fdefn *fdefn;
@@ -702,7 +703,7 @@ scav_fdefn(lispobj *where, lispobj object)
  }
  #endif
  
  }
  #endif
  
-static int
+static long
  scav_unboxed(lispobj *where, lispobj object)
  {
      unsigned long length;
  scav_unboxed(lispobj *where, lispobj object)
  {
      unsigned long length;
@@ -729,7 +730,7 @@ trans_unboxed(lispobj object)
      return copy_unboxed_object(object, length);
  }
  
      return copy_unboxed_object(object, length);
  }
  
-static int
+static long
  size_unboxed(lispobj *where)
  {
      lispobj header;
  size_unboxed(lispobj *where)
  {
      lispobj header;
@@ -742,13 +743,13 @@ size_unboxed(lispobj *where)
      return length;
  }
  
      return length;
  }
  
-static int\f
+\f
  /* vector-like objects */
  /* vector-like objects */
-
+static long
  scav_base_string(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_base_string(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      /* NOTE: Strings contain one more byte of data than the length */
      /* slot indicates. */
  
      /* NOTE: Strings contain one more byte of data than the length */
      /* slot indicates. */
@@ -763,7 +764,7 @@ static lispobj
  trans_base_string(lispobj object)
  {
      struct vector *vector;
  trans_base_string(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -778,11 +779,11 @@ trans_base_string(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
-size_character_string(lispobj *where)
+static long
+size_base_string(lispobj *where)
  {
      struct vector *vector;
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      /* NOTE: A string contains one more byte of data (a terminating
       * '\0' to help when interfacing with C functions) than indicated
  
      /* NOTE: A string contains one more byte of data (a terminating
       * '\0' to help when interfacing with C functions) than indicated
@@ -790,11 +791,12 @@ size_character_string(lispobj *where)
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length) + 1;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length) + 1;
-    nwords = CEILING(NWORDS(length, 32) + 2, 2);
+    nwords = CEILING(NWORDS(length, 8) + 2, 2);
  
      return nwords;
  }
  
  
      return nwords;
  }
  
+static long
  scav_character_string(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_character_string(lispobj *where, lispobj object)
  {
      struct vector *vector;
@@ -828,8 +830,8 @@ trans_character_string(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
-size_base_string(lispobj *where)
+static long
+size_character_string(lispobj *where)
  {
      struct vector *vector;
      int length, nwords;
  {
      struct vector *vector;
      int length, nwords;
@@ -840,7 +842,7 @@ size_base_string(lispobj *where)
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length) + 1;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length) + 1;
-    nwords = CEILING(NWORDS(length, 8) + 2, 2);
+    nwords = CEILING(NWORDS(length, 32) + 2, 2);
  
      return nwords;
  }
  
      return nwords;
  }
@@ -849,7 +851,7 @@ static lispobj
  trans_vector(lispobj object)
  {
      struct vector *vector;
  trans_vector(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -861,11 +863,11 @@ trans_vector(lispobj object)
      return copy_large_object(object, nwords);
  }
  
      return copy_large_object(object, nwords);
  }
  
-static int
+static long
  size_vector(lispobj *where)
  {
      struct vector *vector;
  size_vector(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -874,7 +876,7 @@ size_vector(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-static int
+static long
  scav_vector_nil(lispobj *where, lispobj object)
  {
      return 2;
  scav_vector_nil(lispobj *where, lispobj object)
  {
      return 2;
@@ -887,18 +889,18 @@ trans_vector_nil(lispobj object)
      return copy_unboxed_object(object, 2);
  }
  
      return copy_unboxed_object(object, 2);
  }
  
-static int
+static long
  size_vector_nil(lispobj *where)
  {
      /* Just the header word and the length word */
      return 2;
  }
  
  size_vector_nil(lispobj *where)
  {
      /* Just the header word and the length word */
      return 2;
  }
  
-static int
+static long
  scav_vector_bit(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_bit(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -911,7 +913,7 @@ static lispobj
  trans_vector_bit(lispobj object)
  {
      struct vector *vector;
  trans_vector_bit(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -922,11 +924,11 @@ trans_vector_bit(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_bit(lispobj *where)
  {
      struct vector *vector;
  size_vector_bit(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -935,11 +937,11 @@ size_vector_bit(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-static int
+static long
  scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -952,7 +954,7 @@ static lispobj
  trans_vector_unsigned_byte_2(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_2(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -963,11 +965,11 @@ trans_vector_unsigned_byte_2(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_unsigned_byte_2(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_2(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -976,11 +978,11 @@ size_vector_unsigned_byte_2(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-static int
+static long
  scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -993,7 +995,7 @@ static lispobj
  trans_vector_unsigned_byte_4(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_4(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1003,11 +1005,11 @@ trans_vector_unsigned_byte_4(lispobj object)
  
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
-static int
+static long
  size_vector_unsigned_byte_4(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_4(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1017,11 +1019,11 @@ size_vector_unsigned_byte_4(lispobj *where)
  }
  
  
  }
  
  
-static int
+static long
  scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1038,7 +1040,7 @@ static lispobj
  trans_vector_unsigned_byte_8(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_8(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1049,11 +1051,11 @@ trans_vector_unsigned_byte_8(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_unsigned_byte_8(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_8(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1063,11 +1065,11 @@ size_vector_unsigned_byte_8(lispobj *where)
  }
  
  
  }
  
  
-static int
+static long
  scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1080,7 +1082,7 @@ static lispobj
  trans_vector_unsigned_byte_16(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_16(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1091,11 +1093,11 @@ trans_vector_unsigned_byte_16(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_unsigned_byte_16(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_16(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1104,11 +1106,11 @@ size_vector_unsigned_byte_16(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-static int
+static long
  scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1121,7 +1123,7 @@ static lispobj
  trans_vector_unsigned_byte_32(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_32(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1132,11 +1134,11 @@ trans_vector_unsigned_byte_32(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_unsigned_byte_32(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_32(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1146,11 +1148,11 @@ size_vector_unsigned_byte_32(lispobj *where)
  }
  
  #if N_WORD_BITS == 64
  }
  
  #if N_WORD_BITS == 64
-static int
+static long
  scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_unsigned_byte_64(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1163,7 +1165,7 @@ static lispobj
  trans_vector_unsigned_byte_64(lispobj object)
  {
      struct vector *vector;
  trans_vector_unsigned_byte_64(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1174,11 +1176,11 @@ trans_vector_unsigned_byte_64(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_unsigned_byte_64(lispobj *where)
  {
      struct vector *vector;
  size_vector_unsigned_byte_64(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1188,11 +1190,11 @@ size_vector_unsigned_byte_64(lispobj *where)
  }
  #endif
  
  }
  #endif
  
-static int
+static long
  scav_vector_single_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_single_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1205,7 +1207,7 @@ static lispobj
  trans_vector_single_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_single_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1216,11 +1218,11 @@ trans_vector_single_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_single_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_single_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1229,11 +1231,11 @@ size_vector_single_float(lispobj *where)
      return nwords;
  }
  
      return nwords;
  }
  
-static int
+static long
  scav_vector_double_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_double_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1246,7 +1248,7 @@ static lispobj
  trans_vector_double_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_double_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1257,11 +1259,11 @@ trans_vector_double_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_double_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_double_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1271,11 +1273,11 @@ size_vector_double_float(lispobj *where)
  }
  
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
  }
  
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
-static int
+static long
  scav_vector_long_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_long_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1289,7 +1291,7 @@ static lispobj
  trans_vector_long_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_long_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1300,11 +1302,11 @@ trans_vector_long_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_long_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_long_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1316,11 +1318,11 @@ size_vector_long_float(lispobj *where)
  
  
  #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
  
  
  #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
-static int
+static long
  scav_vector_complex_single_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_complex_single_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1333,7 +1335,7 @@ static lispobj
  trans_vector_complex_single_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_complex_single_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1344,11 +1346,11 @@ trans_vector_complex_single_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_complex_single_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_complex_single_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1359,11 +1361,11 @@ size_vector_complex_single_float(lispobj *where)
  #endif
  
  #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
  #endif
  
  #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
-static int
+static long
  scav_vector_complex_double_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_complex_double_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1376,7 +1378,7 @@ static lispobj
  trans_vector_complex_double_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_complex_double_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1387,11 +1389,11 @@ trans_vector_complex_double_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_complex_double_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_complex_double_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1403,11 +1405,11 @@ size_vector_complex_double_float(lispobj *where)
  
  
  #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
  
  
  #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
-static int
+static long
  scav_vector_complex_long_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
  scav_vector_complex_long_float(lispobj *where, lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1420,7 +1422,7 @@ static lispobj
  trans_vector_complex_long_float(lispobj object)
  {
      struct vector *vector;
  trans_vector_complex_long_float(lispobj object)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      gc_assert(is_lisp_pointer(object));
  
  
      gc_assert(is_lisp_pointer(object));
  
@@ -1431,11 +1433,11 @@ trans_vector_complex_long_float(lispobj object)
      return copy_large_unboxed_object(object, nwords);
  }
  
      return copy_large_unboxed_object(object, nwords);
  }
  
-static int
+static long
  size_vector_complex_long_float(lispobj *where)
  {
      struct vector *vector;
  size_vector_complex_long_float(lispobj *where)
  {
      struct vector *vector;
-    int length, nwords;
+    long length, nwords;
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
  
      vector = (struct vector *) where;
      length = fixnum_value(vector->length);
@@ -1476,7 +1478,7 @@ trans_weak_pointer(lispobj object)
      return copy;
  }
  
      return copy;
  }
  
-static int
+static long
  size_weak_pointer(lispobj *where)
  {
      return WEAK_POINTER_NWORDS;
  size_weak_pointer(lispobj *where)
  {
      return WEAK_POINTER_NWORDS;
@@ -1518,7 +1520,7 @@ void scan_weak_pointers(void)
   * initialization
   */
  
   * initialization
   */
  
-static int
+static long
  scav_lose(lispobj *where, lispobj object)
  {
      lose("no scavenge function for object 0x%08x (widetag 0x%x)",
  scav_lose(lispobj *where, lispobj object)
  {
      lose("no scavenge function for object 0x%08x (widetag 0x%x)",
@@ -1537,7 +1539,7 @@ trans_lose(lispobj object)
      return NIL; /* bogus return value to satisfy static type checking */
  }
  
      return NIL; /* bogus return value to satisfy static type checking */
  }
  
-static int
+static long
  size_lose(lispobj *where)
  {
      lose("no size function for object at 0x%08x (widetag 0x%x)",
  size_lose(lispobj *where)
  {
      lose("no size function for object at 0x%08x (widetag 0x%x)",
@@ -1554,7 +1556,7 @@ size_lose(lispobj *where)
  void
  gc_init_tables(void)
  {
  void
  gc_init_tables(void)
  {
-    int i;
+    long i;
  
      /* Set default value in all slots of scavenge table.  FIXME
       * replace this gnarly sizeof with something based on
  
      /* Set default value in all slots of scavenge table.  FIXME
       * replace this gnarly sizeof with something based on
@@ -1690,7 +1692,7 @@ gc_init_tables(void)
      scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
      scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
  #endif
      scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
      scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
  #endif
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
      scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
      scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
  #else
      scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
      scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
  #else
diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h

index 114f514..c5bb423 100644 (file)
--- a/src/runtime/gc-internal.h
+++ b/src/runtime/gc-internal.h
@@ -30,13 +30,13 @@
  
  #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
  
  
  #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
  
-static inline unsigned int
-NWORDS(unsigned int x, unsigned int n_bits)
+static inline unsigned long
+NWORDS(unsigned long x, unsigned long n_bits)
  {
      /* A good compiler should be able to constant-fold this whole thing,
         even with the conditional. */
      if(n_bits <= N_WORD_BITS) {
  {
      /* A good compiler should be able to constant-fold this whole thing,
         even with the conditional. */
      if(n_bits <= N_WORD_BITS) {
-        unsigned int elements_per_word = N_WORD_BITS/n_bits;
+        unsigned long elements_per_word = N_WORD_BITS/n_bits;
  
          return CEILING(x, elements_per_word)/elements_per_word;
      }
  
          return CEILING(x, elements_per_word)/elements_per_word;
      }
@@ -48,6 +48,17 @@ NWORDS(unsigned int x, unsigned int n_bits)
  }
  
  /* FIXME: Shouldn't this be defined in sbcl.h? */
  }
  
  /* FIXME: Shouldn't this be defined in sbcl.h? */
+
+/* FIXME (1) this could probably be defined using something like
+ *  sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
+ *    -  FUN_POINTER_LOWTAG
+ * as I'm reasonably sure that simple_fun->code must always be the 
+ * last slot in the object 
+
+ * FIXME (2) it also appears in purify.c, and it has a different value
+ * for SPARC users in that bit
+ */
+
  #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
  
  /* values for the *_alloc_* parameters */
  #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
  
  /* values for the *_alloc_* parameters */
@@ -60,21 +71,21 @@ NWORDS(unsigned int x, unsigned int n_bits)
  #define ALLOC_UNBOXED 1
  #define ALLOC_QUICK 1
  
  #define ALLOC_UNBOXED 1
  #define ALLOC_QUICK 1
  
-void *gc_general_alloc(int nbytes,int unboxed_p,int quick_p);
+void *gc_general_alloc(long nbytes,int unboxed_p,int quick_p);
  
  
-extern int (*scavtab[256])(lispobj *where, lispobj object);
+extern long (*scavtab[256])(lispobj *where, lispobj object);
  extern lispobj (*transother[256])(lispobj object);
  extern lispobj (*transother[256])(lispobj object);
-extern int (*sizetab[256])(lispobj *where);
+extern long (*sizetab[256])(lispobj *where);
  
  extern struct weak_pointer *weak_pointers; /* in gc-common.c */
  
  extern void scavenge(lispobj *start, long n_words);
  extern void scan_weak_pointers(void);
  
  
  extern struct weak_pointer *weak_pointers; /* in gc-common.c */
  
  extern void scavenge(lispobj *start, long n_words);
  extern void scan_weak_pointers(void);
  
-lispobj  copy_large_unboxed_object(lispobj object, int nwords);
-lispobj  copy_unboxed_object(lispobj object, int nwords);
-lispobj  copy_large_object(lispobj object, int nwords);
-lispobj  copy_object(lispobj object, int nwords);
+lispobj  copy_large_unboxed_object(lispobj object, long nwords);
+lispobj  copy_unboxed_object(lispobj object, long nwords);
+lispobj  copy_large_object(lispobj object, long nwords);
+lispobj  copy_object(lispobj object, long nwords);
  
  lispobj *search_read_only_space(void *pointer);
  lispobj *search_static_space(void *pointer);
  
  lispobj *search_read_only_space(void *pointer);
  lispobj *search_static_space(void *pointer);
diff --git a/src/runtime/gencgc-alloc-region.h b/src/runtime/gencgc-alloc-region.h

index 8e9dbed..da881b4 100644 (file)
--- a/src/runtime/gencgc-alloc-region.h
+++ b/src/runtime/gencgc-alloc-region.h
@@ -9,14 +9,14 @@ struct alloc_region {
      void  *end_addr; /* pointer to the byte after the last usable byte */
  
      /* These are needed when closing the region. */
      void  *end_addr; /* pointer to the byte after the last usable byte */
  
      /* These are needed when closing the region. */
-    int  first_page;
-    int  last_page;
+    long  first_page;
+    long  last_page;
      void  *start_addr;
  };
  
  extern struct alloc_region  boxed_region;
  extern struct alloc_region  unboxed_region;
      void  *start_addr;
  };
  
  extern struct alloc_region  boxed_region;
  extern struct alloc_region  unboxed_region;
-extern int from_space, new_space;
+extern long from_space, new_space;
  extern struct weak_pointer *weak_pointers;
  
  extern void *current_region_free_pointer;
  extern struct weak_pointer *weak_pointers;
  
  extern void *current_region_free_pointer;
diff --git a/src/runtime/gencgc-internal.h b/src/runtime/gencgc-internal.h

index cca1602..b9966e7 100644 (file)
--- a/src/runtime/gencgc-internal.h
+++ b/src/runtime/gencgc-internal.h
@@ -29,8 +29,8 @@
  
  
  void gc_free_heap(void);
  
  
  void gc_free_heap(void);
-inline int find_page_index(void *);
-inline void *page_address(int);
+inline long find_page_index(void *);
+inline void *page_address(long);
  int gencgc_handle_wp_violation(void *);
  \f
  struct page {
  int gencgc_handle_wp_violation(void *);
  \f
  struct page {
@@ -69,13 +69,13 @@ struct page {
       * than the actual bytes used for pages within the current
       * allocation regions. It should be 0 for all unallocated pages (not
       * hard to achieve). */
       * than the actual bytes used for pages within the current
       * allocation regions. It should be 0 for all unallocated pages (not
       * hard to achieve). */
-    int  bytes_used;
+    long  bytes_used;
  
      /* The name of this field is not well-chosen for its actual use.
       * This is the offset from the start of the page to the start 
       * of the alloc_region which contains/contained it.  It's negative or 0
       */
  
      /* The name of this field is not well-chosen for its actual use.
       * This is the offset from the start of the page to the start 
       * of the alloc_region which contains/contained it.  It's negative or 0
       */
-    int  first_object_offset;
+    long  first_object_offset;
  };
  
  /* values for the page.allocated field */
  };
  
  /* values for the page.allocated field */
@@ -92,7 +92,7 @@ extern struct page page_table[NUM_PAGES];
  void sniff_code_object(struct code *code, unsigned displacement);
  void gencgc_apply_code_fixups(struct code *old_code, struct code *new_code);
  
  void sniff_code_object(struct code *code, unsigned displacement);
  void gencgc_apply_code_fixups(struct code *old_code, struct code *new_code);
  
-int  update_x86_dynamic_space_free_pointer(void);
+long  update_x86_dynamic_space_free_pointer(void);
  void  gc_alloc_update_page_tables(int unboxed,
                                   struct alloc_region *alloc_region);
  void gc_alloc_update_all_page_tables(void);
  void  gc_alloc_update_page_tables(int unboxed,
                                   struct alloc_region *alloc_region);
  void gc_alloc_update_all_page_tables(void);
@@ -102,12 +102,12 @@ void gc_set_region_empty(struct alloc_region *region);
   * predicates
   */
  static inline int 
   * predicates
   */
  static inline int 
-space_matches_p(lispobj obj, int space)
+space_matches_p(lispobj obj, long space)
  {
  {
-    int page_index=(void*)obj - (void *)DYNAMIC_SPACE_START;
+    long page_index=(void*)obj - (void *)DYNAMIC_SPACE_START;
      return ((page_index >= 0)
             && ((page_index =
      return ((page_index >= 0)
             && ((page_index =
-                ((unsigned int)page_index)/PAGE_BYTES) < NUM_PAGES)
+                ((unsigned long)page_index)/PAGE_BYTES) < NUM_PAGES)
             && (page_table[page_index].gen == space));
  }
  
             && (page_table[page_index].gen == space));
  }
  
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c

index c6009cc..f7f45a7 100644 (file)
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -49,7 +49,7 @@
  void do_pending_interrupt(void);
  
  /* forward declarations */
  void do_pending_interrupt(void);
  
  /* forward declarations */
-int gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed);
+long gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed);
  static void  gencgc_pickup_dynamic(void);
  boolean interrupt_maybe_gc_int(int, siginfo_t *, void *);
  
  static void  gencgc_pickup_dynamic(void);
  boolean interrupt_maybe_gc_int(int, siginfo_t *, void *);
  
@@ -141,8 +141,8 @@ unsigned long auto_gc_trigger = 0;
  
  /* the source and destination generations. These are set before a GC starts
   * scavenging. */
  
  /* the source and destination generations. These are set before a GC starts
   * scavenging. */
-int from_space;
-int new_space;
+long from_space;
+long new_space;
  
  
  /* An array of page structures is statically allocated.
  
  
  /* An array of page structures is statically allocated.
@@ -154,23 +154,28 @@ struct page page_table[NUM_PAGES];
   * is needed. */
  static void *heap_base = NULL;
  
   * is needed. */
  static void *heap_base = NULL;
  
+#if N_WORD_BITS == 32
+ #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
+#elif N_WORD_BITS == 64
+ #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+#endif
  
  /* Calculate the start address for the given page number. */
  inline void *
  
  /* Calculate the start address for the given page number. */
  inline void *
-page_address(int page_num)
+page_address(long page_num)
  {
      return (heap_base + (page_num * PAGE_BYTES));
  }
  
  /* Find the page index within the page_table for the given
   * address. Return -1 on failure. */
  {
      return (heap_base + (page_num * PAGE_BYTES));
  }
  
  /* Find the page index within the page_table for the given
   * address. Return -1 on failure. */
-inline int
+inline long
  find_page_index(void *addr)
  {
  find_page_index(void *addr)
  {
-    int index = addr-heap_base;
+    long index = addr-heap_base;
  
      if (index >= 0) {
  
      if (index >= 0) {
-       index = ((unsigned int)index)/PAGE_BYTES;
+       index = ((unsigned long)index)/PAGE_BYTES;
         if (index < NUM_PAGES)
             return (index);
      }
         if (index < NUM_PAGES)
             return (index);
      }
@@ -182,28 +187,28 @@ find_page_index(void *addr)
  struct generation {
  
      /* the first page that gc_alloc() checks on its next call */
  struct generation {
  
      /* the first page that gc_alloc() checks on its next call */
-    int alloc_start_page;
+    long alloc_start_page;
  
      /* the first page that gc_alloc_unboxed() checks on its next call */
  
      /* the first page that gc_alloc_unboxed() checks on its next call */
-    int alloc_unboxed_start_page;
+    long alloc_unboxed_start_page;
  
      /* the first page that gc_alloc_large (boxed) considers on its next
       * call. (Although it always allocates after the boxed_region.) */
  
      /* the first page that gc_alloc_large (boxed) considers on its next
       * call. (Although it always allocates after the boxed_region.) */
-    int alloc_large_start_page;
+    long alloc_large_start_page;
  
      /* the first page that gc_alloc_large (unboxed) considers on its
       * next call. (Although it always allocates after the
       * current_unboxed_region.) */
  
      /* the first page that gc_alloc_large (unboxed) considers on its
       * next call. (Although it always allocates after the
       * current_unboxed_region.) */
-    int alloc_large_unboxed_start_page;
+    long alloc_large_unboxed_start_page;
  
      /* the bytes allocated to this generation */
  
      /* the bytes allocated to this generation */
-    int bytes_allocated;
+    long bytes_allocated;
  
      /* the number of bytes at which to trigger a GC */
  
      /* the number of bytes at which to trigger a GC */
-    int gc_trigger;
+    long gc_trigger;
  
      /* to calculate a new level for gc_trigger */
  
      /* to calculate a new level for gc_trigger */
-    int bytes_consed_between_gc;
+    long bytes_consed_between_gc;
  
      /* the number of GCs since the last raise */
      int num_gc;
  
      /* the number of GCs since the last raise */
      int num_gc;
@@ -217,7 +222,7 @@ struct generation {
       * objects are added from a GC of a younger generation. Dividing by
       * the bytes_allocated will give the average age of the memory in
       * this generation since its last GC. */
       * objects are added from a GC of a younger generation. Dividing by
       * the bytes_allocated will give the average age of the memory in
       * this generation since its last GC. */
-    int cum_sum_bytes_allocated;
+    long cum_sum_bytes_allocated;
  
      /* a minimum average memory age before a GC will occur helps
       * prevent a GC when a large number of new live objects have been
  
      /* a minimum average memory age before a GC will occur helps
       * prevent a GC when a large number of new live objects have been
@@ -252,7 +257,7 @@ unsigned int  gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1;
   * ALLOCATION_POINTER which is used by the room function to limit its
   * search of the heap. XX Gencgc obviously needs to be better
   * integrated with the Lisp code. */
   * ALLOCATION_POINTER which is used by the room function to limit its
   * search of the heap. XX Gencgc obviously needs to be better
   * integrated with the Lisp code. */
-static int  last_free_page;
+static long  last_free_page;
  \f
  /* This lock is to prevent multiple threads from simultaneously
   * allocating new regions which overlap each other.  Note that the
  \f
  /* This lock is to prevent multiple threads from simultaneously
   * allocating new regions which overlap each other.  Note that the
@@ -270,11 +275,11 @@ static lispobj free_pages_lock=0;
  
  /* Count the number of pages which are write-protected within the
   * given generation. */
  
  /* Count the number of pages which are write-protected within the
   * given generation. */
-static int
+static long
  count_write_protect_generation_pages(int generation)
  {
  count_write_protect_generation_pages(int generation)
  {
-    int i;
-    int count = 0;
+    long i;
+    long count = 0;
  
      for (i = 0; i < last_free_page; i++)
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
  
      for (i = 0; i < last_free_page; i++)
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
@@ -285,11 +290,11 @@ count_write_protect_generation_pages(int generation)
  }
  
  /* Count the number of pages within the given generation. */
  }
  
  /* Count the number of pages within the given generation. */
-static int
+static long
  count_generation_pages(int generation)
  {
  count_generation_pages(int generation)
  {
-    int i;
-    int count = 0;
+    long i;
+    long count = 0;
  
      for (i = 0; i < last_free_page; i++)
         if ((page_table[i].allocated != 0)
  
      for (i = 0; i < last_free_page; i++)
         if ((page_table[i].allocated != 0)
@@ -299,11 +304,11 @@ count_generation_pages(int generation)
  }
  
  #ifdef QSHOW
  }
  
  #ifdef QSHOW
-static int
+static long
  count_dont_move_pages(void)
  {
  count_dont_move_pages(void)
  {
-    int i;
-    int count = 0;
+    long i;
+    long count = 0;
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != 0) && (page_table[i].dont_move != 0)) {
             ++count;
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != 0) && (page_table[i].dont_move != 0)) {
             ++count;
@@ -315,11 +320,11 @@ count_dont_move_pages(void)
  
  /* Work through the pages and add up the number of bytes used for the
   * given generation. */
  
  /* Work through the pages and add up the number of bytes used for the
   * given generation. */
-static int
+static long
  count_generation_bytes_allocated (int gen)
  {
  count_generation_bytes_allocated (int gen)
  {
-    int i;
-    int result = 0;
+    long i;
+    long result = 0;
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != 0) && (page_table[i].gen == gen))
             result += page_table[i].bytes_used;
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != 0) && (page_table[i].gen == gen))
             result += page_table[i].bytes_used;
@@ -495,12 +500,12 @@ static int gc_alloc_generation;
   * are allocated, although they will initially be empty.
   */
  static void
   * are allocated, although they will initially be empty.
   */
  static void
-gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
+gc_alloc_new_region(long nbytes, int unboxed, struct alloc_region *alloc_region)
  {
  {
-    int first_page;
-    int last_page;
-    int bytes_found;
-    int i;
+    long first_page;
+    long last_page;
+    long bytes_found;
+    long i;
  
      /*
      FSHOW((stderr,
  
      /*
      FSHOW((stderr,
@@ -512,7 +517,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
      gc_assert((alloc_region->first_page == 0)
               && (alloc_region->last_page == -1)
               && (alloc_region->free_pointer == alloc_region->end_addr));
      gc_assert((alloc_region->first_page == 0)
               && (alloc_region->last_page == -1)
               && (alloc_region->free_pointer == alloc_region->end_addr));
-    get_spinlock(&free_pages_lock,(int) alloc_region);
+    get_spinlock(&free_pages_lock,(long) alloc_region);
      if (unboxed) {
         first_page =
             generations[gc_alloc_generation].alloc_unboxed_start_page;
      if (unboxed) {
         first_page =
             generations[gc_alloc_generation].alloc_unboxed_start_page;
@@ -578,9 +583,9 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
      
      /* we can do this after releasing free_pages_lock */
      if (gencgc_zero_check) {
      
      /* we can do this after releasing free_pages_lock */
      if (gencgc_zero_check) {
-       int *p;
-       for (p = (int *)alloc_region->start_addr;
-            p < (int *)alloc_region->end_addr; p++) {
+       long *p;
+       for (p = (long *)alloc_region->start_addr;
+            p < (long *)alloc_region->end_addr; p++) {
             if (*p != 0) {
                 /* KLUDGE: It would be nice to use %lx and explicit casts
                  * (long) in code like this, so that it is less likely to
             if (*p != 0) {
                 /* KLUDGE: It would be nice to use %lx and explicit casts
                  * (long) in code like this, so that it is less likely to
@@ -610,22 +615,22 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
   * scavenge of a generation. */
  #define NUM_NEW_AREAS 512
  static int record_new_objects = 0;
   * scavenge of a generation. */
  #define NUM_NEW_AREAS 512
  static int record_new_objects = 0;
-static int new_areas_ignore_page;
+static long new_areas_ignore_page;
  struct new_area {
  struct new_area {
-    int  page;
-    int  offset;
-    int  size;
+    long  page;
+    long  offset;
+    long  size;
  };
  static struct new_area (*new_areas)[];
  };
  static struct new_area (*new_areas)[];
-static int new_areas_index;
-int max_new_areas;
+static long new_areas_index;
+long max_new_areas;
  
  /* Add a new area to new_areas. */
  static void
  
  /* Add a new area to new_areas. */
  static void
-add_new_area(int first_page, int offset, int size)
+add_new_area(long first_page, long offset, long size)
  {
      unsigned new_area_start,c;
  {
      unsigned new_area_start,c;
-    int i;
+    long i;
  
      /* Ignore if full. */
      if (new_areas_index >= NUM_NEW_AREAS)
  
      /* Ignore if full. */
      if (new_areas_index >= NUM_NEW_AREAS)
@@ -694,13 +699,13 @@ add_new_area(int first_page, int offset, int size)
  void
  gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
  {
  void
  gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
  {
-    int more;
-    int first_page;
-    int next_page;
-    int bytes_used;
-    int orig_first_page_bytes_used;
-    int region_size;
-    int byte_cnt;
+    long more;
+    long first_page;
+    long next_page;
+    long bytes_used;
+    long orig_first_page_bytes_used;
+    long region_size;
+    long byte_cnt;
  
  
      first_page = alloc_region->first_page;
  
  
      first_page = alloc_region->first_page;
@@ -711,7 +716,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
  
      next_page = first_page+1;
  
  
      next_page = first_page+1;
  
-    get_spinlock(&free_pages_lock,(int) alloc_region);
+    get_spinlock(&free_pages_lock,(long) alloc_region);
      if (alloc_region->free_pointer != alloc_region->start_addr) {
         /* some bytes were allocated in the region */
         orig_first_page_bytes_used = page_table[first_page].bytes_used;
      if (alloc_region->free_pointer != alloc_region->start_addr) {
         /* some bytes were allocated in the region */
         orig_first_page_bytes_used = page_table[first_page].bytes_used;
@@ -820,21 +825,21 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
      gc_set_region_empty(alloc_region);
  }
  
      gc_set_region_empty(alloc_region);
  }
  
-static inline void *gc_quick_alloc(int nbytes);
+static inline void *gc_quick_alloc(long nbytes);
  
  /* Allocate a possibly large object. */
  void *
  
  /* Allocate a possibly large object. */
  void *
-gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
+gc_alloc_large(long nbytes, int unboxed, struct alloc_region *alloc_region)
  {
  {
-    int first_page;
-    int last_page;
-    int orig_first_page_bytes_used;
-    int byte_cnt;
-    int more;
-    int bytes_used;
-    int next_page;
+    long first_page;
+    long last_page;
+    long orig_first_page_bytes_used;
+    long byte_cnt;
+    long more;
+    long bytes_used;
+    long next_page;
  
  
-    get_spinlock(&free_pages_lock,(int) alloc_region);
+    get_spinlock(&free_pages_lock,(long) alloc_region);
  
      if (unboxed) {
         first_page =
  
      if (unboxed) {
         first_page =
@@ -940,16 +945,16 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
      return((void *)(page_address(first_page)+orig_first_page_bytes_used));
  }
  
      return((void *)(page_address(first_page)+orig_first_page_bytes_used));
  }
  
-int
-gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed)
+long
+gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed)
  {
  {
-    int first_page;
-    int last_page;
-    int region_size;
-    int restart_page=*restart_page_ptr;
-    int bytes_found;
-    int num_pages;
-    int large_p=(nbytes>=large_object_size);
+    long first_page;
+    long last_page;
+    long region_size;
+    long restart_page=*restart_page_ptr;
+    long bytes_found;
+    long num_pages;
+    long large_p=(nbytes>=large_object_size);
      gc_assert(free_pages_lock);
  
      /* Search for a contiguous free space of at least nbytes. If it's
      gc_assert(free_pages_lock);
  
      /* Search for a contiguous free space of at least nbytes. If it's
@@ -1024,7 +1029,7 @@ gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed)
   * functions will eventually call this  */
  
  void *
   * functions will eventually call this  */
  
  void *
-gc_alloc_with_region(int nbytes,int unboxed_p, struct alloc_region *my_region,
+gc_alloc_with_region(long nbytes,int unboxed_p, struct alloc_region *my_region,
                      int quick_p)
  {
      void *new_free_pointer;
                      int quick_p)
  {
      void *new_free_pointer;
@@ -1035,6 +1040,9 @@ gc_alloc_with_region(int nbytes,int unboxed_p, struct alloc_region *my_region,
      /* Check whether there is room in the current alloc region. */
      new_free_pointer = my_region->free_pointer + nbytes;
  
      /* Check whether there is room in the current alloc region. */
      new_free_pointer = my_region->free_pointer + nbytes;
  
+    /* fprintf(stderr, "alloc %d bytes from %p to %p\n", nbytes,
+       my_region->free_pointer, new_free_pointer); */
+
      if (new_free_pointer <= my_region->end_addr) {
         /* If so then allocate from the current alloc region. */
         void *new_obj = my_region->free_pointer;
      if (new_free_pointer <= my_region->end_addr) {
         /* If so then allocate from the current alloc region. */
         void *new_obj = my_region->free_pointer;
@@ -1066,7 +1074,7 @@ gc_alloc_with_region(int nbytes,int unboxed_p, struct alloc_region *my_region,
   * region */
  
  void *
   * region */
  
  void *
-gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
+gc_general_alloc(long nbytes,int unboxed_p,int quick_p)
  {
      struct alloc_region *my_region = 
        unboxed_p ? &unboxed_region : &boxed_region;
  {
      struct alloc_region *my_region = 
        unboxed_p ? &unboxed_region : &boxed_region;
@@ -1074,31 +1082,31 @@ gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
  }
  
  static inline void *
  }
  
  static inline void *
-gc_quick_alloc(int nbytes)
+gc_quick_alloc(long nbytes)
  {
      return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
  }
  
  static inline void *
  {
      return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
  }
  
  static inline void *
-gc_quick_alloc_large(int nbytes)
+gc_quick_alloc_large(long nbytes)
  {
      return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
  }
  
  static inline void *
  {
      return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
  }
  
  static inline void *
-gc_alloc_unboxed(int nbytes)
+gc_alloc_unboxed(long nbytes)
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,0);
  }
  
  static inline void *
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,0);
  }
  
  static inline void *
-gc_quick_alloc_unboxed(int nbytes)
+gc_quick_alloc_unboxed(long nbytes)
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
  }
  
  static inline void *
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
  }
  
  static inline void *
-gc_quick_alloc_large_unboxed(int nbytes)
+gc_quick_alloc_large_unboxed(long nbytes)
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
  }
  {
      return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
  }
@@ -1107,9 +1115,9 @@ gc_quick_alloc_large_unboxed(int nbytes)
   * scavenging/transporting routines derived from gc.c in CMU CL ca. 18b
   */
  
   * scavenging/transporting routines derived from gc.c in CMU CL ca. 18b
   */
  
-extern int (*scavtab[256])(lispobj *where, lispobj object);
+extern long (*scavtab[256])(lispobj *where, lispobj object);
  extern lispobj (*transother[256])(lispobj object);
  extern lispobj (*transother[256])(lispobj object);
-extern int (*sizetab[256])(lispobj *where);
+extern long (*sizetab[256])(lispobj *where);
  
  /* Copy a large boxed object. If the object is in a large object
   * region then it is simply promoted, else it is copied. If it's large
  
  /* Copy a large boxed object. If the object is in a large object
   * region then it is simply promoted, else it is copied. If it's large
@@ -1118,11 +1126,11 @@ extern int (*sizetab[256])(lispobj *where);
   * Vectors may have shrunk. If the object is not copied the space
   * needs to be reclaimed, and the page_tables corrected. */
  lispobj
   * Vectors may have shrunk. If the object is not copied the space
   * needs to be reclaimed, and the page_tables corrected. */
  lispobj
-copy_large_object(lispobj object, int nwords)
+copy_large_object(lispobj object, long nwords)
  {
      int tag;
      lispobj *new;
  {
      int tag;
      lispobj *new;
-    int first_page;
+    long first_page;
  
      gc_assert(is_lisp_pointer(object));
      gc_assert(from_space_p(object));
  
      gc_assert(is_lisp_pointer(object));
      gc_assert(from_space_p(object));
@@ -1137,10 +1145,10 @@ copy_large_object(lispobj object, int nwords)
  
         /* Promote the object. */
  
  
         /* Promote the object. */
  
-       int remaining_bytes;
-       int next_page;
-       int bytes_freed;
-       int old_bytes_used;
+       long remaining_bytes;
+       long next_page;
+       long bytes_freed;
+       long old_bytes_used;
  
         /* Note: Any page write-protection must be removed, else a
          * later scavenge_newspace may incorrectly not scavenge these
  
         /* Note: Any page write-protection must be removed, else a
          * later scavenge_newspace may incorrectly not scavenge these
@@ -1208,8 +1216,9 @@ copy_large_object(lispobj object, int nwords)
             next_page++;
         }
  
             next_page++;
         }
  
-       generations[from_space].bytes_allocated -= 4*nwords + bytes_freed;
-       generations[new_space].bytes_allocated += 4*nwords;
+       generations[from_space].bytes_allocated -= N_WORD_BYTES*nwords +
+         bytes_freed;
+       generations[new_space].bytes_allocated += N_WORD_BYTES*nwords;
         bytes_allocated -= bytes_freed;
  
         /* Add the region to the new_areas if requested. */
         bytes_allocated -= bytes_freed;
  
         /* Add the region to the new_areas if requested. */
@@ -1232,9 +1241,9 @@ copy_large_object(lispobj object, int nwords)
  
  /* to copy unboxed objects */
  lispobj
  
  /* to copy unboxed objects */
  lispobj
-copy_unboxed_object(lispobj object, int nwords)
+copy_unboxed_object(lispobj object, long nwords)
  {
  {
-    int tag;
+    long tag;
      lispobj *new;
  
      gc_assert(is_lisp_pointer(object));
      lispobj *new;
  
      gc_assert(is_lisp_pointer(object));
@@ -1265,11 +1274,11 @@ copy_unboxed_object(lispobj object, int nwords)
   * KLUDGE: There's a lot of cut-and-paste duplication between this
   * function and copy_large_object(..). -- WHN 20000619 */
  lispobj
   * KLUDGE: There's a lot of cut-and-paste duplication between this
   * function and copy_large_object(..). -- WHN 20000619 */
  lispobj
-copy_large_unboxed_object(lispobj object, int nwords)
+copy_large_unboxed_object(lispobj object, long nwords)
  {
      int tag;
      lispobj *new;
  {
      int tag;
      lispobj *new;
-    int first_page;
+    long first_page;
  
      gc_assert(is_lisp_pointer(object));
      gc_assert(from_space_p(object));
  
      gc_assert(is_lisp_pointer(object));
      gc_assert(from_space_p(object));
@@ -1286,10 +1295,10 @@ copy_large_unboxed_object(lispobj object, int nwords)
         /* Promote the object. Note: Unboxed objects may have been
          * allocated to a BOXED region so it may be necessary to
          * change the region to UNBOXED. */
         /* Promote the object. Note: Unboxed objects may have been
          * allocated to a BOXED region so it may be necessary to
          * change the region to UNBOXED. */
-       int remaining_bytes;
-       int next_page;
-       int bytes_freed;
-       int old_bytes_used;
+       long remaining_bytes;
+       long next_page;
+       long bytes_freed;
+       long old_bytes_used;
  
         gc_assert(page_table[first_page].first_object_offset == 0);
  
  
         gc_assert(page_table[first_page].first_object_offset == 0);
  
@@ -1397,7 +1406,7 @@ static lispobj trans_boxed(lispobj object);
  void
  sniff_code_object(struct code *code, unsigned displacement)
  {
  void
  sniff_code_object(struct code *code, unsigned displacement)
  {
-    int nheader_words, ncode_words, nwords;
+    long nheader_words, ncode_words, nwords;
      void *p;
      void *constants_start_addr, *constants_end_addr;
      void *code_start_addr, *code_end_addr;
      void *p;
      void *constants_start_addr, *constants_end_addr;
      void *code_start_addr, *code_end_addr;
@@ -1567,7 +1576,7 @@ sniff_code_object(struct code *code, unsigned displacement)
  void
  gencgc_apply_code_fixups(struct code *old_code, struct code *new_code)
  {
  void
  gencgc_apply_code_fixups(struct code *old_code, struct code *new_code)
  {
-    int nheader_words, ncode_words, nwords;
+    long nheader_words, ncode_words, nwords;
      void *constants_start_addr, *constants_end_addr;
      void *code_start_addr, *code_end_addr;
      lispobj fixups = NIL;
      void *constants_start_addr, *constants_end_addr;
      void *code_start_addr, *code_end_addr;
      lispobj fixups = NIL;
@@ -1624,12 +1633,11 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code)
  
      /*SHOW("got fixups");*/
  
  
      /*SHOW("got fixups");*/
  
-    if (widetag_of(fixups_vector->header) ==
-       SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG) {
+    if (widetag_of(fixups_vector->header) == SIMPLE_ARRAY_WORD_WIDETAG) {
         /* Got the fixups for the code block. Now work through the vector,
            and apply a fixup at each address. */
         /* Got the fixups for the code block. Now work through the vector,
            and apply a fixup at each address. */
-       int length = fixnum_value(fixups_vector->length);
-       int i;
+       long length = fixnum_value(fixups_vector->length);
+       long i;
         for (i = 0; i < length; i++) {
             unsigned offset = fixups_vector->data[i];
             /* Now check the current value of offset. */
         for (i = 0; i < length; i++) {
             unsigned offset = fixups_vector->data[i];
             /* Now check the current value of offset. */
@@ -1650,6 +1658,8 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code)
                 *(unsigned *)((unsigned)code_start_addr + offset) =
                     old_value - displacement;
         }
                 *(unsigned *)((unsigned)code_start_addr + offset) =
                     old_value - displacement;
         }
+    } else {
+        fprintf(stderr, "widetag of fixup vector is %d\n", widetag_of(fixups_vector->header));
      }
  
      /* Check for possible errors. */
      }
  
      /* Check for possible errors. */
@@ -1703,14 +1713,14 @@ int gencgc_hash = 1;
  static int
  scav_vector(lispobj *where, lispobj object)
  {
  static int
  scav_vector(lispobj *where, lispobj object)
  {
-    unsigned int kv_length;
+    unsigned long kv_length;
      lispobj *kv_vector;
      lispobj *kv_vector;
-    unsigned int length = 0; /* (0 = dummy to stop GCC warning) */
+    unsigned long length = 0; /* (0 = dummy to stop GCC warning) */
      lispobj *hash_table;
      lispobj empty_symbol;
      lispobj *hash_table;
      lispobj empty_symbol;
-    unsigned int *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */
-    unsigned int *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */
-    unsigned int *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */
+    unsigned long *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */
+    unsigned long *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */
+    unsigned long *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */
      lispobj weak_p_obj;
      unsigned next_vector_length = 0;
  
      lispobj weak_p_obj;
      unsigned next_vector_length = 0;
  
@@ -1775,10 +1785,10 @@ scav_vector(lispobj *where, lispobj object)
  
         if (is_lisp_pointer(index_vector_obj) &&
             (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==
  
         if (is_lisp_pointer(index_vector_obj) &&
             (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==
-            SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
-           index_vector = ((unsigned int *)native_pointer(index_vector_obj)) + 2;
+                SIMPLE_ARRAY_WORD_WIDETAG)) {
+           index_vector = ((lispobj *)native_pointer(index_vector_obj)) + 2;
             /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
             /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
-           length = fixnum_value(((unsigned int *)native_pointer(index_vector_obj))[1]);
+           length = fixnum_value(((lispobj *)native_pointer(index_vector_obj))[1]);
             /*FSHOW((stderr, "/length = %d\n", length));*/
         } else {
             lose("invalid index_vector %x", index_vector_obj);
             /*FSHOW((stderr, "/length = %d\n", length));*/
         } else {
             lose("invalid index_vector %x", index_vector_obj);
@@ -1791,10 +1801,10 @@ scav_vector(lispobj *where, lispobj object)
  
         if (is_lisp_pointer(next_vector_obj) &&
             (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) ==
  
         if (is_lisp_pointer(next_vector_obj) &&
             (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) ==
-            SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
-           next_vector = ((unsigned int *)native_pointer(next_vector_obj)) + 2;
+            SIMPLE_ARRAY_WORD_WIDETAG)) {
+           next_vector = ((lispobj *)native_pointer(next_vector_obj)) + 2;
             /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
             /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
-           next_vector_length = fixnum_value(((unsigned int *)native_pointer(next_vector_obj))[1]);
+           next_vector_length = fixnum_value(((lispobj *)native_pointer(next_vector_obj))[1]);
             /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
         } else {
             lose("invalid next_vector %x", next_vector_obj);
             /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
         } else {
             lose("invalid next_vector %x", next_vector_obj);
@@ -1810,11 +1820,11 @@ scav_vector(lispobj *where, lispobj object)
         lispobj hash_vector_obj = hash_table[15];
  
         if (is_lisp_pointer(hash_vector_obj) &&
         lispobj hash_vector_obj = hash_table[15];
  
         if (is_lisp_pointer(hash_vector_obj) &&
-           (widetag_of(*(lispobj *)native_pointer(hash_vector_obj))
-            == SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG)) {
-           hash_vector = ((unsigned int *)native_pointer(hash_vector_obj)) + 2;
+           (widetag_of(*(lispobj *)native_pointer(hash_vector_obj)) ==
+            SIMPLE_ARRAY_WORD_WIDETAG)){
+           hash_vector = ((lispobj *)native_pointer(hash_vector_obj)) + 2;
             /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
             /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
-           gc_assert(fixnum_value(((unsigned int *)native_pointer(hash_vector_obj))[1])
+           gc_assert(fixnum_value(((lispobj *)native_pointer(hash_vector_obj))[1])
                       == next_vector_length);
         } else {
             hash_vector = NULL;
                       == next_vector_length);
         } else {
             hash_vector = NULL;
@@ -1831,10 +1841,15 @@ scav_vector(lispobj *where, lispobj object)
  
      /* Work through the KV vector. */
      {
  
      /* Work through the KV vector. */
      {
-       int i;
+       long i;
         for (i = 1; i < next_vector_length; i++) {
             lispobj old_key = kv_vector[2*i];
         for (i = 1; i < next_vector_length; i++) {
             lispobj old_key = kv_vector[2*i];
-           unsigned int  old_index = (old_key & 0x1fffffff)%length;
+
+#if N_WORD_BITS == 32
+           unsigned long old_index = (old_key & 0x1fffffff)%length;
+#elif N_WORD_BITS == 64
+           unsigned long old_index = (old_key & 0x1fffffffffffffff)%length;
+#endif
  
             /* Scavenge the key and value. */
             scavenge(&kv_vector[2*i],2);
  
             /* Scavenge the key and value. */
             scavenge(&kv_vector[2*i],2);
@@ -1842,19 +1857,23 @@ scav_vector(lispobj *where, lispobj object)
             /* Check whether the key has moved and is EQ based. */
             {
                 lispobj new_key = kv_vector[2*i];
             /* Check whether the key has moved and is EQ based. */
             {
                 lispobj new_key = kv_vector[2*i];
-               unsigned int new_index = (new_key & 0x1fffffff)%length;
+#if N_WORD_BITS == 32
+               unsigned long new_index = (new_key & 0x1fffffff)%length;
+#elif N_WORD_BITS == 64
+               unsigned long new_index = (new_key & 0x1fffffffffffffff)%length;
+#endif
  
                 if ((old_index != new_index) &&
                     ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
                     ((new_key != empty_symbol) ||
                      (kv_vector[2*i] != empty_symbol))) {
  
  
                 if ((old_index != new_index) &&
                     ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
                     ((new_key != empty_symbol) ||
                      (kv_vector[2*i] != empty_symbol))) {
  
-                   /*FSHOW((stderr,
-                          "* EQ key %d moved from %x to %x; index %d to %d\n",
-                          i, old_key, new_key, old_index, new_index));*/
+                    /*FSHOW((stderr,
+                           "* EQ key %d moved from %x to %x; index %d to %d\n",
+                           i, old_key, new_key, old_index, new_index));*/
  
                     if (index_vector[old_index] != 0) {
  
                     if (index_vector[old_index] != 0) {
-                       /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
+                        /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
  
                         /* Unlink the key from the old_index chain. */
                         if (index_vector[old_index] == i) {
  
                         /* Unlink the key from the old_index chain. */
                         if (index_vector[old_index] == i) {
@@ -1871,7 +1890,7 @@ scav_vector(lispobj *where, lispobj object)
                             /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
  
                             while (next != 0) {
                             /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
  
                             while (next != 0) {
-                               /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
+                                /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
                                 if (next == i) {
                                     /* Unlink it. */
                                     next_vector[prior] = next_vector[next];
                                 if (next == i) {
                                     /* Unlink it. */
                                     next_vector[prior] = next_vector[next];
@@ -1909,7 +1928,7 @@ scav_vector(lispobj *where, lispobj object)
  #define WEAK_POINTER_NWORDS \
      CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
  
  #define WEAK_POINTER_NWORDS \
      CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
  
-static int
+static long
  scav_weak_pointer(lispobj *where, lispobj object)
  {
      struct weak_pointer *wp = weak_pointers;
  scav_weak_pointer(lispobj *where, lispobj object)
  {
      struct weak_pointer *wp = weak_pointers;
@@ -1973,7 +1992,7 @@ search_static_space(void *pointer)
  lispobj *
  search_dynamic_space(void *pointer)
  {
  lispobj *
  search_dynamic_space(void *pointer)
  {
-    int page_index = find_page_index(pointer);
+    long page_index = find_page_index(pointer);
      lispobj *start;
  
      /* The address may be invalid, so do some checks. */
      lispobj *start;
  
      /* The address may be invalid, so do some checks. */
@@ -2174,9 +2193,20 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+#ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+#endif
         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
@@ -2189,6 +2219,12 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+       case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+       case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
@@ -2237,13 +2273,13 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
  static void
  maybe_adjust_large_object(lispobj *where)
  {
  static void
  maybe_adjust_large_object(lispobj *where)
  {
-    int first_page;
-    int nwords;
+    long first_page;
+    long nwords;
  
  
-    int remaining_bytes;
-    int next_page;
-    int bytes_freed;
-    int old_bytes_used;
+    long remaining_bytes;
+    long next_page;
+    long bytes_freed;
+    long old_bytes_used;
  
      int boxed;
  
  
      int boxed;
  
@@ -2265,9 +2301,20 @@ maybe_adjust_large_object(lispobj *where)
      case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+#ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
      case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+#endif
      case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
      case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+    case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+    case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+    case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
      case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
      case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
@@ -2280,6 +2327,12 @@ maybe_adjust_large_object(lispobj *where)
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
      case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
      case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+    case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+    case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
      case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
      case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
      case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
      case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
@@ -2399,9 +2452,9 @@ maybe_adjust_large_object(lispobj *where)
  static void
  preserve_pointer(void *addr)
  {
  static void
  preserve_pointer(void *addr)
  {
-    int addr_page_index = find_page_index(addr);
-    int first_page;
-    int i;
+    long addr_page_index = find_page_index(addr);
+    long first_page;
+    long i;
      unsigned region_allocation;
  
      /* quick check 1: Address is quite likely to have been invalid. */
      unsigned region_allocation;
  
      /* quick check 1: Address is quite likely to have been invalid. */
@@ -2526,13 +2579,13 @@ preserve_pointer(void *addr)
   *
   * We return 1 if the page was write-protected, else 0. */
  static int
   *
   * We return 1 if the page was write-protected, else 0. */
  static int
-update_page_write_prot(int page)
+update_page_write_prot(long page)
  {
      int gen = page_table[page].gen;
  {
      int gen = page_table[page].gen;
-    int j;
+    long j;
      int wp_it = 1;
      void **page_addr = (void **)page_address(page);
      int wp_it = 1;
      void **page_addr = (void **)page_address(page);
-    int num_words = page_table[page].bytes_used / N_WORD_BYTES;
+    long num_words = page_table[page].bytes_used / N_WORD_BYTES;
  
      /* Shouldn't be a free page. */
      gc_assert(page_table[page].allocated != FREE_PAGE_FLAG);
  
      /* Shouldn't be a free page. */
      gc_assert(page_table[page].allocated != FREE_PAGE_FLAG);
@@ -2549,7 +2602,7 @@ update_page_write_prot(int page)
  
      for (j = 0; j < num_words; j++) {
         void *ptr = *(page_addr+j);
  
      for (j = 0; j < num_words; j++) {
         void *ptr = *(page_addr+j);
-       int index = find_page_index(ptr);
+       long index = find_page_index(ptr);
  
         /* Check that it's in the dynamic space */
         if (index != -1)
  
         /* Check that it's in the dynamic space */
         if (index != -1)
@@ -2618,7 +2671,7 @@ update_page_write_prot(int page)
  static void
  scavenge_generation(int generation)
  {
  static void
  scavenge_generation(int generation)
  {
-    int i;
+    long i;
      int num_wp = 0;
  
  #define SC_GEN_CK 0
      int num_wp = 0;
  
  #define SC_GEN_CK 0
@@ -2632,7 +2685,7 @@ scavenge_generation(int generation)
         if ((page_table[i].allocated & BOXED_PAGE_FLAG)
             && (page_table[i].bytes_used != 0)
             && (page_table[i].gen == generation)) {
         if ((page_table[i].allocated & BOXED_PAGE_FLAG)
             && (page_table[i].bytes_used != 0)
             && (page_table[i].gen == generation)) {
-           int last_page,j;
+           long last_page,j;
             int write_protected=1;
  
             /* This should be the start of a region */
             int write_protected=1;
  
             /* This should be the start of a region */
@@ -2651,8 +2704,9 @@ scavenge_generation(int generation)
                     break;
             }
             if (!write_protected) {
                     break;
             }
             if (!write_protected) {
-               scavenge(page_address(i), (page_table[last_page].bytes_used
-                                          + (last_page-i)*PAGE_BYTES)/4);
+               scavenge(page_address(i), 
+                        (page_table[last_page].bytes_used +
+                         (last_page-i)*PAGE_BYTES)/N_WORD_BYTES);
                 
                 /* Now scan the pages and write protect those that
                  * don't have pointers to younger generations. */
                 
                 /* Now scan the pages and write protect those that
                  * don't have pointers to younger generations. */
@@ -2722,7 +2776,7 @@ static struct new_area new_areas_2[NUM_NEW_AREAS];
  static void
  scavenge_newspace_generation_one_scan(int generation)
  {
  static void
  scavenge_newspace_generation_one_scan(int generation)
  {
-    int i;
+    long i;
  
      FSHOW((stderr,
            "/starting one full scan of newspace generation %d\n",
  
      FSHOW((stderr,
            "/starting one full scan of newspace generation %d\n",
@@ -2736,7 +2790,7 @@ scavenge_newspace_generation_one_scan(int generation)
                 /* (This may be redundant as write_protected is now
                  * cleared before promotion.) */
                 || (page_table[i].dont_move == 1))) {
                 /* (This may be redundant as write_protected is now
                  * cleared before promotion.) */
                 || (page_table[i].dont_move == 1))) {
-           int last_page;
+           long last_page;
             int all_wp=1;
  
             /* The scavenge will start at the first_object_offset of page i.
             int all_wp=1;
  
             /* The scavenge will start at the first_object_offset of page i.
@@ -2766,11 +2820,11 @@ scavenge_newspace_generation_one_scan(int generation)
  
             /* Do a limited check for write-protected pages.  */
             if (!all_wp) {
  
             /* Do a limited check for write-protected pages.  */
             if (!all_wp) {
-               int size;
+               long size;
                 
                 size = (page_table[last_page].bytes_used
                         + (last_page-i)*PAGE_BYTES
                 
                 size = (page_table[last_page].bytes_used
                         + (last_page-i)*PAGE_BYTES
-                       - page_table[i].first_object_offset)/4;
+                       - page_table[i].first_object_offset)/N_WORD_BYTES;
                 new_areas_ignore_page = last_page;
                 
                 scavenge(page_address(i) +
                 new_areas_ignore_page = last_page;
                 
                 scavenge(page_address(i) +
@@ -2790,15 +2844,15 @@ scavenge_newspace_generation_one_scan(int generation)
  static void
  scavenge_newspace_generation(int generation)
  {
  static void
  scavenge_newspace_generation(int generation)
  {
-    int i;
+    long i;
  
      /* the new_areas array currently being written to by gc_alloc() */
      struct new_area (*current_new_areas)[] = &new_areas_1;
  
      /* the new_areas array currently being written to by gc_alloc() */
      struct new_area (*current_new_areas)[] = &new_areas_1;
-    int current_new_areas_index;
+    long current_new_areas_index;
  
      /* the new_areas created by the previous scavenge cycle */
      struct new_area (*previous_new_areas)[] = NULL;
  
      /* the new_areas created by the previous scavenge cycle */
      struct new_area (*previous_new_areas)[] = NULL;
-    int previous_new_areas_index;
+    long previous_new_areas_index;
  
      /* Flush the current regions updating the tables. */
      gc_alloc_update_all_page_tables();
  
      /* Flush the current regions updating the tables. */
      gc_alloc_update_all_page_tables();
@@ -2871,9 +2925,9 @@ scavenge_newspace_generation(int generation)
  
             /* Work through previous_new_areas. */
             for (i = 0; i < previous_new_areas_index; i++) {
  
             /* Work through previous_new_areas. */
             for (i = 0; i < previous_new_areas_index; i++) {
-               int page = (*previous_new_areas)[i].page;
-               int offset = (*previous_new_areas)[i].offset;
-               int size = (*previous_new_areas)[i].size / N_WORD_BYTES;
+               long page = (*previous_new_areas)[i].page;
+               long offset = (*previous_new_areas)[i].offset;
+               long size = (*previous_new_areas)[i].size / N_WORD_BYTES;
                 gc_assert((*previous_new_areas)[i].size % N_WORD_BYTES == 0);
                 scavenge(page_address(page)+offset, size);
             }
                 gc_assert((*previous_new_areas)[i].size % N_WORD_BYTES == 0);
                 scavenge(page_address(page)+offset, size);
             }
@@ -2916,7 +2970,7 @@ scavenge_newspace_generation(int generation)
  static void
  unprotect_oldspace(void)
  {
  static void
  unprotect_oldspace(void)
  {
-    int i;
+    long i;
  
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
  
      for (i = 0; i < last_free_page; i++) {
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
@@ -2940,11 +2994,11 @@ unprotect_oldspace(void)
   * assumes that all objects have been copied or promoted to an older
   * generation. Bytes_allocated and the generation bytes_allocated
   * counter are updated. The number of bytes freed is returned. */
   * assumes that all objects have been copied or promoted to an older
   * generation. Bytes_allocated and the generation bytes_allocated
   * counter are updated. The number of bytes freed is returned. */
-static int
+static long
  free_oldspace(void)
  {
  free_oldspace(void)
  {
-    int bytes_freed = 0;
-    int first_page, last_page;
+    long bytes_freed = 0;
+    long first_page, last_page;
  
      first_page = 0;
  
  
      first_page = 0;
  
@@ -3004,9 +3058,9 @@ free_oldspace(void)
                      addr);
             }
         } else {
                      addr);
             }
         } else {
-           int *page_start;
+           long *page_start;
  
  
-           page_start = (int *)page_address(first_page);
+           page_start = (long *)page_address(first_page);
             memset(page_start, 0,PAGE_BYTES*(last_page-first_page));
         }
  
             memset(page_start, 0,PAGE_BYTES*(last_page-first_page));
         }
  
@@ -3024,11 +3078,11 @@ static void
  print_ptr(lispobj *addr)
  {
      /* If addr is in the dynamic space then out the page information. */
  print_ptr(lispobj *addr)
  {
      /* If addr is in the dynamic space then out the page information. */
-    int pi1 = find_page_index((void*)addr);
+    long pi1 = find_page_index((void*)addr);
  
      if (pi1 != -1)
         fprintf(stderr,"  %x: page %d  alloc %d  gen %d  bytes_used %d  offset %d  dont_move %d\n",
  
      if (pi1 != -1)
         fprintf(stderr,"  %x: page %d  alloc %d  gen %d  bytes_used %d  offset %d  dont_move %d\n",
-               (unsigned int) addr,
+               (unsigned long) addr,
                 pi1,
                 page_table[pi1].allocated,
                 page_table[pi1].gen,
                 pi1,
                 page_table[pi1].allocated,
                 page_table[pi1].gen,
@@ -3048,7 +3102,7 @@ print_ptr(lispobj *addr)
  }
  #endif
  
  }
  #endif
  
-extern int undefined_tramp;
+extern long undefined_tramp;
  
  static void
  verify_space(lispobj *start, size_t words)
  
  static void
  verify_space(lispobj *start, size_t words)
@@ -3063,11 +3117,11 @@ verify_space(lispobj *start, size_t words)
         lispobj thing = *(lispobj*)start;
  
         if (is_lisp_pointer(thing)) {
         lispobj thing = *(lispobj*)start;
  
         if (is_lisp_pointer(thing)) {
-           int page_index = find_page_index((void*)thing);
-           int to_readonly_space =
+           long page_index = find_page_index((void*)thing);
+           long to_readonly_space =
                 (READ_ONLY_SPACE_START <= thing &&
                  thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
                 (READ_ONLY_SPACE_START <= thing &&
                  thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
-           int to_static_space =
+           long to_static_space =
                 (STATIC_SPACE_START <= thing &&
                  thing < SymbolValue(STATIC_SPACE_FREE_POINTER,0));
  
                 (STATIC_SPACE_START <= thing &&
                  thing < SymbolValue(STATIC_SPACE_FREE_POINTER,0));
  
@@ -3142,7 +3196,7 @@ verify_space(lispobj *start, size_t words)
                     {
                         lispobj object = *start;
                         struct code *code;
                     {
                         lispobj object = *start;
                         struct code *code;
-                       int nheader_words, ncode_words, nwords;
+                       long nheader_words, ncode_words, nwords;
                         lispobj fheaderl;
                         struct simple_fun *fheaderp;
  
                         lispobj fheaderl;
                         struct simple_fun *fheaderp;
  
@@ -3220,9 +3274,20 @@ verify_space(lispobj *start, size_t words)
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+#endif
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
                 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
                 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
                 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
@@ -3235,6 +3300,12 @@ verify_space(lispobj *start, size_t words)
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
                 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
                 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+               case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+               case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
                 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
                 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
                 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
                 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
@@ -3273,15 +3344,15 @@ verify_gc(void)
       * Some counts of lispobjs are called foo_count; it might be good
       * to grep for all foo_size and rename the appropriate ones to
       * foo_count. */
       * Some counts of lispobjs are called foo_count; it might be good
       * to grep for all foo_size and rename the appropriate ones to
       * foo_count. */
-    int read_only_space_size =
+    long read_only_space_size =
         (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)
         - (lispobj*)READ_ONLY_SPACE_START;
         (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)
         - (lispobj*)READ_ONLY_SPACE_START;
-    int static_space_size =
+    long static_space_size =
         (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0)
         - (lispobj*)STATIC_SPACE_START;
      struct thread *th;
      for_each_thread(th) {
         (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0)
         - (lispobj*)STATIC_SPACE_START;
      struct thread *th;
      for_each_thread(th) {
-    int binding_stack_size =
+    long binding_stack_size =
             (lispobj*)SymbolValue(BINDING_STACK_POINTER,th)
             - (lispobj*)th->binding_stack_start;
         verify_space(th->binding_stack_start, binding_stack_size);
             (lispobj*)SymbolValue(BINDING_STACK_POINTER,th)
             - (lispobj*)th->binding_stack_start;
         verify_space(th->binding_stack_start, binding_stack_size);
@@ -3299,7 +3370,7 @@ verify_generation(int  generation)
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
             && (page_table[i].bytes_used != 0)
             && (page_table[i].gen == generation)) {
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
             && (page_table[i].bytes_used != 0)
             && (page_table[i].gen == generation)) {
-           int last_page;
+           long last_page;
             int region_allocation = page_table[i].allocated;
  
             /* This should be the start of a contiguous block */
             int region_allocation = page_table[i].allocated;
  
             /* This should be the start of a contiguous block */
@@ -3322,7 +3393,7 @@ verify_generation(int  generation)
                     break;
  
             verify_space(page_address(i), (page_table[last_page].bytes_used
                     break;
  
             verify_space(page_address(i), (page_table[last_page].bytes_used
-                                          + (last_page-i)*PAGE_BYTES)/4);
+                                          + (last_page-i)*PAGE_BYTES)/N_WORD_BYTES);
             i = last_page;
         }
      }
             i = last_page;
         }
      }
@@ -3332,26 +3403,26 @@ verify_generation(int  generation)
  static void
  verify_zero_fill(void)
  {
  static void
  verify_zero_fill(void)
  {
-    int page;
+    long page;
  
      for (page = 0; page < last_free_page; page++) {
         if (page_table[page].allocated == FREE_PAGE_FLAG) {
             /* The whole page should be zero filled. */
  
      for (page = 0; page < last_free_page; page++) {
         if (page_table[page].allocated == FREE_PAGE_FLAG) {
             /* The whole page should be zero filled. */
-           int *start_addr = (int *)page_address(page);
-           int size = 1024;
-           int i;
+           long *start_addr = (long *)page_address(page);
+           long size = 1024;
+           long i;
             for (i = 0; i < size; i++) {
                 if (start_addr[i] != 0) {
                     lose("free page not zero at %x", start_addr + i);
                 }
             }
         } else {
             for (i = 0; i < size; i++) {
                 if (start_addr[i] != 0) {
                     lose("free page not zero at %x", start_addr + i);
                 }
             }
         } else {
-           int free_bytes = PAGE_BYTES - page_table[page].bytes_used;
+           long free_bytes = PAGE_BYTES - page_table[page].bytes_used;
             if (free_bytes > 0) {
             if (free_bytes > 0) {
-               int *start_addr = (int *)((unsigned)page_address(page)
+               long *start_addr = (long *)((unsigned)page_address(page)
                                           + page_table[page].bytes_used);
                                           + page_table[page].bytes_used);
-               int size = free_bytes / N_WORD_BYTES;
-               int i;
+               long size = free_bytes / N_WORD_BYTES;
+               long i;
                 for (i = 0; i < size; i++) {
                     if (start_addr[i] != 0) {
                         lose("free region not zero at %x", start_addr + i);
                 for (i = 0; i < size; i++) {
                     if (start_addr[i] != 0) {
                         lose("free region not zero at %x", start_addr + i);
@@ -3375,7 +3446,7 @@ gencgc_verify_zero_fill(void)
  static void
  verify_dynamic_space(void)
  {
  static void
  verify_dynamic_space(void)
  {
-    int i;
+    long i;
  
      for (i = 0; i < NUM_GENERATIONS; i++)
         verify_generation(i);
  
      for (i = 0; i < NUM_GENERATIONS; i++)
         verify_generation(i);
@@ -3388,7 +3459,7 @@ verify_dynamic_space(void)
  static void
  write_protect_generation_pages(int generation)
  {
  static void
  write_protect_generation_pages(int generation)
  {
-    int i;
+    long i;
  
      gc_assert(generation < NUM_GENERATIONS);
  
  
      gc_assert(generation < NUM_GENERATIONS);
  
@@ -3439,8 +3510,9 @@ garbage_collect_generation(int generation, int raise)
       * temporary generation (NUM_GENERATIONS), and lowered when
       * done. Set up this new generation. There should be no pages
       * allocated to it yet. */
       * temporary generation (NUM_GENERATIONS), and lowered when
       * done. Set up this new generation. There should be no pages
       * allocated to it yet. */
-    if (!raise)
-       gc_assert(generations[NUM_GENERATIONS].bytes_allocated == 0);
+    if (!raise) {
+        gc_assert(generations[NUM_GENERATIONS].bytes_allocated == 0);
+    }
  
      /* Set the global src and dest. generations */
      from_space = generation;
  
      /* Set the global src and dest. generations */
      from_space = generation;
@@ -3488,7 +3560,7 @@ garbage_collect_generation(int generation, int raise)
         void **ptr;
         void **esp=(void **)-1;
  #ifdef LISP_FEATURE_SB_THREAD
         void **ptr;
         void **esp=(void **)-1;
  #ifdef LISP_FEATURE_SB_THREAD
-       int i,free;
+       long i,free;
         if(th==arch_os_get_current_thread()) {
             esp = (void **) &raise;
         } else {
         if(th==arch_os_get_current_thread()) {
             esp = (void **) &raise;
         } else {
@@ -3515,7 +3587,7 @@ garbage_collect_generation(int generation, int raise)
  
  #ifdef QSHOW
      if (gencgc_verbose > 1) {
  
  #ifdef QSHOW
      if (gencgc_verbose > 1) {
-       int num_dont_move_pages = count_dont_move_pages();
+       long num_dont_move_pages = count_dont_move_pages();
         fprintf(stderr,
                 "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
                 num_dont_move_pages,
         fprintf(stderr,
                 "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
                 num_dont_move_pages,
@@ -3607,8 +3679,8 @@ garbage_collect_generation(int generation, int raise)
      /* As a check re-scavenge the newspace once; no new objects should
       * be found. */
      {
      /* As a check re-scavenge the newspace once; no new objects should
       * be found. */
      {
-       int old_bytes_allocated = bytes_allocated;
-       int bytes_allocated;
+       long old_bytes_allocated = bytes_allocated;
+       long bytes_allocated;
  
         /* Start with a full scavenge. */
         scavenge_newspace_generation_one_scan(new_space);
  
         /* Start with a full scavenge. */
         scavenge_newspace_generation_one_scan(new_space);
@@ -3671,13 +3743,13 @@ garbage_collect_generation(int generation, int raise)
  }
  
  /* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */
  }
  
  /* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */
-int
+long
  update_x86_dynamic_space_free_pointer(void)
  {
  update_x86_dynamic_space_free_pointer(void)
  {
-    int last_page = -1;
-    int i;
+    long last_page = -1;
+    long i;
  
  
-    for (i = 0; i < NUM_PAGES; i++)
+    for (i = 0; i < last_free_page; i++)
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
             && (page_table[i].bytes_used != 0))
             last_page = i;
         if ((page_table[i].allocated != FREE_PAGE_FLAG)
             && (page_table[i].bytes_used != 0))
             last_page = i;
@@ -3704,7 +3776,7 @@ collect_garbage(unsigned last_gen)
      int gen = 0;
      int raise;
      int gen_to_wp;
      int gen = 0;
      int raise;
      int gen_to_wp;
-    int i;
+    long i;
  
      FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
  
  
      FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
  
@@ -3822,7 +3894,7 @@ collect_garbage(unsigned last_gen)
  void
  gc_free_heap(void)
  {
  void
  gc_free_heap(void)
  {
-    int page;
+    long page;
  
      if (gencgc_verbose > 1)
         SHOW("entering gc_free_heap");
  
      if (gencgc_verbose > 1)
         SHOW("entering gc_free_heap");
@@ -3856,10 +3928,10 @@ gc_free_heap(void)
             }
         } else if (gencgc_zero_check_during_free_heap) {
             /* Double-check that the page is zero filled. */
             }
         } else if (gencgc_zero_check_during_free_heap) {
             /* Double-check that the page is zero filled. */
-           int *page_start, i;
+           long *page_start, i;
             gc_assert(page_table[page].allocated == FREE_PAGE_FLAG);
             gc_assert(page_table[page].bytes_used == 0);
             gc_assert(page_table[page].allocated == FREE_PAGE_FLAG);
             gc_assert(page_table[page].bytes_used == 0);
-           page_start = (int *)page_address(page);
+           page_start = (long *)page_address(page);
             for (i=0; i<1024; i++) {
                 if (page_start[i] != 0) {
                     lose("free region not zero at %x", page_start + i);
             for (i=0; i<1024; i++) {
                 if (page_start[i] != 0) {
                     lose("free region not zero at %x", page_start + i);
@@ -3905,7 +3977,7 @@ gc_free_heap(void)
  void
  gc_init(void)
  {
  void
  gc_init(void)
  {
-    int i;
+    long i;
  
      gc_init_tables();
      scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
  
      gc_init_tables();
      scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
@@ -3961,8 +4033,8 @@ gc_init(void)
  static void
  gencgc_pickup_dynamic(void)
  {
  static void
  gencgc_pickup_dynamic(void)
  {
-    int page = 0;
-    int alloc_ptr = SymbolValue(ALLOCATION_POINTER,0);
+    long page = 0;
+    long alloc_ptr = SymbolValue(ALLOCATION_POINTER,0);
      lispobj *prev=(lispobj *)page_address(page);
  
      do {
      lispobj *prev=(lispobj *)page_address(page);
  
      do {
@@ -4007,7 +4079,7 @@ gc_initialize_pointers(void)
   * region is full, so in most cases it's not needed. */
  
  char *
   * region is full, so in most cases it's not needed. */
  
  char *
-alloc(int nbytes)
+alloc(long nbytes)
  {
      struct thread *th=arch_os_get_current_thread();
      struct alloc_region *region=
  {
      struct thread *th=arch_os_get_current_thread();
      struct alloc_region *region=
@@ -4018,10 +4090,11 @@ alloc(int nbytes)
  #endif
      void *new_obj;
      void *new_free_pointer;
  #endif
      void *new_obj;
      void *new_free_pointer;
-
+    gc_assert(nbytes>0);
      /* Check for alignment allocation problems. */
      /* Check for alignment allocation problems. */
-    gc_assert((((unsigned)region->free_pointer & 0x7) == 0)
-             && ((nbytes & 0x7) == 0));
+    gc_assert((((unsigned)region->free_pointer & LOWTAG_MASK) == 0)
+             && ((nbytes & LOWTAG_MASK) == 0));
+#if 0
      if(all_threads)
         /* there are a few places in the C code that allocate data in the
          * heap before Lisp starts.  This is before interrupts are enabled,
      if(all_threads)
         /* there are a few places in the C code that allocate data in the
          * heap before Lisp starts.  This is before interrupts are enabled,
@@ -4039,6 +4112,7 @@ alloc(int nbytes)
  #else
      gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th));
  #endif
  #else
      gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th));
  #endif
+#endif
      
      /* maybe we can do this quickly ... */
      new_free_pointer = region->free_pointer + nbytes;
      
      /* maybe we can do this quickly ... */
      new_free_pointer = region->free_pointer + nbytes;
@@ -4085,7 +4159,7 @@ void unhandled_sigmemoryfault(void);
  int
  gencgc_handle_wp_violation(void* fault_addr)
  {
  int
  gencgc_handle_wp_violation(void* fault_addr)
  {
-    int  page_index = find_page_index(fault_addr);
+    long  page_index = find_page_index(fault_addr);
  
  #ifdef QSHOW_SIGNALS
      FSHOW((stderr, "heap WP violation? fault_addr=%x, page_index=%d\n",
  
  #ifdef QSHOW_SIGNALS
      FSHOW((stderr, "heap WP violation? fault_addr=%x, page_index=%d\n",
diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c

index 0067a10..8a5a20f 100644 (file)
--- a/src/runtime/interrupt.c
+++ b/src/runtime/interrupt.c
@@ -161,7 +161,7 @@ void reset_signal_mask ()
  void 
  build_fake_control_stack_frames(struct thread *th,os_context_t *context)
  {
  void 
  build_fake_control_stack_frames(struct thread *th,os_context_t *context)
  {
-#ifndef LISP_FEATURE_X86
+#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
      
      lispobj oldcont;
  
      
      lispobj oldcont;
  
@@ -364,7 +364,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
  {
      os_context_t *context = (os_context_t*)void_context;
      struct thread *thread=arch_os_get_current_thread();
  {
      os_context_t *context = (os_context_t*)void_context;
      struct thread *thread=arch_os_get_current_thread();
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
      boolean were_in_lisp;
  #endif
      union interrupt_handler handler;
      boolean were_in_lisp;
  #endif
      union interrupt_handler handler;
@@ -381,7 +381,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
         return;
      }
      
         return;
      }
      
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
      were_in_lisp = !foreign_function_call_active;
      if (were_in_lisp)
  #endif
      were_in_lisp = !foreign_function_call_active;
      if (were_in_lisp)
  #endif
@@ -440,7 +440,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
          (*handler.c)(signal, info, void_context);
      }
  
          (*handler.c)(signal, info, void_context);
      }
  
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
      if (were_in_lisp)
  #endif
      {
      if (were_in_lisp)
  #endif
      {
@@ -481,7 +481,7 @@ maybe_defer_handler(void *handler, struct interrupt_data *data,
       * actually use its argument for anything on x86, so this branch
       * may succeed even when context is null (gencgc alloc()) */
      if (
       * actually use its argument for anything on x86, so this branch
       * may succeed even when context is null (gencgc alloc()) */
      if (
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
         (!foreign_function_call_active) &&
  #endif
         arch_pseudo_atomic_atomic(context)) {
         (!foreign_function_call_active) &&
  #endif
         arch_pseudo_atomic_atomic(context)) {
@@ -684,6 +684,8 @@ void arrange_return_to_lisp_function(os_context_t *context, lispobj function)
  #else
      *os_context_register_addr(context,reg_ESP) = sp-14;
  #endif
  #else
      *os_context_register_addr(context,reg_ESP) = sp-14;
  #endif
+#elif defined(LISP_FEATURE_X86_64)
+    lose("deferred gubbins still needs to be written");
  #else
      /* this much of the calling convention is common to all
         non-x86 ports */
  #else
      /* this much of the calling convention is common to all
         non-x86 ports */
diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c

index 2c91308..dd7808d 100644 (file)
--- a/src/runtime/monitor.c
+++ b/src/runtime/monitor.c
@@ -176,17 +176,17 @@ regs_cmd(char **ptr)
  {
      printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer);
      printf("FP\t=\t0x%08lX\n", (unsigned long)current_control_frame_pointer);
  {
      printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer);
      printf("FP\t=\t0x%08lX\n", (unsigned long)current_control_frame_pointer);
-#if !defined(LISP_FEATURE_X86)
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
  #endif
  #if 0
      printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
  #endif
  #if 0
-#ifdef LISP_FEATURE_X86
+#if (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      printf("BSP\t=\t0x%08lx\n",
            (unsigned long)SymbolValue(BINDING_STACK_POINTER));
  #endif
  
      printf("DYNAMIC\t=\t0x%08lx\n", (unsigned long)DYNAMIC_SPACE_START);
      printf("BSP\t=\t0x%08lx\n",
            (unsigned long)SymbolValue(BINDING_STACK_POINTER));
  #endif
  
      printf("DYNAMIC\t=\t0x%08lx\n", (unsigned long)DYNAMIC_SPACE_START);
-#if defined(LISP_FEATURE_X86)
+#if (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      printf("ALLOC\t=\t0x%08lx\n",
            (unsigned long)SymbolValue(ALLOCATION_POINTER));
  #else
      printf("ALLOC\t=\t0x%08lx\n",
            (unsigned long)SymbolValue(ALLOCATION_POINTER));
  #else
@@ -393,7 +393,7 @@ catchers_cmd(char **ptr)
          printf("There are no active catchers!\n");
      else {
          while (catch != NULL) {
          printf("There are no active catchers!\n");
      else {
          while (catch != NULL) {
-#ifndef LISP_FEATURE_X86
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
              printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\tcode: 0x%08lx\n\tentry: 0x%08lx\n\ttag: ",
                    (unsigned long)catch, (unsigned long)(catch->current_uwp),
                    (unsigned long)(catch->current_cont),
              printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\tcode: 0x%08lx\n\tentry: 0x%08lx\n\ttag: ",
                    (unsigned long)catch, (unsigned long)(catch->current_uwp),
                    (unsigned long)(catch->current_cont),
diff --git a/src/runtime/parse.c b/src/runtime/parse.c

index f6c6360..fd89930 100644 (file)
--- a/src/runtime/parse.c
+++ b/src/runtime/parse.c
@@ -258,7 +258,7 @@ static boolean lookup_symbol(char *name, lispobj *result)
  
      /* Search dynamic space. */
      headerptr = (lispobj *)DYNAMIC_SPACE_START;
  
      /* Search dynamic space. */
      headerptr = (lispobj *)DYNAMIC_SPACE_START;
-#if !defined(LISP_FEATURE_X86)
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      count =
         dynamic_space_free_pointer -
         (lispobj *)DYNAMIC_SPACE_START;
      count =
         dynamic_space_free_pointer -
         (lispobj *)DYNAMIC_SPACE_START;
diff --git a/src/runtime/purify.c b/src/runtime/purify.c

index 3750895..480227d 100644 (file)
--- a/src/runtime/purify.c
+++ b/src/runtime/purify.c
@@ -66,7 +66,7 @@ static lispobj *read_only_end, *static_end;
  
  static lispobj *read_only_free, *static_free;
  
  
  static lispobj *read_only_free, *static_free;
  
-static lispobj *pscav(lispobj *addr, int nwords, boolean constant);
+static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
  
  #define LATERBLOCKSIZE 1020
  #define LATERMAXCOUNT 10
  
  #define LATERBLOCKSIZE 1020
  #define LATERMAXCOUNT 10
@@ -76,10 +76,16 @@ later {
      struct later *next;
      union {
          lispobj *ptr;
      struct later *next;
      union {
          lispobj *ptr;
-        int count;
+        long count;
      } u[LATERBLOCKSIZE];
  } *later_blocks = NULL;
      } u[LATERBLOCKSIZE];
  } *later_blocks = NULL;
-static int later_count = 0;
+static long later_count = 0;
+
+#if N_WORD_BITS == 32
+ #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
+#elif N_WORD_BITS == 64
+ #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+#endif
  
  /* FIXME: Shouldn't this be defined in sbcl.h?  See also notes in
   * cheneygc.c */
  
  /* FIXME: Shouldn't this be defined in sbcl.h?  See also notes in
   * cheneygc.c */
@@ -115,7 +121,7 @@ dynamic_pointer_p(lispobj ptr)
  }
  
  static inline lispobj *
  }
  
  static inline lispobj *
-newspace_alloc(int nwords, int constantp) 
+newspace_alloc(long nwords, int constantp) 
  {
      lispobj *ret;
      nwords=CEILING(nwords,2);
  {
      lispobj *ret;
      nwords=CEILING(nwords,2);
@@ -131,7 +137,7 @@ newspace_alloc(int nwords, int constantp)
  
  
  \f
  
  
  \f
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
  
  #ifdef LISP_FEATURE_GENCGC
  /*
  
  #ifdef LISP_FEATURE_GENCGC
  /*
@@ -173,27 +179,28 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
             break;
         case CLOSURE_HEADER_WIDETAG:
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
             break;
         case CLOSURE_HEADER_WIDETAG:
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
-           if ((int)pointer != ((int)start_addr+FUN_POINTER_LOWTAG)) {
+           if ((long)pointer != ((long)start_addr+FUN_POINTER_LOWTAG)) {
                 if (pointer_filter_verbose) {
                 if (pointer_filter_verbose) {
-                   fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer, 
-                           (unsigned int) start_addr, *start_addr);
+                   fprintf(stderr,"*Wf2: %x %x %x\n", 
+                           (unsigned long) pointer, 
+                           (unsigned long) start_addr, *start_addr);
                 }
                 return 0;
             }
             break;
         default:
             if (pointer_filter_verbose) {
                 }
                 return 0;
             }
             break;
         default:
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
         break;
      case LIST_POINTER_LOWTAG:
             }
             return 0;
         }
         break;
      case LIST_POINTER_LOWTAG:
-       if ((int)pointer != ((int)start_addr+LIST_POINTER_LOWTAG)) {
+       if ((long)pointer != ((long)start_addr+LIST_POINTER_LOWTAG)) {
             if (pointer_filter_verbose)
             if (pointer_filter_verbose)
-               fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             return 0;
         }
         /* Is it plausible cons? */
             return 0;
         }
         /* Is it plausible cons? */
@@ -208,40 +215,40 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
             break;
         } else {
             if (pointer_filter_verbose) {
             break;
         } else {
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
      case INSTANCE_POINTER_LOWTAG:
             }
             return 0;
         }
      case INSTANCE_POINTER_LOWTAG:
-       if ((int)pointer != ((int)start_addr+INSTANCE_POINTER_LOWTAG)) {
+       if ((long)pointer != ((long)start_addr+INSTANCE_POINTER_LOWTAG)) {
             if (pointer_filter_verbose) {
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
             if (pointer_filter_verbose) {
             }
             return 0;
         }
         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
         break;
      case OTHER_POINTER_LOWTAG:
             }
             return 0;
         }
         break;
      case OTHER_POINTER_LOWTAG:
-       if ((int)pointer != ((int)start_addr+OTHER_POINTER_LOWTAG)) {
+       if ((long)pointer != ((long)start_addr+OTHER_POINTER_LOWTAG)) {
             if (pointer_filter_verbose) {
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
         /* Is it plausible? Not a cons. XXX should check the headers. */
         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
             if (pointer_filter_verbose) {
             }
             return 0;
         }
         /* Is it plausible? Not a cons. XXX should check the headers. */
         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
             }
             return 0;
         }
@@ -249,8 +256,8 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
         case UNBOUND_MARKER_WIDETAG:
         case CHARACTER_WIDETAG:
             if (pointer_filter_verbose) {
         case UNBOUND_MARKER_WIDETAG:
         case CHARACTER_WIDETAG:
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
  
             }
             return 0;
  
@@ -258,15 +265,15 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
         case CLOSURE_HEADER_WIDETAG:
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
             if (pointer_filter_verbose) {
         case CLOSURE_HEADER_WIDETAG:
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
  
         case INSTANCE_HEADER_WIDETAG:
             if (pointer_filter_verbose) {
             }
             return 0;
  
         case INSTANCE_HEADER_WIDETAG:
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
  
             }
             return 0;
  
@@ -314,9 +321,20 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+#endif
         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+               case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
  #endif
@@ -329,6 +347,12 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
  #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
  #endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+               case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+               case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
@@ -349,16 +373,16 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
  
         default:
             if (pointer_filter_verbose) {
  
         default:
             if (pointer_filter_verbose) {
-               fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer, 
-                       (unsigned int) start_addr, *start_addr);
+               fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned long) pointer, 
+                       (unsigned long) start_addr, *start_addr);
             }
             return 0;
         }
         break;
      default:
         if (pointer_filter_verbose) {
             }
             return 0;
         }
         break;
      default:
         if (pointer_filter_verbose) {
-           fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer, 
-                   (unsigned int) start_addr, *start_addr);
+           fprintf(stderr,"*W?: %x %x %x\n", (unsigned long) pointer, 
+                   (unsigned long) start_addr, *start_addr);
         }
         return 0;
      }
         }
         return 0;
      }
@@ -369,12 +393,12 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
  
  #define MAX_STACK_POINTERS 256
  lispobj *valid_stack_locations[MAX_STACK_POINTERS];
  
  #define MAX_STACK_POINTERS 256
  lispobj *valid_stack_locations[MAX_STACK_POINTERS];
-unsigned int num_valid_stack_locations;
+unsigned long num_valid_stack_locations;
  
  #define MAX_STACK_RETURN_ADDRESSES 128
  lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
  lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
  
  #define MAX_STACK_RETURN_ADDRESSES 128
  lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
  lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
-unsigned int num_valid_stack_ra_locations;
+unsigned long num_valid_stack_ra_locations;
  
  /* Identify valid stack slots. */
  static void
  
  /* Identify valid stack slots. */
  static void
@@ -401,7 +425,7 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
                           MAX_STACK_RETURN_ADDRESSES);
                 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
                 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
                           MAX_STACK_RETURN_ADDRESSES);
                 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
                 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
-                   (lispobj *)((int)start_addr + OTHER_POINTER_LOWTAG);
+                   (lispobj *)((long)start_addr + OTHER_POINTER_LOWTAG);
             } else {
                 if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
                     gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
             } else {
                 if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
                     gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
@@ -421,7 +445,7 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
  static void
  pscav_i386_stack(void)
  {
  static void
  pscav_i386_stack(void)
  {
-    int i;
+    long i;
  
      for (i = 0; i < num_valid_stack_locations; i++)
         pscav(valid_stack_locations[i], 1, 0);
  
      for (i = 0; i < num_valid_stack_locations; i++)
         pscav(valid_stack_locations[i], 1, 0);
@@ -432,13 +456,13 @@ pscav_i386_stack(void)
         if (pointer_filter_verbose) {
             fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
                     *valid_stack_ra_locations[i],
         if (pointer_filter_verbose) {
             fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
                     *valid_stack_ra_locations[i],
-                   (int)(*valid_stack_ra_locations[i])
-                   - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
-                   (unsigned int) valid_stack_ra_code_objects[i], code_obj);
+                   (long)(*valid_stack_ra_locations[i])
+                   - ((long)valid_stack_ra_code_objects[i] - (long)code_obj),
+                   (unsigned long) valid_stack_ra_code_objects[i], code_obj);
         }
         *valid_stack_ra_locations[i] =
         }
         *valid_stack_ra_locations[i] =
-           ((int)(*valid_stack_ra_locations[i])
-            - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
+           ((long)(*valid_stack_ra_locations[i])
+            - ((long)valid_stack_ra_code_objects[i] - (long)code_obj));
      }
  }
  #endif
      }
  }
  #endif
@@ -446,7 +470,7 @@ pscav_i386_stack(void)
  
  \f
  static void
  
  \f
  static void
-pscav_later(lispobj *where, int count)
+pscav_later(lispobj *where, long count)
  {
      struct later *new;
  
  {
      struct later *new;
  
@@ -477,10 +501,10 @@ pscav_later(lispobj *where, int count)
  static lispobj
  ptrans_boxed(lispobj thing, lispobj header, boolean constant)
  {
  static lispobj
  ptrans_boxed(lispobj thing, lispobj header, boolean constant)
  {
-    int nwords;
+    long nwords;
      lispobj result, *new, *old;
  
      lispobj result, *new, *old;
  
-    nwords = 1 + HeaderValue(header);
+    nwords = CEILING(1 + HeaderValue(header), 2);
  
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
  
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
@@ -520,10 +544,10 @@ ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
              * space placed into it (e.g. the cache-name slot), but
              * the lists and arrays at the time of a purify can be
              * moved to the RO space. */
              * space placed into it (e.g. the cache-name slot), but
              * the lists and arrays at the time of a purify can be
              * moved to the RO space. */
-           int nwords;
+           long nwords;
             lispobj result, *new, *old;
  
             lispobj result, *new, *old;
  
-           nwords = 1 + HeaderValue(header);
+           nwords = CEILING(1 + HeaderValue(header), 2);
  
             /* Allocate it */
             old = (lispobj *)native_pointer(thing);
  
             /* Allocate it */
             old = (lispobj *)native_pointer(thing);
@@ -550,11 +574,11 @@ ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
  static lispobj
  ptrans_fdefn(lispobj thing, lispobj header)
  {
  static lispobj
  ptrans_fdefn(lispobj thing, lispobj header)
  {
-    int nwords;
+    long nwords;
      lispobj result, *new, *old, oldfn;
      struct fdefn *fdefn;
  
      lispobj result, *new, *old, oldfn;
      struct fdefn *fdefn;
  
-    nwords = 1 + HeaderValue(header);
+    nwords = CEILING(1 + HeaderValue(header), 2);
  
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
  
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
@@ -580,10 +604,10 @@ ptrans_fdefn(lispobj thing, lispobj header)
  static lispobj
  ptrans_unboxed(lispobj thing, lispobj header)
  {
  static lispobj
  ptrans_unboxed(lispobj thing, lispobj header)
  {
-    int nwords;
+    long nwords;
      lispobj result, *new, *old;
      
      lispobj result, *new, *old;
      
-    nwords = 1 + HeaderValue(header);
+    nwords = CEILING(1 + HeaderValue(header), 2);
      
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
      
      /* Allocate it */
      old = (lispobj *)native_pointer(thing);
@@ -600,15 +624,22 @@ ptrans_unboxed(lispobj thing, lispobj header)
  }
  
  static lispobj
  }
  
  static lispobj
-ptrans_vector(lispobj thing, int bits, int extra,
+ptrans_vector(lispobj thing, long bits, long extra,
               boolean boxed, boolean constant)
  {
      struct vector *vector;
               boolean boxed, boolean constant)
  {
      struct vector *vector;
-    int nwords;
+    long nwords;
      lispobj result, *new;
      lispobj result, *new;
+    long length;
  
      vector = (struct vector *)native_pointer(thing);
  
      vector = (struct vector *)native_pointer(thing);
-    nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
+    length = fixnum_value(vector->length)+extra;
+    // Argh, handle simple-vector-nil separately.
+    if (bits == 0) {
+      nwords = 2;
+    } else {
+      nwords = CEILING(NWORDS(length, bits) + 2, 2);
+    } 
  
      new=newspace_alloc(nwords, (constant || !boxed));
      bcopy(vector, new, nwords * sizeof(lispobj));
  
      new=newspace_alloc(nwords, (constant || !boxed));
      bcopy(vector, new, nwords * sizeof(lispobj));
@@ -622,11 +653,11 @@ ptrans_vector(lispobj thing, int bits, int extra,
      return result;
  }
  
      return result;
  }
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
  static void
  apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
  {
  static void
  apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
  {
-    int nheader_words, ncode_words, nwords;
+    long nheader_words, ncode_words, nwords;
      void  *constants_start_addr, *constants_end_addr;
      void  *code_start_addr, *code_end_addr;
      lispobj fixups = NIL;
      void  *constants_start_addr, *constants_end_addr;
      void  *code_start_addr, *code_end_addr;
      lispobj fixups = NIL;
@@ -637,10 +668,10 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
      nheader_words = HeaderValue(*(lispobj *)new_code);
      nwords = ncode_words + nheader_words;
  
      nheader_words = HeaderValue(*(lispobj *)new_code);
      nwords = ncode_words + nheader_words;
  
-    constants_start_addr = (void *)new_code + 5*4;
-    constants_end_addr = (void *)new_code + nheader_words*4;
-    code_start_addr = (void *)new_code + nheader_words*4;
-    code_end_addr = (void *)new_code + nwords*4;
+    constants_start_addr = (void *)new_code + 5 * N_WORD_BYTES;
+    constants_end_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
+    code_start_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
+    code_end_addr = (void *)new_code + nwords*N_WORD_BYTES;
  
      /* The first constant should be a pointer to the fixups for this
       * code objects. Check. */
  
      /* The first constant should be a pointer to the fixups for this
       * code objects. Check. */
@@ -668,12 +699,11 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
             (struct vector *)native_pointer(*(lispobj *)fixups_vector);
      }
  
             (struct vector *)native_pointer(*(lispobj *)fixups_vector);
      }
  
-    if (widetag_of(fixups_vector->header) ==
-       SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG) {
+    if (widetag_of(fixups_vector->header) == SIMPLE_ARRAY_WORD_WIDETAG) {
         /* We got the fixups for the code block. Now work through the
          * vector, and apply a fixup at each address. */
         /* We got the fixups for the code block. Now work through the
          * vector, and apply a fixup at each address. */
-       int length = fixnum_value(fixups_vector->length);
-       int i;
+       long length = fixnum_value(fixups_vector->length);
+       long i;
         for (i=0; i<length; i++) {
             unsigned offset = fixups_vector->data[i];
             /* Now check the current value of offset. */
         for (i=0; i<length; i++) {
             unsigned offset = fixups_vector->data[i];
             /* Now check the current value of offset. */
@@ -683,7 +713,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
             /* If it's within the old_code object then it must be an
              * absolute fixup (relative ones are not saved) */
             if ((old_value>=(unsigned)old_code)
             /* If it's within the old_code object then it must be an
              * absolute fixup (relative ones are not saved) */
             if ((old_value>=(unsigned)old_code)
-               && (old_value<((unsigned)old_code + nwords*4)))
+               && (old_value<((unsigned)old_code + nwords * N_WORD_BYTES)))
                 /* So add the dispacement. */
                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
                     + displacement;
                 /* So add the dispacement. */
                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
                     + displacement;
@@ -710,17 +740,18 @@ static lispobj
  ptrans_code(lispobj thing)
  {
      struct code *code, *new;
  ptrans_code(lispobj thing)
  {
      struct code *code, *new;
-    int nwords;
+    long nwords;
      lispobj func, result;
  
      code = (struct code *)native_pointer(thing);
      lispobj func, result;
  
      code = (struct code *)native_pointer(thing);
-    nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
+    nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
+                    2);
  
      new = (struct code *)newspace_alloc(nwords,1); /* constant */
  
      bcopy(code, new, nwords * sizeof(lispobj));
  
  
      new = (struct code *)newspace_alloc(nwords,1); /* constant */
  
      bcopy(code, new, nwords * sizeof(lispobj));
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
      apply_code_fixups_during_purify(code,new);
  #endif
  
      apply_code_fixups_during_purify(code,new);
  #endif
  
@@ -765,13 +796,13 @@ ptrans_code(lispobj thing)
          gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
          gc_assert(!dynamic_pointer_p(func));
  
          gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
          gc_assert(!dynamic_pointer_p(func));
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
         /* Temporarily convert the self pointer to a real function pointer. */
         ((struct simple_fun *)native_pointer(func))->self
             -= FUN_RAW_ADDR_OFFSET;
  #endif
          pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
         /* Temporarily convert the self pointer to a real function pointer. */
         ((struct simple_fun *)native_pointer(func))->self
             -= FUN_RAW_ADDR_OFFSET;
  #endif
          pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
         ((struct simple_fun *)native_pointer(func))->self
             += FUN_RAW_ADDR_OFFSET;
  #endif
         ((struct simple_fun *)native_pointer(func))->self
             += FUN_RAW_ADDR_OFFSET;
  #endif
@@ -784,7 +815,7 @@ ptrans_code(lispobj thing)
  static lispobj
  ptrans_func(lispobj thing, lispobj header)
  {
  static lispobj
  ptrans_func(lispobj thing, lispobj header)
  {
-    int nwords;
+    long nwords;
      lispobj code, *new, *old, result;
      struct simple_fun *function;
  
      lispobj code, *new, *old, result;
      struct simple_fun *function;
  
@@ -816,7 +847,7 @@ ptrans_func(lispobj thing, lispobj header)
      }
      else {
         /* It's some kind of closure-like thing. */
      }
      else {
         /* It's some kind of closure-like thing. */
-        nwords = 1 + HeaderValue(header);
+        nwords = CEILING(1 + HeaderValue(header), 2);
          old = (lispobj *)native_pointer(thing);
  
         /* Allocate the new one.  FINs *must* not go in read_only
          old = (lispobj *)native_pointer(thing);
  
         /* Allocate the new one.  FINs *must* not go in read_only
@@ -862,7 +893,7 @@ static lispobj
  ptrans_list(lispobj thing, boolean constant)
  {
      struct cons *old, *new, *orig;
  ptrans_list(lispobj thing, boolean constant)
  {
      struct cons *old, *new, *orig;
-    int length;
+    long length;
  
      orig = (struct cons *) newspace_alloc(0,constant);
      length = 0;
  
      orig = (struct cons *) newspace_alloc(0,constant);
      length = 0;
@@ -949,7 +980,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
          return ptrans_vector(thing, 1, 0, 0, constant);
  
        case SIMPLE_VECTOR_WIDETAG:
          return ptrans_vector(thing, 1, 0, 0, constant);
  
        case SIMPLE_VECTOR_WIDETAG:
-        return ptrans_vector(thing, 32, 0, 1, constant);
+        return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant);
  
        case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
          return ptrans_vector(thing, 2, 0, 0, constant);
  
        case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
          return ptrans_vector(thing, 2, 0, 0, constant);
@@ -982,6 +1013,25 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
  #endif
          return ptrans_vector(thing, 32, 0, 0, constant);
  
  #endif
          return ptrans_vector(thing, 32, 0, 0, constant);
  
+#if N_WORD_BITS == 64
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+      case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+      case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
+        return ptrans_vector(thing, 64, 0, 0, constant);
+#endif
+               
        case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
          return ptrans_vector(thing, 32, 0, 0, constant);
  
        case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
          return ptrans_vector(thing, 32, 0, 0, constant);
  
@@ -1028,13 +1078,14 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
         return ptrans_fdefn(thing, header);
  
        default:
         return ptrans_fdefn(thing, header);
  
        default:
+       fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
          /* Should only come across other pointers to the above stuff. */
          gc_abort();
         return NIL;
      }
  }
  
          /* Should only come across other pointers to the above stuff. */
          gc_abort();
         return NIL;
      }
  }
  
-static int
+static long
  pscav_fdefn(struct fdefn *fdefn)
  {
      boolean fix_func;
  pscav_fdefn(struct fdefn *fdefn)
  {
      boolean fix_func;
@@ -1047,14 +1098,15 @@ pscav_fdefn(struct fdefn *fdefn)
      return sizeof(struct fdefn) / sizeof(lispobj);
  }
  
      return sizeof(struct fdefn) / sizeof(lispobj);
  }
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
  /* now putting code objects in static space */
  /* now putting code objects in static space */
-static int
+static long
  pscav_code(struct code*code)
  {
  pscav_code(struct code*code)
  {
-    int nwords;
+    long nwords;
      lispobj func;
      lispobj func;
-    nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
+    nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
+                    2);
  
      /* Arrange to scavenge the debug info later. */
      pscav_later(&code->debug_info, 1);
  
      /* Arrange to scavenge the debug info later. */
      pscav_later(&code->debug_info, 1);
@@ -1070,14 +1122,14 @@ pscav_code(struct code*code)
          gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
          gc_assert(!dynamic_pointer_p(func));
  
          gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
          gc_assert(!dynamic_pointer_p(func));
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
         /* Temporarily convert the self pointer to a real function
          * pointer. */
         ((struct simple_fun *)native_pointer(func))->self
             -= FUN_RAW_ADDR_OFFSET;
  #endif
          pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
         /* Temporarily convert the self pointer to a real function
          * pointer. */
         ((struct simple_fun *)native_pointer(func))->self
             -= FUN_RAW_ADDR_OFFSET;
  #endif
          pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
         ((struct simple_fun *)native_pointer(func))->self
             += FUN_RAW_ADDR_OFFSET;
  #endif
         ((struct simple_fun *)native_pointer(func))->self
             += FUN_RAW_ADDR_OFFSET;
  #endif
@@ -1089,10 +1141,10 @@ pscav_code(struct code*code)
  #endif
  
  static lispobj *
  #endif
  
  static lispobj *
-pscav(lispobj *addr, int nwords, boolean constant)
+pscav(lispobj *addr, long nwords, boolean constant)
  {
      lispobj thing, *thingp, header;
  {
      lispobj thing, *thingp, header;
-    int count = 0; /* (0 = dummy init value to stop GCC warning) */
+    long count = 0; /* (0 = dummy init value to stop GCC warning) */
      struct vector *vector;
  
      while (nwords > 0) {
      struct vector *vector;
  
      while (nwords > 0) {
@@ -1134,7 +1186,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
              }
              count = 1;
          }
              }
              count = 1;
          }
-        else if (thing & 3) {  /* FIXME: 3?  not 2? */
+        else if (thing & FIXNUM_TAG_MASK) {
              /* It's an other immediate. Maybe the header for an unboxed */
              /* object. */
              switch (widetag_of(thing)) {
              /* It's an other immediate. Maybe the header for an unboxed */
              /* object. */
              switch (widetag_of(thing)) {
@@ -1146,7 +1198,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
  #endif
                case SAP_WIDETAG:
                  /* It's an unboxed simple object. */
  #endif
                case SAP_WIDETAG:
                  /* It's an unboxed simple object. */
-                count = HeaderValue(thing)+1;
+                count = CEILING(HeaderValue(thing)+1, 2);
                  break;
  
                case SIMPLE_VECTOR_WIDETAG:
                  break;
  
                case SIMPLE_VECTOR_WIDETAG:
@@ -1154,7 +1206,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
                      *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
                          SIMPLE_VECTOR_WIDETAG;
                   }
                      *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
                          SIMPLE_VECTOR_WIDETAG;
                   }
-                count = 1;
+                count = 2;
                  break;
  
               case SIMPLE_ARRAY_NIL_WIDETAG:
                  break;
  
               case SIMPLE_ARRAY_NIL_WIDETAG:
@@ -1236,7 +1288,8 @@ pscav(lispobj *addr, int nwords, boolean constant)
  
                case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
                  vector = (struct vector *)addr;
  
                case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
                  vector = (struct vector *)addr;
-                count = CEILING(fixnum_value(vector->length)+2,2);
+                count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2, 
+                               2);
                  break;
  
                case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
                  break;
  
                case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
@@ -1244,7 +1297,8 @@ pscav(lispobj *addr, int nwords, boolean constant)
                case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
  #endif
                  vector = (struct vector *)addr;
                case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
  #endif
                  vector = (struct vector *)addr;
-                count = fixnum_value(vector->length)*2+2;
+                count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2, 
+                               2);
                  break;
  
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
                  break;
  
  #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
@@ -1262,7 +1316,8 @@ pscav(lispobj *addr, int nwords, boolean constant)
  #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
                case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
                  vector = (struct vector *)addr;
  #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
                case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
                  vector = (struct vector *)addr;
-                count = fixnum_value(vector->length)*4+2;
+                count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2, 
+                               2);
                  break;
  #endif
  
                  break;
  #endif
  
@@ -1279,7 +1334,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
  #endif
  
                case CODE_HEADER_WIDETAG:
  #endif
  
                case CODE_HEADER_WIDETAG:
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
                  gc_abort(); /* no code headers in static space */
  #else
                 count = pscav_code((struct code*)addr);
                  gc_abort(); /* no code headers in static space */
  #else
                 count = pscav_code((struct code*)addr);
@@ -1293,7 +1348,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
                  gc_abort();
                 break;
  
                  gc_abort();
                 break;
  
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
               case CLOSURE_HEADER_WIDETAG:
               case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
                 /* The function self pointer needs special care on the
               case CLOSURE_HEADER_WIDETAG:
               case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
                 /* The function self pointer needs special care on the
@@ -1342,7 +1397,7 @@ int
  purify(lispobj static_roots, lispobj read_only_roots)
  {
      lispobj *clean;
  purify(lispobj static_roots, lispobj read_only_roots)
  {
      lispobj *clean;
-    int count, i;
+    long count, i;
      struct later *laters, *next;
      struct thread *thread;
  
      struct later *laters, *next;
      struct thread *thread;
  
@@ -1371,7 +1426,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
          return 0;
      }
  
          return 0;
      }
  
-#if defined(LISP_FEATURE_X86)
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
      dynamic_space_free_pointer =
        (lispobj*)SymbolValue(ALLOCATION_POINTER,0);
  #endif
      dynamic_space_free_pointer =
        (lispobj*)SymbolValue(ALLOCATION_POINTER,0);
  #endif
@@ -1386,7 +1441,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
      fflush(stdout);
  #endif
  
      fflush(stdout);
  #endif
  
-#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
+#if defined(LISP_FEATURE_GENCGC) && (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      /* note this expects only one thread to be active.  We'd have to 
       * stop all the others in the same way as GC does if we wanted 
       * PURIFY to work when >1 thread exists */
      /* note this expects only one thread to be active.  We'd have to 
       * stop all the others in the same way as GC does if we wanted 
       * PURIFY to work when >1 thread exists */
@@ -1410,7 +1465,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
      printf(" stack");
      fflush(stdout);
  #endif
      printf(" stack");
      fflush(stdout);
  #endif
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
      pscav((lispobj *)all_threads->control_stack_start,
           current_control_stack_pointer - 
           all_threads->control_stack_start,
      pscav((lispobj *)all_threads->control_stack_start,
           current_control_stack_pointer - 
           all_threads->control_stack_start,
@@ -1425,7 +1480,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
      printf(" bindings");
      fflush(stdout);
  #endif
      printf(" bindings");
      fflush(stdout);
  #endif
-#if !defined(LISP_FEATURE_X86)
+#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
      pscav( (lispobj *)all_threads->binding_stack_start,
           (lispobj *)current_binding_stack_pointer -
            all_threads->binding_stack_start,
      pscav( (lispobj *)all_threads->binding_stack_start,
           (lispobj *)current_binding_stack_pointer -
            all_threads->binding_stack_start,
@@ -1505,7 +1560,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
  
      /* Zero the stack. Note that the stack is also zeroed by SUB-GC
       * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
  
      /* Zero the stack. Note that the stack is also zeroed by SUB-GC
       * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
      os_zero((os_vm_address_t) current_control_stack_pointer,
              (os_vm_size_t)
             ((all_threads->control_stack_end -
      os_zero((os_vm_address_t) current_control_stack_pointer,
              (os_vm_size_t)
             ((all_threads->control_stack_end -
diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h

index c6e8a6e..69560b8 100644 (file)
--- a/src/runtime/runtime.h
+++ b/src/runtime/runtime.h
@@ -45,13 +45,10 @@
  /* even on alpha, int happens to be 4 bytes.  long is longer. */
  /* FIXME: these names really shouldn't reflect their length and this
     is not quite right for some of the FFI stuff */
  /* even on alpha, int happens to be 4 bytes.  long is longer. */
  /* FIXME: these names really shouldn't reflect their length and this
     is not quite right for some of the FFI stuff */
-#if 64 == N_WORD_BITS
-typedef unsigned long u32;
-typedef signed long s32;
-#else
+typedef unsigned long u64;
+typedef signed long s64;
  typedef unsigned int u32;
  typedef signed int s32;
  typedef unsigned int u32;
  typedef signed int s32;
-#endif
  
  /* this is an integral type the same length as a machine pointer */
  typedef unsigned long pointer_sized_uint_t ;
  
  /* this is an integral type the same length as a machine pointer */
  typedef unsigned long pointer_sized_uint_t ;
diff --git a/src/runtime/save.c b/src/runtime/save.c

index ec630d5..b0a7a76 100644 (file)
--- a/src/runtime/save.c
+++ b/src/runtime/save.c
@@ -30,6 +30,12 @@
  #include "genesis/static-symbols.h"
  #include "genesis/symbol.h"
  
  #include "genesis/static-symbols.h"
  #include "genesis/symbol.h"
  
+static void
+write_lispobj(lispobj obj, FILE *file) 
+{
+    fwrite(&obj, sizeof(lispobj), 1, file);
+}
+
  static long
  write_bytes(FILE *file, char *addr, long bytes)
  {
  static long
  write_bytes(FILE *file, char *addr, long bytes)
  {
@@ -65,9 +71,9 @@ output_space(FILE *file, int id, lispobj *addr, lispobj *end)
      int words, bytes, data;
      static char *names[] = {NULL, "dynamic", "static", "read-only"};
  
      int words, bytes, data;
      static char *names[] = {NULL, "dynamic", "static", "read-only"};
  
-    putw(id, file);
+    write_lispobj(id, file);
      words = end - addr;
      words = end - addr;
-    putw(words, file);
+    write_lispobj(words, file);
  
      bytes = words * sizeof(lispobj);
  
  
      bytes = words * sizeof(lispobj);
  
@@ -76,9 +82,9 @@ output_space(FILE *file, int id, lispobj *addr, lispobj *end)
  
      data = write_bytes(file, (char *)addr, bytes);
  
  
      data = write_bytes(file, (char *)addr, bytes);
  
-    putw(data, file);
-    putw((long)addr / os_vm_page_size, file);
-    putw((bytes + os_vm_page_size - 1) / os_vm_page_size, file);
+    write_lispobj(data, file);
+    write_lispobj((long)addr / os_vm_page_size, file);
+    write_lispobj((bytes + os_vm_page_size - 1) / os_vm_page_size, file);
  }
  
  boolean
  }
  
  boolean
@@ -115,14 +121,14 @@ save(char *filename, lispobj init_function)
      printf("[saving current Lisp image into %s:\n", filename);
      fflush(stdout);
  
      printf("[saving current Lisp image into %s:\n", filename);
      fflush(stdout);
  
-    putw(CORE_MAGIC, file);
+    write_lispobj(CORE_MAGIC, file);
  
  
-    putw(VERSION_CORE_ENTRY_TYPE_CODE, file);
-    putw(3, file);
-    putw(SBCL_CORE_VERSION_INTEGER, file);
+    write_lispobj(VERSION_CORE_ENTRY_TYPE_CODE, file);
+    write_lispobj(3, file);
+    write_lispobj(SBCL_CORE_VERSION_INTEGER, file);
  
  
-    putw(BUILD_ID_CORE_ENTRY_TYPE_CODE, file);
-    putw(/* (We're writing the word count of the entry here, and the 2
+    write_lispobj(BUILD_ID_CORE_ENTRY_TYPE_CODE, file);
+    write_lispobj(/* (We're writing the word count of the entry here, and the 2
           * term is one word for the leading BUILD_ID_CORE_ENTRY_TYPE_CODE
           * word and one word where we store the count itself.) */
          2 + strlen(build_id),
           * term is one word for the leading BUILD_ID_CORE_ENTRY_TYPE_CODE
           * word and one word where we store the count itself.) */
          2 + strlen(build_id),
@@ -130,11 +136,11 @@ save(char *filename, lispobj init_function)
      {
         char *p;
         for (p = build_id; *p; ++p)
      {
         char *p;
         for (p = build_id; *p; ++p)
-           putw(*p, file);
+           write_lispobj(*p, file);
      }
  
      }
  
-    putw(NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE, file);
-    putw(/* (word count = 3 spaces described by 5 words each, plus the
+    write_lispobj(NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE, file);
+    write_lispobj(/* (word count = 3 spaces described by 5 words each, plus the
           * entry type code, plus this count itself) */
          (5*3)+2, file);
      output_space(file,
           * entry type code, plus this count itself) */
          (5*3)+2, file);
      output_space(file,
@@ -162,11 +168,11 @@ save(char *filename, lispobj init_function)
                  (lispobj *)SymbolValue(ALLOCATION_POINTER,0));
  #endif
  
                  (lispobj *)SymbolValue(ALLOCATION_POINTER,0));
  #endif
  
-    putw(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);
-    putw(3, file);
-    putw(init_function, file);
+    write_lispobj(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);
+    write_lispobj(3, file);
+    write_lispobj(init_function, file);
  
  
-    putw(END_CORE_ENTRY_TYPE_CODE, file);
+    write_lispobj(END_CORE_ENTRY_TYPE_CODE, file);
  
      fclose(file);
      printf("done]\n");
  
      fclose(file);
      printf("done]\n");
diff --git a/src/runtime/thread.c b/src/runtime/thread.c

index 8662682..2a174d6 100644 (file)
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -40,7 +40,7 @@ initial_thread_trampoline(struct thread *th)
  
      if(th->pid < 1) lose("th->pid not set up right");
      th->state=STATE_RUNNING;
  
      if(th->pid < 1) lose("th->pid not set up right");
      th->state=STATE_RUNNING;
-#if defined(LISP_FEATURE_X86)
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
      return call_into_lisp_first_time(function,args,0);
  #else
      return funcall0(function);
      return call_into_lisp_first_time(function,args,0);
  #else
      return funcall0(function);
@@ -141,11 +141,11 @@ struct thread * create_thread_struct(lispobj initial_function) {
      th->state=STATE_STOPPED;
  #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
      th->alien_stack_pointer=((void *)th->alien_stack_start
      th->state=STATE_STOPPED;
  #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
      th->alien_stack_pointer=((void *)th->alien_stack_start
-                            + ALIEN_STACK_SIZE-4); /* naked 4.  FIXME */
+                            + ALIEN_STACK_SIZE-N_WORD_BYTES);
  #else
      th->alien_stack_pointer=((void *)th->alien_stack_start);
  #endif
  #else
      th->alien_stack_pointer=((void *)th->alien_stack_start);
  #endif
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
      th->pseudo_atomic_interrupted=0;
      th->pseudo_atomic_atomic=0;
  #endif
      th->pseudo_atomic_interrupted=0;
      th->pseudo_atomic_atomic=0;
  #endif
@@ -163,7 +163,7 @@ struct thread * create_thread_struct(lispobj initial_function) {
      SetSymbolValue(BINDING_STACK_START,(lispobj)th->binding_stack_start,th);
      SetSymbolValue(CONTROL_STACK_START,(lispobj)th->control_stack_start,th);
      SetSymbolValue(CONTROL_STACK_END,(lispobj)th->control_stack_end,th);
      SetSymbolValue(BINDING_STACK_START,(lispobj)th->binding_stack_start,th);
      SetSymbolValue(CONTROL_STACK_START,(lispobj)th->control_stack_start,th);
      SetSymbolValue(CONTROL_STACK_END,(lispobj)th->control_stack_end,th);
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
      SetSymbolValue(BINDING_STACK_POINTER,(lispobj)th->binding_stack_pointer,th);
      SetSymbolValue(ALIEN_STACK,(lispobj)th->alien_stack_pointer,th);
      SetSymbolValue(PSEUDO_ATOMIC_ATOMIC,(lispobj)th->pseudo_atomic_atomic,th);
      SetSymbolValue(BINDING_STACK_POINTER,(lispobj)th->binding_stack_pointer,th);
      SetSymbolValue(ALIEN_STACK,(lispobj)th->alien_stack_pointer,th);
      SetSymbolValue(PSEUDO_ATOMIC_ATOMIC,(lispobj)th->pseudo_atomic_atomic,th);
diff --git a/src/runtime/thread.h b/src/runtime/thread.h

index a4318fe..2ff59e6 100644 (file)
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -43,7 +43,7 @@ extern struct thread *find_thread_by_pid(pid_t pid);
  #define for_each_thread(th) for(th=all_threads;th;th=0)
  #endif
  
  #define for_each_thread(th) for(th=all_threads;th;th=0)
  #endif
  
-static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
+static inline lispobj SymbolValue(u64 tagged_symbol_pointer, void *thread) {
      struct symbol *sym= (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
      struct symbol *sym= (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
@@ -56,7 +56,7 @@ static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
  #endif
      return sym->value;
  }
  #endif
      return sym->value;
  }
-static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
+static inline lispobj SymbolTlValue(u64 tagged_symbol_pointer, void *thread) {
      struct symbol *sym= (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
      struct symbol *sym= (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
@@ -67,7 +67,7 @@ static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
  #endif
  }
  
  #endif
  }
  
-static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
+static inline void SetSymbolValue(u64 tagged_symbol_pointer,lispobj val, void *thread) {
      struct symbol *sym=        (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
      struct symbol *sym=        (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
@@ -82,7 +82,7 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t
  #endif
      sym->value = val;
  }
  #endif
      sym->value = val;
  }
-static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
+static inline void SetTlSymbolValue(u64 tagged_symbol_pointer,lispobj val, void *thread) {
  #ifdef LISP_FEATURE_SB_THREAD
      struct symbol *sym=        (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  #ifdef LISP_FEATURE_SB_THREAD
      struct symbol *sym=        (struct symbol *)
         (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c

new file mode 100644 (file)

index 0000000..5b4f674
--- /dev/null
+++ b/src/runtime/x86-64-arch.c
@@ -0,0 +1,393 @@
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+
+#include "sbcl.h"
+#include "runtime.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "sbcl.h"
+#include "arch.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+#include "monitor.h"
+#include "thread.h"
+
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
+#define BREAKPOINT_INST 0xcc   /* INT3 */
+
+unsigned long fast_random_state = 1;
+
+void arch_init(void)
+{}
+\f
+/*
+ * hacking signal contexts
+ *
+ * (This depends both on architecture, which determines what we might
+ * want to get to, and on OS, which determines how we get to it.)
+ */
+
+int *
+context_eflags_addr(os_context_t *context)
+{
+#if defined __linux__
+    /* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
+     * <sys/ucontext.h> file to define symbolic names for offsets into
+     * gregs[], but it's conditional on __USE_GNU and not defined, so
+     * we need to do this nasty absolute index magic number thing
+     * instead. */
+    return &context->uc_mcontext.gregs[16];
+#elif defined __FreeBSD__
+    return &context->uc_mcontext.mc_eflags;
+#elif defined __OpenBSD__
+    return &context->sc_eflags;
+#else
+#error unsupported OS
+#endif
+}
+\f
+void arch_skip_instruction(os_context_t *context)
+{
+    /* Assuming we get here via an INT3 xxx instruction, the PC now
+     * points to the interrupt code (a Lisp value) so we just move
+     * past it. Skip the code; after that, if the code is an
+     * error-trap or cerror-trap then skip the data bytes that follow. */
+
+    int vlen;
+    long code;
+
+    
+    /* Get and skip the Lisp interrupt code. */
+    code = *(char*)(*os_context_pc_addr(context))++;
+    switch (code)
+       {
+       case trap_Error:
+       case trap_Cerror:
+           /* Lisp error arg vector length */
+           vlen = *(char*)(*os_context_pc_addr(context))++;
+           /* Skip Lisp error arg data bytes. */
+           while (vlen-- > 0) {
+               ( (char*)(*os_context_pc_addr(context)) )++;
+           }
+           break;
+
+       case trap_Breakpoint:           /* not tested */
+       case trap_FunEndBreakpoint: /* not tested */
+           break;
+
+       case trap_PendingInterrupt:
+       case trap_Halt:
+           /* only needed to skip the Code */
+           break;
+
+       default:
+           fprintf(stderr,"[arch_skip_inst invalid code %d\n]\n",code);
+           break;
+       }
+
+    FSHOW((stderr,
+          "/[arch_skip_inst resuming at %x]\n",
+          *os_context_pc_addr(context)));
+}
+
+unsigned char *
+arch_internal_error_arguments(os_context_t *context)
+{
+    return 1 + (unsigned char *)(*os_context_pc_addr(context));
+}
+
+boolean
+arch_pseudo_atomic_atomic(os_context_t *context)
+{
+    return SymbolValue(PSEUDO_ATOMIC_ATOMIC,arch_os_get_current_thread());
+}
+
+void
+arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),
+                  arch_os_get_current_thread());
+}
+\f
+/*
+ * This stuff seems to get called for TRACE and debug activity.
+ */
+
+unsigned long
+arch_install_breakpoint(void *pc)
+{
+    unsigned long result = *(unsigned long*)pc;
+
+    *(char*)pc = BREAKPOINT_INST;              /* x86 INT3       */
+    *((char*)pc+1) = trap_Breakpoint;          /* Lisp trap code */
+
+    return result;
+}
+
+void
+arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+    *((char *)pc) = orig_inst & 0xff;
+    *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+}
+\f
+/* When single stepping, single_stepping holds the original instruction
+ * PC location. */
+unsigned long *single_stepping = NULL;
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+unsigned long  single_step_save1;
+unsigned long  single_step_save2;
+unsigned long  single_step_save3;
+#endif
+
+void
+arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
+{
+    unsigned long *pc = (unsigned long*)(*os_context_pc_addr(context));
+
+    /* Put the original instruction back. */
+    *((char *)pc) = orig_inst & 0xff;
+    *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+    /* Install helper instructions for the single step:
+     * pushf; or [esp],0x100; popf. */
+    single_step_save1 = *(pc-3);
+    single_step_save2 = *(pc-2);
+    single_step_save3 = *(pc-1);
+    *(pc-3) = 0x9c909090;
+    *(pc-2) = 0x00240c81;
+    *(pc-1) = 0x9d000001;
+#else
+    *context_eflags_addr(context) |= 0x100;
+#endif
+
+    single_stepping = (unsigned int*)pc;
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+    *os_context_pc_addr(context) = (char *)pc - 9;
+#endif
+}
+\f
+void
+sigtrap_handler(int signal, siginfo_t *info, void *void_context)
+{
+    int code = info->si_code;
+    os_context_t *context = (os_context_t*)void_context;
+    unsigned int trap;
+    sigset_t ss;
+
+    if (single_stepping && (signal==SIGTRAP))
+    {
+       /* fprintf(stderr,"* single step trap %x\n", single_stepping); */
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+       /* 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_addr(context) ^= 0x100;
+#endif
+       /* Re-install the breakpoint if possible. */
+       if (*os_context_pc_addr(context) == (int)single_stepping + 1) {
+           fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
+       } else {
+           *((char *)single_stepping) = BREAKPOINT_INST;       /* x86 INT3 */
+           *((char *)single_stepping+1) = trap_Breakpoint;
+       }
+
+       single_stepping = NULL;
+       return;
+    }
+
+    /* This is just for info in case the monitor wants to print an
+     * approximation. */
+    current_control_stack_pointer =
+       (lispobj *)*os_context_sp_addr(context);
+
+    /* FIXME: CMUCL puts the float control restoration code here.
+       Thus, it seems to me that single-stepping won't restore the
+       float control.  Since SBCL currently doesn't support
+       single-stepping (as far as I can tell) this is somewhat moot,
+       but it might be worth either moving this code up or deleting
+       the single-stepping code entirely.  -- CSR, 2002-07-15 */
+#ifdef LISP_FEATURE_LINUX
+    os_restore_fp_control(context);
+#endif
+
+    /* 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
+     * number of bytes will follow, the first is the length of the byte
+     * arguments to follow. */
+    trap = *(unsigned char *)(*os_context_pc_addr(context));
+    switch (trap) {
+
+    case trap_PendingInterrupt:
+       FSHOW((stderr, "/<trap pending interrupt>\n"));
+       arch_skip_instruction(context);
+       sigemptyset(&ss);
+       sigaddset(&ss,SIGTRAP);
+       sigprocmask(SIG_UNBLOCK,&ss,0);
+       interrupt_handle_pending(context);
+       break;
+
+    case trap_Halt:
+       /* Note: the old CMU CL code tried to save FPU state
+        * here, and restore it after we do our thing, but there
+        * seems to be no point in doing that, since we're just
+        * going to lose(..) anyway. */
+       fake_foreign_function_call(context);
+       lose("%%PRIMITIVE HALT called; the party is over.");
+
+    case trap_Error:
+    case trap_Cerror:
+       FSHOW((stderr, "<trap error/cerror %d>\n", code));
+       interrupt_internal_error(signal, info, context, code==trap_Cerror);
+       break;
+
+    case trap_Breakpoint:
+       (char*)(*os_context_pc_addr(context)) -= 1;
+       handle_breakpoint(signal, info, context);
+       break;
+
+    case trap_FunEndBreakpoint:
+       (char*)(*os_context_pc_addr(context)) -= 1;
+       *os_context_pc_addr(context) =
+           (int)handle_fun_end_breakpoint(signal, info, context);
+       break;
+
+    default:
+       FSHOW((stderr,"/[C--trap default %d %d %x]\n",
+              signal, code, context));
+       interrupt_handle_now(signal, info, context);
+       break;
+    }
+}
+
+static void
+sigill_handler(int signal, siginfo_t *siginfo, void *void_context) {
+    os_context_t *context = (os_context_t*)void_context;
+    fake_foreign_function_call(context);
+    monitor_or_something();
+}
+
+void
+arch_install_interrupt_handlers()
+{
+    SHOW("entering arch_install_interrupt_handlers()");
+
+    /* Note: The old CMU CL code here used sigtrap_handler() to handle
+     * SIGILL as well as SIGTRAP. I couldn't see any reason to do
+     * things that way. So, I changed to separate handlers when
+     * debugging a problem on OpenBSD, where SBCL wasn't catching
+     * SIGILL properly, but was instead letting the process be
+     * terminated with an "Illegal instruction" output. If this change
+     * turns out to break something (maybe breakpoint handling on some
+     * OS I haven't tested on?) and we have to go back to the old CMU
+     * CL way, I hope there will at least be a comment to explain
+     * why.. -- WHN 2001-06-07 */
+    undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler);
+    undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
+
+    SHOW("returning from arch_install_interrupt_handlers()");
+}
+\f
+/* This is implemented in assembly language and called from C: */
+extern lispobj
+call_into_lisp(lispobj fun, lispobj *args, int nargs);
+
+/* These functions are an interface to the Lisp call-in facility.
+ * Since this is C we can know nothing about the calling environment.
+ * The control stack might be the C stack if called from the monitor
+ * or the Lisp stack if called as a result of an interrupt or maybe
+ * even a separate stack. The args are most likely on that stack but
+ * could be in registers depending on what the compiler likes. So we
+ * copy the args into a portable vector and let the assembly language
+ * call-in function figure it out. */
+
+lispobj
+funcall0(lispobj function)
+{
+    lispobj *args = NULL;
+
+    FSHOW((stderr, "/entering funcall0(0x%lx)\n", (long)function));
+    return call_into_lisp(function, args, 0);
+}
+lispobj
+funcall1(lispobj function, lispobj arg0)
+{
+    lispobj args[1];
+    args[0] = arg0;
+    return call_into_lisp(function, args, 1);
+}
+lispobj
+funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+    lispobj args[2];
+    args[0] = arg0;
+    args[1] = arg1;
+    return call_into_lisp(function, args, 2);
+}
+lispobj
+funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+    lispobj args[3];
+    args[0] = arg0;
+    args[1] = arg1;
+    args[2] = arg2;
+    return call_into_lisp(function, args, 3);
+}
+
+
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+/* FIXME: It might be cleaner to generate these from the lisp side of
+ * things.
+ */
+
+void 
+arch_write_linkage_table_jmp(char * reloc, void * fun)
+{
+    unsigned long addr = (unsigned long) fun;
+    int i;
+
+    *reloc++ = 0xFF; /* Opcode for near jump to absolute reg/mem64. */
+    *reloc++ = 0x25; /* ModRM #b00 100 101, i.e. RIP-relative. */
+    *reloc++ = 0x00; /* 32-bit displacement field = 0 */
+    *reloc++ = 0x00; /* ... */
+    *reloc++ = 0x00; /* ... */
+    *reloc++ = 0x00; /* ... */
+
+    for (i = 0; i < 8; i++) {
+       *reloc++ = addr & 0xff;
+       addr >>= 8;
+    }
+
+    /* write a nop for good measure. */
+    *reloc = 0x90;
+}
+
+void
+arch_write_linkage_table_ref(void * reloc, void * data)
+{
+    *(unsigned long *)reloc = (unsigned long)data;
+}
+
+#endif
diff --git a/src/runtime/x86-64-arch.h b/src/runtime/x86-64-arch.h

new file mode 100644 (file)

index 0000000..a992756
--- /dev/null
+++ b/src/runtime/x86-64-arch.h
@@ -0,0 +1,38 @@
+/* FIXME: Aren't preprocessor symbols with underscore prefixes
+ * reserved for the system libraries? If so, it would be tidy to
+ * rename flags like _X86_ARCH_H so their names are in a part of the
+ * namespace that we control. */
+#ifndef _X86_ARCH_H
+#define _X86_ARCH_H
+
+#define ARCH_HAS_STACK_POINTER
+
+/* FIXME: Do we also want
+ *   #define ARCH_HAS_FLOAT_REGISTERS
+ * here? (The answer wasn't obvious to me when merging the
+ * architecture-abstracting patches for CSR's SPARC port. -- WHN 2002-02-15) */
+
+static inline void 
+get_spinlock(lispobj *word,int value)
+{
+#if 0
+    u32 eax=0;
+    do {
+       asm ("xor %0,%0\n\
+              lock cmpxchg %1,%2" 
+            : "=a" (eax)
+            : "r" (value), "m" (*word)
+            : "memory", "cc");
+    } while(eax!=0);
+#else
+    *word=value;
+#endif
+}
+
+static inline void
+release_spinlock(lispobj *word)
+{
+    *word=0;
+}
+
+#endif /* _X86_ARCH_H */
diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S

new file mode 100644 (file)

index 0000000..47916c2
--- /dev/null
+++ b/src/runtime/x86-64-assem.S
@@ -0,0 +1,335 @@
+/*
+ * very-low-level utilities for runtime support
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+\f
+#define LANGUAGE_ASSEMBLY
+#include "validate.h"
+#include "sbcl.h"
+#include "genesis/closure.h"
+#include "genesis/fdefn.h"
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+#include "genesis/thread.h"
+       
+/* Minimize conditionalization for different OS naming schemes. */
+#if defined __linux__  || defined __FreeBSD__ /* (but *not* OpenBSD) */
+#define GNAME(var) var
+#else
+#define GNAME(var) _##var
+#endif
+
+/* Get the right type of alignment. Linux and FreeBSD (but not OpenBSD)
+ * want alignment in bytes. */
+#if defined(__linux__) || defined(__FreeBSD__)
+#define align_4byte    4
+#define align_8byte    8
+#define align_16byte   16
+#define align_32byte   32
+#else
+#define        align_4byte     2
+#define        align_8byte     3
+#define        align_16byte    4       
+#endif                 
+
+       .text
+       .global GNAME(foreign_function_call_active)
+       .global GNAME(all_threads)
+       
+\f
+/* From lower to higher-numbered addresses, the stack contains 
+ * return address, arg 0, arg 1, arg 2 ...
+ * rax contains the address of the function to call
+ * Lisp expects return value in rax, whic is already consistent with C
+ * XXXX correct floating point handling is unimplemented so far
+ * Based on comments cleaned from x86-assem.S, we believe that 
+ * Lisp is expecting us to preserve rsi, rdi, rsp (no idea about r8-15)
+ */
+       .text
+       .align  align_16byte,0x90
+       .global GNAME(call_into_c)
+       .type   GNAME(call_into_c),@function
+GNAME(call_into_c):
+       push    %rbp            # Save old frame pointer.
+       mov     %rsp,%rbp       # Establish new frame.
+
+       push    %rsi            # args are going in here
+       push    %rdi
+       mov     16(%rbp),%rdi
+       mov     24(%rbp),%rsi
+       mov     32(%rbp),%rdx
+       mov     40(%rbp),%rcx
+       mov     48(%rbp),%rcx
+       mov     56(%rbp),%r8
+       mov     64(%rbp),%r9
+       call    *%rax
+       mov     %rbp,%rsp
+       pop     %rbp
+       ret
+       .size   GNAME(call_into_c), . - GNAME(call_into_c)
+
+\f
+       .text   
+       .global GNAME(call_into_lisp_first_time)
+       .type  GNAME(call_into_lisp_first_time),@function
+               
+/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when
+ * the stack changes.  We don't worry too much about saving registers 
+ * here, because we never expect to return from the initial call to lisp 
+ * anyway */
+       
+       .align  align_16byte,0x90
+GNAME(call_into_lisp_first_time):
+       push    %rbp            # Save old frame pointer.
+       mov     %rsp,%rbp       # Establish new frame.
+       mov    %rsp,ALIEN_STACK + SYMBOL_VALUE_OFFSET
+       mov    GNAME(all_threads),%rax
+       mov    THREAD_CONTROL_STACK_START_OFFSET(%rax) ,%rsp
+       /* don't think too hard about what happens if we get interrupted
+       * here */
+       add     $THREAD_CONTROL_STACK_SIZE-8,%rsp
+       jmp     Lstack
+\f
+       .text   
+       .global GNAME(call_into_lisp)
+       .type  GNAME(call_into_lisp),@function
+               
+/*
+ * amd64 calling convention: C expects that
+ * arguments go in rdi rsi rdx rcx r8 r9
+ * return values in rax rdx
+ * callee saves rbp rbx r12-15 if it uses them
+ */
+       
+       .align  align_16byte,0x90
+GNAME(call_into_lisp):
+       push    %rbp            # Save old frame pointer.
+       mov     %rsp,%rbp       # Establish new frame.
+Lstack:
+       /* FIXME x86 saves FPU state here */
+       push    %rbx
+       push    %r12
+       push    %r13
+       push    %r14
+       push    %r15
+
+
+       mov     %rsp,%rbx       # remember current stack
+       push    %rbx            # Save entry stack on (maybe) new stack.
+
+       /* Establish Lisp args. */
+       mov     %rdi,%rax       # lexenv?
+       mov     %rsi,%rbx       # address of arg vec
+       mov     %rdx,%rcx       # num args
+
+       xor     %rdx,%rdx       # clear any descriptor registers 
+       xor     %rdi,%rdi       # that we can't be sure we'll 
+       xor     %rsi,%rsi       # initialise properly.  XX do r8-r15 too?
+       shl     $3,%rcx         # (fixnumize num-args)
+       cmp     $0,%rcx
+       je      Ldone
+       mov     0(%rbx),%rdx    # arg0
+       cmp     $8,%rcx
+       je      Ldone
+       mov     8(%rbx),%rdi    # arg1
+       cmp     $16,%rcx
+       je      Ldone
+       mov     16(%rbx),%rsi   # arg2
+Ldone: 
+       /* Registers rax, rcx, rdx, rdi, and rsi are now live. */
+       xor     %rbx,%rbx       # available
+
+       /* Alloc new frame. */
+       mov     %rsp,%rbx       # The current sp marks start of new frame.
+       push    %rbp            # fp in save location S0
+       sub     $16,%rsp        # Ensure 3 slots are allocated, one above.
+       mov     %rbx,%rbp       # Switch to new frame.
+
+Lcall:
+       call    *CLOSURE_FUN_OFFSET(%rax)
+       
+       /* If the function returned multiple values, it will return to
+          this point.  Lose them */
+       mov     %rbx, %rsp
+       /* A singled value function returns here */
+
+/* Restore the stack, in case there was a stack change. */
+       pop     %rsp            # c-sp
+
+/* Restore C regs */
+       pop     %r15
+       pop     %r14
+       pop     %r13
+       pop     %r12
+       pop     %rbx
+
+/* FIXME Restore the NPX state. */
+       pop     %rbp            # c-sp
+       /* return value is already in rax where lisp expects it */
+       ret
+       .size   GNAME(call_into_lisp), . - GNAME(call_into_lisp)
+\f
+/* support for saving and restoring the NPX state from C */
+       .text
+       .global GNAME(fpu_save)
+       .type   GNAME(fpu_save),@function
+       .align  2,0x90
+GNAME(fpu_save):
+       mov     4(%rsp),%rax
+       fnsave  (%rax)          # Save the NPX state. (resets NPX)
+       ret
+       .size   GNAME(fpu_save),.-GNAME(fpu_save)
+
+       .global GNAME(fpu_restore)
+       .type   GNAME(fpu_restore),@function
+       .align  2,0x90
+GNAME(fpu_restore):
+       mov     4(%rsp),%rax
+       frstor  (%rax)          # Restore the NPX state.
+       ret
+       .size   GNAME(fpu_restore),.-GNAME(fpu_restore)
+\f
+/*
+ * the undefined-function trampoline
+ */
+       .text
+       .align  align_4byte,0x90
+       .global GNAME(undefined_tramp)
+       .type   GNAME(undefined_tramp),@function
+GNAME(undefined_tramp):
+       int3
+       .byte   trap_Error
+        .byte   2
+        .byte   UNDEFINED_FUN_ERROR
+        .byte   sc_DescriptorReg # eax in the Descriptor-reg SC
+       ret
+       .size   GNAME(undefined_tramp), .-GNAME(undefined_tramp)
+
+
+       .text
+       .align  align_4byte,0x90
+       .global GNAME(alloc_tramp)
+       .type   GNAME(alooc_tramp),@function
+GNAME(alloc_tramp):
+       push    %rbp            # Save old frame pointer.
+       mov     %rsp,%rbp       # Establish new frame.
+       push    %rax
+       push    %rcx
+       push    %rdx
+       push    %rsi
+       push    %rdi
+       push    %r8
+       push    %r9
+       push    %r10
+       push    %r11
+       mov     16(%rbp),%rdi   
+       call    alloc
+       mov     %rax,16(%rbp)
+       pop     %r11
+       pop     %r10
+       pop     %r9
+       pop     %r8
+       pop     %rdi
+       pop     %rsi
+       pop     %rdx
+       pop     %rcx
+       pop     %rax
+       pop     %rbp
+       ret
+       .size   GNAME(alloc_tramp),.-GNAME(alloc_tramp)
+
+               
+/*
+ * the closure trampoline
+ */
+       .text
+       .align  align_4byte,0x90
+       .global GNAME(closure_tramp)
+       .type   GNAME(closure_tramp),@function
+GNAME(closure_tramp):
+       mov     FDEFN_FUN_OFFSET(%rax),%rax
+       /* FIXME: The '*' after "jmp" in the next line is from PVE's
+        * patch posted to the CMU CL mailing list Oct 6, 1999. It looks
+        * reasonable, and it certainly seems as though if CMU CL needs it,
+        * SBCL needs it too, but I haven't actually verified that it's
+        * right. It would be good to find a way to force the flow of
+        * control through here to test it. */
+       jmp     *CLOSURE_FUN_OFFSET(%rax)
+       .size   GNAME(closure_tramp), .-GNAME(closure_tramp)
+
+/*
+ * fun-end breakpoint magic
+ */
+       .text
+       .global GNAME(fun_end_breakpoint_guts)
+       .align  align_4byte
+GNAME(fun_end_breakpoint_guts):
+       /* Multiple Value return */
+       jmp     multiple_value_return
+       /* Single value return: The eventual return will now use the
+          multiple values return convention but with a return values
+          count of one. */
+       mov     %rsp,%rbx       # Setup ebx - the ofp.
+       sub     $4,%rsp         # Allocate one stack slot for the return value
+       mov     $4,%rcx         # Setup ecx for one return value.
+       mov     $NIL,%rdi       # default second value
+       mov     $NIL,%rsi       # default third value
+               
+multiple_value_return:
+       
+       .global GNAME(fun_end_breakpoint_trap)
+GNAME(fun_end_breakpoint_trap):
+       int3
+       .byte   trap_FunEndBreakpoint
+       hlt                     # We should never return here.
+
+       .global GNAME(fun_end_breakpoint_end)
+GNAME(fun_end_breakpoint_end):
+
+\f
+       .global GNAME(do_pending_interrupt)
+       .type   GNAME(do_pending_interrupt),@function
+       .align  align_4byte,0x90
+GNAME(do_pending_interrupt):
+       int3
+       .byte   trap_PendingInterrupt
+       ret
+       .size   GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt)
+\f
+#ifdef LISP_FEATURE_GENCGC
+/* This is a fast bzero using the FPU. The first argument is the start
+ * address which needs to be aligned on an 8 byte boundary, the second
+ * argument is the number of bytes, which must be a nonzero multiple
+ * of 8 bytes. */
+/* FIXME whether this is still faster than using the OS's bzero or
+ * equivalent, we don't know */
+       .text
+       .globl  GNAME(i586_bzero)
+       .type   GNAME(i586_bzero),@function
+       .align  align_4byte,0x90
+GNAME(i586_bzero):
+       mov     4(%rsp),%rdx    # Load the start address.
+       mov     8(%rsp),%rax    # Load the number of bytes.
+       fldz
+l1:    fstl    0(%rdx)
+       add     $8,%rdx
+       sub     $8,%rax
+       jnz     l1
+       fstp    %st(0)
+       ret
+       .size   GNAME(i586_bzero),.-GNAME(i586_bzero)
+#endif 
+\f
+
+
+       .end
diff --git a/src/runtime/x86-64-linux-os.c b/src/runtime/x86-64-linux-os.c

new file mode 100644 (file)

index 0000000..c996813
--- /dev/null
+++ b/src/runtime/x86-64-linux-os.c
@@ -0,0 +1,229 @@
+/*
+ * The x86 Linux incarnation of arch-dependent OS-dependent routines.
+ * See also "linux-os.c".
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+#include <stddef.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
+#include <errno.h>
+
+#define __USE_GNU
+#include <sys/ucontext.h>
+#undef __USE_GNU
+
+
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <asm/ldt.h>
+#include <linux/unistd.h>
+#include <sys/mman.h>
+#include <linux/version.h>
+#include "thread.h"            /* dynamic_values_bytes */
+
+#if LINUX_VERSION_CODE < KERNEL_VERSION(2,6,0)
+#define user_desc  modify_ldt_ldt_s 
+#endif
+
+_syscall3(int, modify_ldt, int, func, void *, ptr, unsigned long, bytecount );
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+u32 local_ldt_copy[LDT_ENTRIES*LDT_ENTRY_SIZE/sizeof(u32)];
+
+/* This is never actually called, but it's great for calling from gdb when
+ * users have thread-related problems that maintainers can't duplicate */
+
+void debug_get_ldt()
+{ 
+    int n=modify_ldt (0, local_ldt_copy, sizeof local_ldt_copy);
+    printf("%d bytes in ldt: print/x local_ldt_copy\n", n);
+}
+
+lispobj modify_ldt_lock;       /* protect all calls to modify_ldt */
+
+int arch_os_thread_init(struct thread *thread) {
+    stack_t sigstack;
+#ifdef LISP_FEATURE_SB_THREAD
+    /* this must be called from a function that has an exclusive lock
+     * on all_threads
+     */
+    struct user_desc ldt_entry = {
+       1, 0, 0, /* index, address, length filled in later */
+       1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1
+    }; 
+    int n;
+    get_spinlock(&modify_ldt_lock,thread);
+    n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy);
+    /* get next free ldt entry */
+
+    if(n) {
+       u32 *p;
+       for(n=0,p=local_ldt_copy;*p;p+=LDT_ENTRY_SIZE/sizeof(u32))
+           n++;
+    }
+    ldt_entry.entry_number=n;
+    ldt_entry.base_addr=(unsigned long) thread;
+    ldt_entry.limit=dynamic_values_bytes;
+    ldt_entry.limit_in_pages=0;
+    if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) {
+       modify_ldt_lock=0;
+       /* modify_ldt call failed: something magical is not happening */
+       return -1;
+    }
+    __asm__ __volatile__ ("movw %w0, %%fs" : : "q" 
+                         ((n << 3) /* selector number */
+                          + (1 << 2) /* TI set = LDT */
+                          + 3)); /* privilege level */
+    thread->tls_cookie=n;
+    modify_ldt_lock=0;
+
+    if(n<0) return 0;
+#endif
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+    /* Signal handlers are run on the control stack, so if it is exhausted
+     * we had better use an alternate stack for whatever signal tells us
+     * we've exhausted it */
+    sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
+    sigstack.ss_flags=0;
+    sigstack.ss_size = 32*SIGSTKSZ;
+    sigaltstack(&sigstack,0);
+#endif
+    return 1;
+}
+
+struct thread *debug_get_fs() {
+    register u32 fs;
+    __asm__ __volatile__ ("movl %%fs,%0" : "=r" (fs)  : );
+    return fs;
+}
+
+/* free any arch/os-specific resources used by thread, which is now
+ * defunct.  Not called on live threads
+ */
+
+int arch_os_thread_cleanup(struct thread *thread) {
+    struct user_desc ldt_entry = {
+       0, 0, 0, 
+       0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0
+    }; 
+
+    ldt_entry.entry_number=thread->tls_cookie;
+    get_spinlock(&modify_ldt_lock,thread);
+    if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) {
+       modify_ldt_lock=0;
+       /* modify_ldt call failed: something magical is not happening */
+       return 0;
+    }
+    modify_ldt_lock=0;
+    return 1;
+}
+
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+#define RCASE(name) case reg_ ## name: return &context->uc_mcontext.gregs[REG_ ## name];
+    switch(offset) {
+        RCASE(RAX)
+       RCASE(RCX)
+       RCASE(RDX)
+       RCASE(RBX)
+       RCASE(RSP)
+       RCASE(RBP)
+       RCASE(RSI)
+       RCASE(RDI)
+       RCASE(R8)
+       RCASE(R9)
+       RCASE(R10)
+       RCASE(R11)
+       RCASE(R12)
+       RCASE(R13)
+       RCASE(R14)
+       RCASE(R15)
+      default: 
+       if(offset<NGREG) 
+           return &context->uc_mcontext.gregs[offset/2+4];
+       else return 0;
+    }
+    return &context->uc_mcontext.gregs[offset];
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+    return &context->uc_mcontext.gregs[REG_RIP]; /*  REG_EIP */
+}
+
+os_context_register_t *
+os_context_sp_addr(os_context_t *context)
+{                              
+    return &context->uc_mcontext.gregs[REG_RSP];
+}
+
+os_context_register_t *
+os_context_fp_addr(os_context_t *context)
+{
+    return &context->uc_mcontext.gregs[REG_RBP];
+}
+
+unsigned long
+os_context_fp_control(os_context_t *context)
+{
+#if 0
+    return ((((context->uc_mcontext.fpregs->cw) & 0xffff) ^ 0x3f) |
+           (((context->uc_mcontext.fpregs->sw) & 0xffff) << 16));
+#else
+    return 0;
+#endif
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+    return &context->uc_sigmask;
+}
+
+void
+os_restore_fp_control(os_context_t *context)
+{
+#if 0
+    asm ("fldcw %0" : : "m" (context->uc_mcontext.fpregs->cw));
+#endif
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
+
diff --git a/src/runtime/x86-64-linux-os.h b/src/runtime/x86-64-linux-os.h

new file mode 100644 (file)

index 0000000..90b34c0
--- /dev/null
+++ b/src/runtime/x86-64-linux-os.h
@@ -0,0 +1,14 @@
+#ifndef _X86_LINUX_OS_H
+#define _X86_LINUX_OS_H
+
+typedef struct ucontext os_context_t;
+typedef long os_context_register_t;
+
+static inline os_context_t *arch_os_get_context(void **void_context) {
+    return (os_context_t *) *void_context;
+}
+
+unsigned long os_context_fp_control(os_context_t *context);
+void os_restore_fp_control(os_context_t *context);
+
+#endif /* _X86_LINUX_OS_H */
diff --git a/src/runtime/x86-64-lispregs.h b/src/runtime/x86-64-lispregs.h

new file mode 100644 (file)

index 0000000..0851642
--- /dev/null
+++ b/src/runtime/x86-64-lispregs.h
@@ -0,0 +1,58 @@
+/*
+ * These register names and offsets correspond to definitions in
+ * compiler/x86/vm.lisp. They map into accessors in the OS-dependent
+ * POSIX signal context structure os_context_t via the
+ * os_context_register_addr(..) OS-dependent function.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/* the number of registers visible as registers in the virtual machine
+ * (excludes stuff like segment registers) */
+#define NREGS  (16)
+
+#ifdef LANGUAGE_ASSEMBLY
+#define REG(num) $ ## num
+#else
+#define REG(num) num
+#endif
+
+#define reg_RAX REG( 0)
+#define reg_RCX REG( 2)
+#define reg_RDX REG( 4)
+#define reg_RBX REG( 6)
+#define reg_RSP REG( 8)
+#define reg_RBP REG(10)
+#define reg_RSI REG(12)
+#define reg_RDI REG(14)
+#define reg_R8  REG(16)
+#define reg_R9  REG(18)
+#define reg_R10 REG(20)
+#define reg_R11 REG(22)
+#define reg_R12 REG(24)
+#define reg_R13 REG(26)
+#define reg_R14 REG(28)
+#define reg_R15 REG(30)
+
+#define REGNAMES "RAX", "RCX", "RDX", "RBX", "RSP", "RBP", "RSI", "RDI"
+
+/* classification of registers
+ *
+ * reg_SP = the register used by Lisp as stack pointer
+ * reg_FP = the register used by Lisp as frame pointer
+ * BOXED_REGISTERS =
+ *   the registers which may contain Lisp object pointers */
+#define reg_SP reg_RSP
+#define reg_FP reg_RBP
+#define BOXED_REGISTERS {\
+  reg_RAX, reg_RCX, reg_RDX, reg_RBX, reg_RSI, reg_RDI \
+}
diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp

index 88bb515..2b1266d 100644 (file)
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -151,11 +151,11 @@
              ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
              ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
              (1 (ash most-negative-fixnum 1) nil)
              ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
              ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
              (1 (ash most-negative-fixnum 1) nil)
-            (29 most-negative-fixnum t)
-            (30 (ash most-negative-fixnum 1) t)
-            (31 (ash most-negative-fixnum 1) t)
-            (64 (ash most-negative-fixnum 36) nil)
-            (65 (ash most-negative-fixnum 36) t)))
+            (#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t)
+            (#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
+            (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
+            (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil)
+            (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t)))
    (destructuring-bind (index int result) x
      (assert (eq (eval `(logbitp ,index ,int)) result))))
  
    (destructuring-bind (index int result) x
      (assert (eq (eval `(logbitp ,index ,int)) result))))
  
diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp

index 137d19d..bd37acb 100644 (file)
--- a/tests/bit-vector.impure-cload.lisp
+++ b/tests/bit-vector.impure-cload.lisp
@@ -32,6 +32,8 @@
      (assert (equal (bit-xor a b) #*001111111111111111111111111111111))
      (assert (equal (bit-and a b) #*010000000000000000000000000000000)))
    ;; now test the biggy, mostly that it works...
      (assert (equal (bit-xor a b) #*001111111111111111111111111111111))
      (assert (equal (bit-and a b) #*010000000000000000000000000000000)))
    ;; now test the biggy, mostly that it works...
+  #-x86-64 ; except on machines where addressable space is likely to be
+           ; much bigger than physical memory
    (let ((a (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0))
         (b (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0)))
      (bit-not a a)
    (let ((a (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0))
         (b (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0)))
      (bit-not a a)
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp

index e8f86a0..d371ea9 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -898,7 +898,7 @@
  \f
  ;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
  (defvar *compiler-note-count* 0)
  \f
  ;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
  (defvar *compiler-note-count* 0)
-#-alpha ; FIXME: make a better test!
+#-(or alpha x86-64) ; FIXME: make a better test!
  (handler-bind ((sb-ext:compiler-note (lambda (c)
                                        (declare (ignore c))
                                        (incf *compiler-note-count*))))
  (handler-bind ((sb-ext:compiler-note (lambda (c)
                                        (declare (ignore c))
                                        (incf *compiler-note-count*))))
diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp

index b61f5e5..9521ae4 100644 (file)
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -131,6 +131,7 @@
             (declare (type (simple-array (unsigned-byte 32) (*)) a))
             (declare (type (function (fixnum)) f))
             (funcall f (aref a 0))))
             (declare (type (simple-array (unsigned-byte 32) (*)) a))
             (declare (type (function (fixnum)) f))
             (funcall f (aref a 0))))
+    #-x86-64
      (assert
       (eval `(let ((n (1+ most-positive-fixnum)))
                (if (not (typep n '(unsigned-byte 32)))
      (assert
       (eval `(let ((n (1+ most-positive-fixnum)))
                (if (not (typep n '(unsigned-byte 32)))
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp

index ab8c3ec..a593394 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -110,17 +110,17 @@
           (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
           (funcall fun)))
    #-x86 ; <- known bug (?): fails for me on 0.8.17.31/Linux/x86 -- WHN 2004-12-27
           (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
           (funcall fun)))
    #-x86 ; <- known bug (?): fails for me on 0.8.17.31/Linux/x86 -- WHN 2004-12-27
-  (dolist (frame '(#-x86 "undefined function" ; bug 353
+  (dolist (frame '(#-(or x86 x86-64) "undefined function" ; bug 353
                     "FLET COMMON-LISP-USER::TEST"))
      (assert (verify-backtrace (lambda () (test #'optimized)) frame
                                :test #'equal
                     "FLET COMMON-LISP-USER::TEST"))
      (assert (verify-backtrace (lambda () (test #'optimized)) frame
                                :test #'equal
-                              :allow-bogus-frames (or #+x86 t))))
-  (dolist (frame '(#-x86 "undefined function" ; bug 353
+                              :allow-bogus-frames (or #+(or x86 x86-64) t))))
+  (dolist (frame '(#-(or x86 x86-64) "undefined function" ; bug 353
                     "FLET COMMON-LISP-USER::NOT-OPTIMIZED"
                     "FLET COMMON-LISP-USER::TEST"))
      (assert (verify-backtrace (lambda () (test #'not-optimized)) frame
                                :test #'equal
                     "FLET COMMON-LISP-USER::NOT-OPTIMIZED"
                     "FLET COMMON-LISP-USER::TEST"))
      (assert (verify-backtrace (lambda () (test #'not-optimized)) frame
                                :test #'equal
-                              :allow-bogus-frames (or #+x86 t)))))
+                              :allow-bogus-frames (or #+(or x86 x86-64) t)))))
  
  ;;; Division by zero was a common error on PPC.  It depended on the
  ;;; return function either being before INTEGER-/-INTEGER in memory,
  
  ;;; Division by zero was a common error on PPC.  It depended on the
  ;;; return function either being before INTEGER-/-INTEGER in memory,
@@ -151,8 +151,8 @@
    (defun throw-test ()
      (throw 'no-such-tag t))
    (assert (verify-backtrace #'throw-test 
    (defun throw-test ()
      (throw 'no-such-tag t))
    (assert (verify-backtrace #'throw-test 
-                            #-(or x86 sparc) 'throw-test
-                            #+(or x86 sparc) "XEP for COMMON-LISP-USER::THROW-TEST" ; bug 354
+                            #-(or x86 x86-64 sparc) 'throw-test
+                            #+(or x86 x86-64 sparc) "XEP for COMMON-LISP-USER::THROW-TEST" ; bug 354
                              :test #'equal)))
  
  ;;; success
                              :test #'equal)))
  
  ;;; success
diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp

index 25bc891..66e883b 100644 (file)
--- a/tools-for-build/ldso-stubs.lisp
+++ b/tools-for-build/ldso-stubs.lisp
@@ -55,7 +55,7 @@ ldso_stub__~A: ;                                \\
  #endif
          .text"
  
  #endif
          .text"
  
-#!+x86 "
+#!+(or x86 x86-64) "
  #define LDSO_STUBIFY(fct)                       \\
         .align 16 ;                             \\
  .globl ldso_stub__ ## fct ;                     \\
  #define LDSO_STUBIFY(fct)                       \\
         .align 16 ;                             \\
  .globl ldso_stub__ ## fct ;                     \\
diff --git a/version.lisp-expr b/version.lisp-expr

index 284ec4b..bdda81f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
  ;;; checkins which aren't released. (And occasionally for internal
  ;;; versions, especially for internal versions off the main CVS
  ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
  ;;; checkins which aren't released. (And occasionally for internal
  ;;; versions, especially for internal versions off the main CVS
  ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.18.13"
+"0.8.18.14"
author	Christophe Rhodes <csr21@cam.ac.uk>
	Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)
committer	Christophe Rhodes <csr21@cam.ac.uk>
	Thu, 6 Jan 2005 12:47:55 +0000 (12:47 +0000)
CREDITS		patch \| blob \| history
contrib/sb-bsd-sockets/constants.lisp		patch \| blob \| history
contrib/sb-bsd-sockets/sockopt.lisp		patch \| blob \| history
contrib/sb-posix/interface.lisp		patch \| blob \| history
contrib/sb-posix/posix-tests.lisp		patch \| blob \| history
contrib/sb-sprof/sb-sprof.lisp		patch \| blob \| history
make-config.sh		patch \| blob \| history
package-data-list.lisp-expr		patch \| blob \| history
src/assembly/x86-64/alloc.lisp	[new file with mode: 0644]	patch \| blob
src/assembly/x86-64/arith.lisp	[new file with mode: 0644]	patch \| blob
src/assembly/x86-64/array.lisp	[new file with mode: 0644]	patch \| blob
src/assembly/x86-64/assem-rtns.lisp	[new file with mode: 0644]	patch \| blob
src/assembly/x86-64/bit-bash.lisp	[new file with mode: 0644]	patch \| blob
src/assembly/x86-64/support.lisp	[new file with mode: 0644]	patch \| blob
src/code/bignum.lisp		patch \| blob \| history
src/code/bit-bash.lisp		patch \| blob \| history
src/code/cold-init.lisp		patch \| blob \| history
src/code/cross-misc.lisp		patch \| blob \| history
src/code/cross-sap.lisp		patch \| blob \| history
src/code/debug-int.lisp		patch \| blob \| history
src/code/defsetfs.lisp		patch \| blob \| history
src/code/defstruct.lisp		patch \| blob \| history
src/code/fop.lisp		patch \| blob \| history
src/code/foreign.lisp		patch \| blob \| history
src/code/hash-table.lisp		patch \| blob \| history
src/code/kernel.lisp		patch \| blob \| history
src/code/numbers.lisp		patch \| blob \| history
src/code/room.lisp		patch \| blob \| history
src/code/run-program.lisp		patch \| blob \| history
src/code/target-c-call.lisp		patch \| blob \| history
src/code/target-defstruct.lisp		patch \| blob \| history
src/code/target-hash-table.lisp		patch \| blob \| history
src/code/target-random.lisp		patch \| blob \| history
src/code/target-sap.lisp		patch \| blob \| history
src/code/target-sxhash.lisp		patch \| blob \| history
src/code/target-thread.lisp		patch \| blob \| history
src/code/target-unithread.lisp		patch \| blob \| history
src/code/toplevel.lisp		patch \| blob \| history
src/code/x86-64-vm.lisp	[new file with mode: 0644]	patch \| blob
src/compiler/aliencomp.lisp		patch \| blob \| history
src/compiler/disassem.lisp		patch \| blob \| history
src/compiler/generic/core.lisp		patch \| blob \| history
src/compiler/generic/early-objdef.lisp		patch \| blob \| history
src/compiler/generic/genesis.lisp		patch \| blob \| history
src/compiler/generic/objdef.lisp		patch \| blob \| history
src/compiler/generic/primtype.lisp		patch \| blob \| history
src/compiler/generic/vm-fndb.lisp		patch \| blob \| history
src/compiler/pack.lisp		patch \| blob \| history
src/compiler/saptran.lisp		patch \| blob \| history
src/compiler/target-disassem.lisp		patch \| blob \| history
src/compiler/x86-64/alloc.lisp		patch \| blob \| history
src/compiler/x86-64/arith.lisp		patch \| blob \| history
src/compiler/x86-64/array.lisp		patch \| blob \| history
src/compiler/x86-64/backend-parms.lisp		patch \| blob \| history
src/compiler/x86-64/c-call.lisp		patch \| blob \| history
src/compiler/x86-64/call.lisp		patch \| blob \| history
src/compiler/x86-64/cell.lisp		patch \| blob \| history
src/compiler/x86-64/char.lisp		patch \| blob \| history
src/compiler/x86-64/float.lisp		patch \| blob \| history
src/compiler/x86-64/insts.lisp		patch \| blob \| history
src/compiler/x86-64/macros.lisp		patch \| blob \| history
src/compiler/x86-64/memory.lisp		patch \| blob \| history
src/compiler/x86-64/move.lisp		patch \| blob \| history
src/compiler/x86-64/nlx.lisp		patch \| blob \| history
src/compiler/x86-64/parms.lisp		patch \| blob \| history
src/compiler/x86-64/pred.lisp		patch \| blob \| history
src/compiler/x86-64/sap.lisp		patch \| blob \| history
src/compiler/x86-64/show.lisp		patch \| blob \| history
src/compiler/x86-64/static-fn.lisp		patch \| blob \| history
src/compiler/x86-64/system.lisp		patch \| blob \| history
src/compiler/x86-64/type-vops.lisp		patch \| blob \| history
src/compiler/x86-64/values.lisp		patch \| blob \| history
src/compiler/x86-64/vm.lisp		patch \| blob \| history
src/compiler/x86/array.lisp		patch \| blob \| history
src/runtime/Config.x86_64-linux		patch \| blob \| history
src/runtime/backtrace.c		patch \| blob \| history
src/runtime/cheneygc.c		patch \| blob \| history
src/runtime/dynbind.c		patch \| blob \| history
src/runtime/gc-common.c		patch \| blob \| history
src/runtime/gc-internal.h		patch \| blob \| history
src/runtime/gencgc-alloc-region.h		patch \| blob \| history
src/runtime/gencgc-internal.h		patch \| blob \| history
src/runtime/gencgc.c		patch \| blob \| history
src/runtime/interrupt.c		patch \| blob \| history
src/runtime/monitor.c		patch \| blob \| history
src/runtime/parse.c		patch \| blob \| history
src/runtime/purify.c		patch \| blob \| history
src/runtime/runtime.h		patch \| blob \| history
src/runtime/save.c		patch \| blob \| history
src/runtime/thread.c		patch \| blob \| history
src/runtime/thread.h		patch \| blob \| history
src/runtime/x86-64-arch.c	[new file with mode: 0644]	patch \| blob
src/runtime/x86-64-arch.h	[new file with mode: 0644]	patch \| blob
src/runtime/x86-64-assem.S	[new file with mode: 0644]	patch \| blob
src/runtime/x86-64-linux-os.c	[new file with mode: 0644]	patch \| blob
src/runtime/x86-64-linux-os.h	[new file with mode: 0644]	patch \| blob
src/runtime/x86-64-lispregs.h	[new file with mode: 0644]	patch \| blob
tests/arith.pure.lisp		patch \| blob \| history
tests/bit-vector.impure-cload.lisp		patch \| blob \| history
tests/compiler.impure.lisp		patch \| blob \| history
tests/compiler.pure-cload.lisp		patch \| blob \| history
tests/debug.impure.lisp		patch \| blob \| history
tools-for-build/ldso-stubs.lisp		patch \| blob \| history
version.lisp-expr		patch \| blob \| history