From 78fa16bf55be44cc16845be84d98023e83fb14bc Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 6 Jan 2005 12:47:55 +0000 Subject: [PATCH] 0.8.18.14: Merge x86-64-again branch onto HEAD. Many, many, many 64-bit cleanups in code/, runtime/, compiler/, compiler/generic/ New SAP-REF-WORD and friends. Various fixes to the x86-64 backends (and addition of assembly/ and runtime/ files necessary). Implementation of Unicode-related stuff by CSR. Signed modular arithmetic has not yet been implemented. A number of tests fail: ... alien.impure.lisp: enum <-> integer array conversion ... exhaust.impure.lisp: "deferred gubbins" ... float.pure.lisp: float infinities ... foreign.test.sh: "deferred gubbins" It's possible that this merge will cause alpha32 to break in an interesting way, probably related to undefined-alien. Needs debugging. Other architectures have been tested, but of course it's possible that something has gone wrong. Though I (CSR) am merging this, the vast majority of the work was done by Juho Snellman (building on Dan Barlow's initial work to get it into executing lisp code in cold-init), with guest appearances by Cheuksan Edward Wang and Vincent Arkesteijn. --- CREDITS | 21 +- contrib/sb-bsd-sockets/constants.lisp | 86 +- contrib/sb-bsd-sockets/sockopt.lisp | 8 +- contrib/sb-posix/interface.lisp | 4 +- contrib/sb-posix/posix-tests.lisp | 10 +- contrib/sb-sprof/sb-sprof.lisp | 10 +- make-config.sh | 5 +- package-data-list.lisp-expr | 16 +- src/assembly/x86-64/alloc.lisp | 59 + src/assembly/x86-64/arith.lisp | 303 ++++ src/assembly/x86-64/array.lisp | 39 + src/assembly/x86-64/assem-rtns.lisp | 263 ++++ src/assembly/x86-64/bit-bash.lisp | 12 + src/assembly/x86-64/support.lisp | 46 + src/code/bignum.lisp | 21 +- src/code/bit-bash.lisp | 17 +- src/code/cold-init.lisp | 4 +- src/code/cross-misc.lisp | 4 +- src/code/cross-sap.lisp | 6 +- src/code/debug-int.lisp | 117 +- src/code/defsetfs.lisp | 8 +- src/code/defstruct.lisp | 9 +- src/code/fop.lisp | 10 +- src/code/foreign.lisp | 3 +- src/code/hash-table.lisp | 9 +- src/code/kernel.lisp | 13 +- src/code/numbers.lisp | 4 +- src/code/room.lisp | 26 +- src/code/run-program.lisp | 11 +- src/code/target-c-call.lisp | 4 +- src/code/target-defstruct.lisp | 4 +- src/code/target-hash-table.lisp | 14 +- src/code/target-random.lisp | 3 +- src/code/target-sap.lisp | 24 + src/code/target-sxhash.lisp | 36 +- src/code/target-thread.lisp | 12 +- src/code/target-unithread.lisp | 4 +- src/code/toplevel.lisp | 10 +- src/code/x86-64-vm.lisp | 341 +++++ src/compiler/aliencomp.lisp | 14 +- src/compiler/disassem.lisp | 16 +- src/compiler/generic/core.lisp | 2 +- src/compiler/generic/early-objdef.lisp | 4 +- src/compiler/generic/genesis.lisp | 82 +- src/compiler/generic/objdef.lisp | 26 +- src/compiler/generic/primtype.lisp | 126 +- src/compiler/generic/vm-fndb.lisp | 4 +- src/compiler/pack.lisp | 4 +- src/compiler/saptran.lisp | 36 +- src/compiler/target-disassem.lisp | 82 +- src/compiler/x86-64/alloc.lisp | 2 +- src/compiler/x86-64/arith.lisp | 25 +- src/compiler/x86-64/array.lisp | 713 +++++----- src/compiler/x86-64/backend-parms.lisp | 2 +- src/compiler/x86-64/c-call.lisp | 147 +- src/compiler/x86-64/call.lisp | 33 +- src/compiler/x86-64/cell.lisp | 37 +- src/compiler/x86-64/char.lisp | 173 ++- src/compiler/x86-64/float.lisp | 2428 +++++--------------------------- src/compiler/x86-64/insts.lisp | 828 ++++++++--- src/compiler/x86-64/macros.lisp | 68 +- src/compiler/x86-64/memory.lisp | 30 +- src/compiler/x86-64/move.lisp | 77 +- src/compiler/x86-64/nlx.lisp | 10 +- src/compiler/x86-64/parms.lisp | 18 +- src/compiler/x86-64/pred.lisp | 21 +- src/compiler/x86-64/sap.lisp | 18 +- src/compiler/x86-64/show.lisp | 7 +- src/compiler/x86-64/static-fn.lisp | 12 +- src/compiler/x86-64/system.lisp | 4 +- src/compiler/x86-64/type-vops.lisp | 181 ++- src/compiler/x86-64/values.lisp | 29 + src/compiler/x86-64/vm.lisp | 148 +- src/compiler/x86/array.lisp | 322 +---- src/runtime/Config.x86_64-linux | 24 +- src/runtime/backtrace.c | 2 +- src/runtime/cheneygc.c | 50 +- src/runtime/dynbind.c | 1 + src/runtime/gc-common.c | 236 ++-- src/runtime/gc-internal.h | 31 +- src/runtime/gencgc-alloc-region.h | 6 +- src/runtime/gencgc-internal.h | 16 +- src/runtime/gencgc.c | 484 ++++--- src/runtime/interrupt.c | 12 +- src/runtime/monitor.c | 8 +- src/runtime/parse.c | 2 +- src/runtime/purify.c | 253 ++-- src/runtime/runtime.h | 7 +- src/runtime/save.c | 42 +- src/runtime/thread.c | 8 +- src/runtime/thread.h | 8 +- src/runtime/x86-64-arch.c | 393 ++++++ src/runtime/x86-64-arch.h | 38 + src/runtime/x86-64-assem.S | 335 +++++ src/runtime/x86-64-linux-os.c | 229 +++ src/runtime/x86-64-linux-os.h | 14 + src/runtime/x86-64-lispregs.h | 58 + tests/arith.pure.lisp | 10 +- tests/bit-vector.impure-cload.lisp | 2 + tests/compiler.impure.lisp | 2 +- tests/compiler.pure-cload.lisp | 1 + tests/debug.impure.lisp | 12 +- tools-for-build/ldso-stubs.lisp | 2 +- version.lisp-expr | 2 +- 104 files changed, 5368 insertions(+), 4245 deletions(-) create mode 100644 src/assembly/x86-64/alloc.lisp create mode 100644 src/assembly/x86-64/arith.lisp create mode 100644 src/assembly/x86-64/array.lisp create mode 100644 src/assembly/x86-64/assem-rtns.lisp create mode 100644 src/assembly/x86-64/bit-bash.lisp create mode 100644 src/assembly/x86-64/support.lisp create mode 100644 src/code/x86-64-vm.lisp create mode 100644 src/runtime/x86-64-arch.c create mode 100644 src/runtime/x86-64-arch.h create mode 100644 src/runtime/x86-64-assem.S create mode 100644 src/runtime/x86-64-linux-os.c create mode 100644 src/runtime/x86-64-linux-os.h create mode 100644 src/runtime/x86-64-lispregs.h diff --git a/CREDITS b/CREDITS index be6601d..36d9436 100644 --- 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 - 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, @@ -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 - 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 @@ -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. +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 diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 22f6793..ab29f66 100644 --- 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"))) - (: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? - (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? - (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? - (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? - (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? - (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) - (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)) - (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)) - (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)) - (optlen (* integer))))) + (optlen (* int))))) ) diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index 88e83b6..7fa1ff7 100644 --- 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 - `(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) @@ -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) - (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 - 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) @@ -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 - 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 diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index bf9498e..ed265c1 100644 --- 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 - ;; KLUDGE: #XFFFFFFFF is (void *)-1, which is the charming return - ;; value of mmap on failure. Except on 64 bit systems ... (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)) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index a82bd7e..1108583 100644 --- 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) +#-(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) - +;; 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 "/"))) diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index d638443..dffc369 100644 --- 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." - '(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.") @@ -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)) - (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))))))) @@ -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)) - (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)) diff --git a/make-config.sh b/make-config.sh index 0ba561e..238bc8a 100644 --- 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 - *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 ;; @@ -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 +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! diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 72b7b59..076bbe4 100644 --- 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-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-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" @@ -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" - #!+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" @@ -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" - #!+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" @@ -1823,7 +1824,8 @@ SB-KERNEL) have been undone, but probably more remain." "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" @@ -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" - "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" diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp new file mode 100644 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") + +;;;; 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 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") + +;;;; 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)) + +;;;; 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) + +;;;; 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 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") + +;;;; 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)) + +;;;; 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 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") + +;;;; 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)) + +;;;; 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)))) + +(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 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 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 --- 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 - (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 @@ -1196,14 +1196,15 @@ (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)) diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 66cfb57..0ca7ed6 100644 --- 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))) - (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)) - (+ (* (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) - (values (unsigned-byte 32)) + (values sb!vm:word) (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) - (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))) - (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)) ;;;; CONSTANT-BIT-BASH diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index f3217e6..db603e9 100644 --- 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 (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))))) - #!+(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) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 86d8082..51efcbf 100644 --- 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)) -#!-alpha +#!-(or alpha x86-64) (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))) diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp index 739fa11..574adeb 100644 --- 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-64 sap-ref-sap + sap-ref-word 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 --- 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))) -;;;; X86 support +;;;; (OR X86 X86-64) support -#!+x86 +#!+(or x86 x86-64) (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)) - ;;(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. - (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) - 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)))) + #+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) @@ -701,10 +704,10 @@ (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))) - #!-x86 + #!-(or x86 x86-64) (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. -#!-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)) @@ -731,7 +734,7 @@ (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)) @@ -743,9 +746,10 @@ (#.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)) @@ -755,7 +759,7 @@ (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)) @@ -767,7 +771,8 @@ (#.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))) @@ -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. -#!-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) @@ -833,7 +838,7 @@ 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") @@ -883,7 +888,7 @@ (+ 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") @@ -923,7 +928,7 @@ (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)) @@ -983,7 +988,7 @@ 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 @@ -1092,34 +1097,34 @@ register." (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)) - #!+x86 + #!+(or x86 x86-64) (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)) - #!+x86 + #!+(or x86 x86-64) (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) - #!+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)))) - (push (cons #!-x86 + (push (cons #!-(or x86 x86-64) (stack-ref catch sb!vm:catch-block-tag-slot) - #!+x86 + #!+(or x86 x86-64) (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))) @@ -1984,9 +1989,9 @@ register." (defun make-valid-lisp-obj (val) (if (or ;; fixnum - (zerop (logand val 3)) + (zerop (logand val sb!vm:fixnum-tag-mask)) ;; 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) @@ -2006,7 +2011,7 @@ register." (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 @@ -2149,7 +2154,7 @@ register." (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) @@ -2238,14 +2243,14 @@ register." (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 - (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 - (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))))))) @@ -2278,7 +2283,7 @@ register." (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 @@ -2437,7 +2442,7 @@ register." 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 @@ -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 - (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 - (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 - (setf (signed-sap-ref-32 + (setf (signed-sap-ref-word 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))) @@ -2891,7 +2896,7 @@ register." (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))))) @@ -3225,8 +3230,8 @@ register." (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*) @@ -3243,9 +3248,9 @@ register." ;;;; 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 - (+ 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 @@ -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) - #!-x86 + #!-(or x86 x86-64) (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)) @@ -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) - #!+x86 + #!+(or x86 x86-64) (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 diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index 9a9e11c..002e818 100644 --- 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) -#!+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) -#!+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) @@ -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 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) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8a72c68..5c3ff13 100644 --- 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) - (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 @@ -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. - `(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))))))) @@ -1314,7 +1315,7 @@ ,@(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 diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 33146bf..89bafa3 100644 --- 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: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)) ;;;; miscellaneous fops diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 5e23aa0..4daef08 100644 --- 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) - ;; 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 diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 1690fd3..8a79e0e 100644 --- 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. - (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. - (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. - (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) (*))))) (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 --- 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)) -#!+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)) -#!+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 --- 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 -#!-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))))) -#!+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))) diff --git a/src/code/room.lisp b/src/code/room.lisp index c7696b2..3dc375e 100644 --- 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-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-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) @@ -110,13 +115,14 @@ (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 @@ -213,7 +219,7 @@ #+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 @@ -441,7 +447,7 @@ (%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) @@ -484,7 +490,7 @@ #.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 diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index f2dfe10..0808fdd 100644 --- 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]. - (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) @@ -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)) - (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) @@ -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)))) - (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)) - (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) diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index e35489e..1d312c3 100644 --- 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 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-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) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 267e58b..33dc00d 100644 --- 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)) - (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)))))) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 38bae0c..70d6ddb 100644 --- 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 - :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 - :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 @@ -182,7 +184,7 @@ :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. @@ -246,18 +248,18 @@ (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 - :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 - :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)) diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 97acbf8..c729bba 100644 --- 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) - (- 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)) diff --git a/src/code/target-sap.lisp b/src/code/target-sap.lisp index 0f937b6..d49334a 100644 --- a/src/code/target-sap.lisp +++ b/src/code/target-sap.lisp @@ -83,6 +83,12 @@ (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) @@ -132,6 +138,12 @@ (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) @@ -156,6 +168,12 @@ (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) @@ -180,6 +198,12 @@ (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)) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 38422a1..df0ec12 100644 --- 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)) - (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) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index b882962..0bedaba 100644 --- 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))) - 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)))) @@ -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 ((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)) - (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 @@ -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)) - (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)))))) diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index 886ed82..89f7bb2 100644 --- 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))) - (* n 4))) + (* n sb!vm:n-word-bytes))) (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 ()) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 4f3d0f2..2a8eb52 100644 --- 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 - (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) @@ -206,11 +206,11 @@ steppers to maintain contextual information.") (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)))))) - (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))) @@ -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 - (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) @@ -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))))))) - (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)))) diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp new file mode 100644 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") + +;;;; 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)) + +;;;; 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) + +;;;; :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))))))) + +;;;; 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) + + +;;;; 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 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))))))) + +;;; 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 --- 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) - #!+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))) - #!-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))) @@ -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) - #!+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)) - #!-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))) @@ -678,19 +678,19 @@ (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))) - #!+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) - #!-x86 (progn + #!-(or x86 x86-64) (progn (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 --- 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 address () '(unsigned-byte 32)) +(deftype address () '(unsigned-byte #.sb!vm:n-word-bits)) (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-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.") @@ -131,7 +139,7 @@ dchunk= dchunk-count-bits)) -(def!constant dchunk-bits 32) +(def!constant dchunk-bits #.sb!vm:n-word-bits) (deftype dchunk () `(unsigned-byte ,dchunk-bits)) @@ -139,7 +147,7 @@ `(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)) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index c4b2f7f..890263e 100644 --- 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)) - #!+x86 + #!+(or x86 x86-64) (: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 --- 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 - ;; 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 @@ -151,7 +151,9 @@ unused05 ; 01101110 unused06 ; 01110010 unused07 ; 01110110 + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) 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)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index fdfa848..fd4cbfc 100644 --- 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)) +(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 @@ -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) - 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)) @@ -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* ((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) @@ -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. - #!-x86 + #!-(or x86 x86-64) ;; 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 @@ -3106,7 +3092,7 @@ initially undefined function references:~2%") 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) @@ -3174,7 +3160,7 @@ initially undefined function references:~2%") ;; 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") diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 0659a28..1e4fc8b 100644 --- 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) - (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 @@ -170,9 +170,9 @@ (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)) - #!+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 @@ -226,11 +226,11 @@ :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)) - #!+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. @@ -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") - #!-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") - #!-x86 current-code + #!-(or x86 x86-64) current-code 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) - (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 @@ -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 - #!+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)) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index a219a4f..d11bcf6 100644 --- 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") -#!-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") -#!-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") -#!+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)) -#!+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))) -#!-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)) -#!+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)) @@ -52,17 +53,16 @@ (/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") @@ -161,32 +161,48 @@ (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 - (#!-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)) - (#!-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)) @@ -198,22 +214,26 @@ (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) - #!-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) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index e0a4899..a2c9d35 100644 --- 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 - #!+#.(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 - #!+#.(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 diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 114e61e..b4c5a67 100644 --- 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. - #!-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)) @@ -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. - #!+x86 + #!+(or x86 x86-64) (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 --- 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 system-area-pointer) (signed-byte 32) +(defknown sap- (system-area-pointer system-area-pointer) + (signed-byte #.sb!vm::n-word-bits) (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)) -(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) @@ -78,6 +80,14 @@ (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)) @@ -102,6 +112,14 @@ (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) @@ -182,3 +200,15 @@ ;; 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 --- 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) - (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 @@ -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 ((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)) - + + ;; 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) - + (setf prefix-p (null (inst-printer inst))) - + (when control - (funcall control chunk inst stream dstate)))))) - ))))) - + (funcall control chunk inst stream dstate)) + )))))))))) + (setf (dstate-cur-offs dstate) (dstate-next-offs 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))) +;;; 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) @@ -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) - (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 @@ -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) - (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) - (declare (type (member 8 16 32) length) + (declare (type (member 8 16 32 64) length) (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) @@ -2007,6 +2046,7 @@ (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 diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index bc7de22..a2300fb 100644 --- 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 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)) diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index 1dbf7b0..14c6e28 100644 --- 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")) +;; 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) - (: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) @@ -134,7 +136,7 @@ (: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 @@ -609,8 +611,7 @@ (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) @@ -960,6 +961,7 @@ (:temporary (:sc unsigned-reg :from (:argument 0)) t1) (:generator 60 (move result arg) + (move t1 arg) (inst mov temp result) (inst shr temp 1) @@ -992,8 +994,7 @@ (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) @@ -1063,7 +1064,7 @@ (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) @@ -1076,10 +1077,9 @@ (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)) - (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/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") diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp index 917906e..725b457 100644 --- a/src/compiler/x86-64/array.lisp +++ b/src/compiler/x86-64/array.lisp @@ -11,6 +11,11 @@ (in-package "SB!VM") + +;; 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) @@ -33,7 +38,7 @@ :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)) @@ -140,15 +145,11 @@ ,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-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 @@ -175,7 +176,7 @@ (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) @@ -188,7 +189,7 @@ (: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) @@ -249,7 +250,8 @@ (: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) @@ -267,18 +269,21 @@ (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) - (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)) - (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 mov (make-ea :dword :base object + (inst mov (make-ea :qword :base object :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) + (:temporary (:sc unsigned-reg) dword-index) (: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") @@ -315,16 +322,15 @@ (: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 - (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") @@ -334,33 +340,19 @@ (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 - (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") @@ -369,37 +361,19 @@ (: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 - (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") @@ -411,11 +385,10 @@ (: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") @@ -423,16 +396,15 @@ (: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 - (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") @@ -445,30 +417,13 @@ (: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) - 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") @@ -477,38 +432,19 @@ (: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 - (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 @@ -524,17 +460,16 @@ (: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))) - (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") @@ -542,24 +477,22 @@ (: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))) - (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))) - (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") @@ -575,41 +508,23 @@ (: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))) - (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) - (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") @@ -618,51 +533,31 @@ (: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))) - (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))) - (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) - (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") @@ -675,18 +570,16 @@ (: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))) - (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") @@ -694,24 +587,22 @@ (: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))) - (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))) - (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") @@ -727,41 +618,23 @@ (: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))) - (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) - (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") @@ -770,53 +643,31 @@ (: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))) - (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))) - (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) - (inst fstd result-imag)) - (inst fxch value-imag)))) - - - + (inst movsd result-imag value-imag))))) @@ -841,7 +692,7 @@ (: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 @@ -874,7 +725,7 @@ (: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)) @@ -912,7 +763,7 @@ (: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 @@ -946,7 +797,7 @@ (: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)) @@ -984,13 +835,14 @@ (: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 - :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) @@ -1018,7 +870,7 @@ (: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)) @@ -1038,14 +890,88 @@ ;;; 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) - (: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 @@ -1057,9 +983,9 @@ (: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 @@ -1071,10 +997,10 @@ (: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) @@ -1082,22 +1008,95 @@ 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)) - (value :scs (base-char-reg))) + (value :scs (character-reg))) (: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))) +) ; 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)) + ;;; 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) - (: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 @@ -1154,7 +1153,7 @@ (: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)) @@ -1190,7 +1189,7 @@ (: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 @@ -1226,7 +1225,7 @@ (: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) @@ -1262,7 +1261,7 @@ (: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 @@ -1298,7 +1297,7 @@ (: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) @@ -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 (: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) - (: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) - (: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) - (: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 @@ -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) - (: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) @@ -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) - (: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) @@ -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) - (: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) @@ -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) - (:arg-types sb!c::raw-vector (:constant (signed-byte 61)) + (:arg-types sb!c::raw-vector (:constant low-index) 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 --- a/src/compiler/x86-64/backend-parms.lisp +++ b/src/compiler/x86-64/backend-parms.lisp @@ -17,7 +17,7 @@ ;;;; compiler constants -(def!constant +backend-fasl-file-implementation+ :x86) +(def!constant +backend-fasl-file-implementation+ :x86-64) (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 --- 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)) + (register-args 0) + (xmm-args 0) (stack-frame-size 0)) +(defun int-arg (state prim-type reg-sc stack-sc) + (let ((reg-args (arg-state-register-args state))) + (cond ((< reg-args 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) - (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)) - (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)) - (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)) - (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)) @@ -69,12 +74,17 @@ (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) - (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))))) @@ -85,24 +95,17 @@ (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)) - (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)) - (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))) @@ -188,51 +191,61 @@ (: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)))) +#!+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)) - (: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) - (:ignore args ecx edx) (: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) diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index f1ce595..eb4f7f4 100644 --- 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) + (inst nop) (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. + (inst nop) (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. + (inst nop) (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))) + (inst nop) (inst jmp-short variable-values) (cond ((location= start (first *register-arg-tns*)) @@ -443,6 +447,7 @@ (:args (fp) (nfp) (args :more t)) + (:temporary (:sc unsigned-reg) return-label) (: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)) - (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))))) @@ -482,6 +487,7 @@ (:args (fp) (nfp) (args :more t)) + (:temporary (:sc unsigned-reg) return-label) (: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 - (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))))) @@ -528,6 +534,7 @@ (:args (fp) (nfp) (args :more t)) + (:temporary (:sc unsigned-reg) return-label) (: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 - (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))))) @@ -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) + (: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. @@ -910,8 +918,11 @@ (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. - (inst jmp (make-fixup 'tail-call-variable :assembly-routine)))) + (inst jmp call-target))) ;;;; 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) 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) @@ -1064,7 +1076,10 @@ (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))) ;;;; 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 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. diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index a6290c8..87c5e9c 100644 --- 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))) + (:temporary (:sc descriptor-reg) temp) (:info name offset lowtag) (:ignore name) (:results) (:generator 1 - (if (sc-is value immediate) + (if (sc-is value immediate) (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)))) diff --git a/src/compiler/x86-64/char.lisp b/src/compiler/x86-64/char.lisp index 684a88a..bbd1fa4 100644 --- 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. -(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 - (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. -(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 - (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 - :scs (base-char-reg) + :scs (character-reg) :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))) -(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 - :scs (base-char-reg)) + :scs (character-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 - (base-char-reg + (character-reg (move y x)) - (base-char-stack + (character-stack + #!-sb-unicode (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 - (base-char-reg) (any-reg descriptor-reg)) + (character-reg) (any-reg descriptor-reg)) ;;;; other operations (define-vop (char-code) (:translate char-code) (:policy :fast-safe) - (:args (ch :scs (base-char-reg base-char-stack))) - (:arg-types base-char) + (:args (ch :scs (character-reg character-stack))) + (:arg-types character) (: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) @@ -105,19 +146,19 @@ (: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))) -;;; 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) @@ -127,21 +168,21 @@ (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)) -(define-vop (fast-char/base-char base-char-compare) +(define-vop (fast-char>/character character-compare) (: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) @@ -151,14 +192,14 @@ (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)) -(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)) diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index 2b3f28c..9c018cf 100644 --- 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) + (declare (ignore kind)) `(make-ea :qword :base rbp-tn :disp (- (* (+ (tn-offset ,tn) 1) @@ -77,66 +78,29 @@ ;;;; 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))) -;;; got this far 20040627 - (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)) - (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)) - (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)) @@ -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))) - (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))) - (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)) - (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))) - (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))) - (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)) - (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))) ;;;; 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) @@ -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. - (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 @@ -283,8 +213,7 @@ (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)) @@ -298,11 +227,11 @@ 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)) +#+nil (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*))))) +#+nil (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 - (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) @@ -330,8 +259,7 @@ (: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)) @@ -348,11 +276,9 @@ 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))) - (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)) @@ -367,11 +293,9 @@ 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))) - (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)) @@ -384,18 +308,22 @@ (: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))) - (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))))) - (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)) ;;;; the move argument vops ;;;; @@ -411,38 +339,29 @@ :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) - (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))) - (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) - (:double 2) - (:long 3))) + (:double 2) )) 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) @@ -457,53 +376,35 @@ :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))) - (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))) - (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))) - (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))) - (inst fxch imag-tn) ,@(ecase format - (:single - '((inst fst (ea-for-csf-imag-stack y fp)))) - (:double - '((inst fstd (ea-for-cdf-imag-stack y fp))))) - (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 @@ -519,690 +420,183 @@ ;;;; 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)) + + -(macrolet ((frob (name inst translate sc type) +(macrolet ((frob ((name translate sc type) &body body) `(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))) ;;;; 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) - (: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) - (: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) - (:policy :fast-safe) - (:note "inline float comparison") - (:ignore temp) + (:vop-var vop) (: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 (0/single-float float-test) +(define-vop (>double-float double-float-compare) (: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 >) - (: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))) + ;;;; 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) @@ -1218,17 +612,16 @@ (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 - (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))) @@ -1240,18 +633,11 @@ (: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))) @@ -1264,34 +650,18 @@ (: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) - (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))) - (: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) @@ -1301,33 +671,20 @@ (: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)) @@ -1379,7 +736,7 @@ (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) @@ -1396,31 +753,25 @@ (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 - (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))) - (: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 - (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) @@ -1437,11 +788,10 @@ (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 - (inst mov bits float)) + (move bits float)) (descriptor-reg (loadw bits float single-float-value-slot @@ -1449,14 +799,16 @@ (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))) - (: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) @@ -1465,23 +817,20 @@ (: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 - (loadw hi-bits rbp-tn (- (1+ (tn-offset float))))) + (loadw hi-bits ebp-tn (- (tn-offset float)))) (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))) - (: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) @@ -1490,17 +839,15 @@ (: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 - (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 - other-pointer-lowtag))))) + other-pointer-lowtag))) + (inst shl lo-bits 32) + (inst shr lo-bits 32))) ;;;; float mode hackery @@ -1558,1086 +905,6 @@ (move res new))) -(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 - - ;;;; complex float VOPs (define-vop (make-complex-single-float) @@ -2654,35 +921,15 @@ (: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) - (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) - (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 - (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) @@ -2700,33 +947,13 @@ (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) - (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 - (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)) @@ -2740,14 +967,9 @@ :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 @@ -2758,8 +980,7 @@ (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 @@ -2770,8 +991,7 @@ (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) diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 0ae887b..4b8fd6c 100644 --- 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)) +;; 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) @@ -40,7 +43,7 @@ :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* @@ -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) - (declare (ignore dstate)) + (declare (ignore dstate) + (type full-reg value)) (princ (aref (ecase width (:byte *byte-reg-names*) (:word *word-reg-names*) @@ -61,67 +65,80 @@ ) (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 - (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) - (declare (type reg value) + (declare (type (or full-reg list) value) (type stream stream) (type sb!disassem:disassem-state dstate)) - (print-reg-with-width value - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+) - stream - dstate)) + (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) - (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) - (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)) - (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) - (declare (type (or list reg) value) + (declare (type (or list full-reg) value) (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) - (declare (type (or list reg) value) + (declare (type (or list full-reg) value) (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 t dstate))) + (print-mem-access value stream t 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)) - (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) - (declare (type (or list reg) value) + (declare (type (or list full-reg) value) (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))) @@ -129,6 +146,22 @@ (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 @@ -136,44 +169,59 @@ (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) - (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) - (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 @@ -181,16 +229,17 @@ (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 - (or (sb!disassem:dstate-get-prop dstate 'word-width) + (or (sb!disassem:dstate-get-prop dstate 'reg-width) +default-operand-size+))) - (when (not (eql word-width +default-operand-size+)) + (when (not (eql reg-width +default-operand-size+)) ;; Reset it. - (setf (sb!disassem:dstate-get-prop dstate 'word-width) + (setf (sb!disassem:dstate-get-prop dstate 'reg-width) +default-operand-size+)) - word-width)))) + reg-width)))) (defun read-address (value dstate) (declare (ignore value)) ; always nil anyway @@ -201,6 +250,7 @@ (:byte 8) (:word 16) (:dword 32) + (:qword 64) (:float 32) (:double 64))) @@ -236,7 +286,10 @@ :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 @@ -246,13 +299,16 @@ :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 - (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 @@ -269,7 +325,7 @@ :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)))) @@ -294,6 +350,15 @@ :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) @@ -315,11 +380,11 @@ (or (null value) (and (numberp value) (zerop value))) ; zzz jrd (princ 'b stream) - (let ((word-width + (let ((reg-width ;; 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+))) - (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* @@ -379,6 +444,15 @@ (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)) @@ -392,6 +466,12 @@ :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)) @@ -400,6 +480,26 @@ (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)) @@ -411,6 +511,16 @@ (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)) @@ -431,6 +541,17 @@ ;; 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 @@ -441,6 +562,16 @@ (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)) @@ -451,6 +582,14 @@ ;; 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 @@ -460,6 +599,13 @@ (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 @@ -480,6 +626,20 @@ ;; 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)) @@ -563,6 +723,10 @@ :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) @@ -678,19 +842,23 @@ (defun emit-relative-fixup (segment fixup) (note-fixup segment :relative fixup) (emit-dword segment (or (fixup-offset fixup) 0))) + ;;;; the effective-address (ea) structure (defun reg-tn-encoding (tn) (declare (type tn tn)) - (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (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 - (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 @@ -730,13 +898,55 @@ (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))) - (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. @@ -749,15 +959,10 @@ (emit-dword segment disp))))) (constant (unless allow-constants + ;; Why? (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)) @@ -797,9 +1002,13 @@ (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) @@ -864,7 +1073,6 @@ (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))) @@ -872,6 +1080,7 @@ (defun accumulator-p (thing) (and (register-p thing) (= (tn-offset thing) 0))) + ;;;; utilities @@ -884,23 +1093,32 @@ (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))) - (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))))) -(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 - (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) - (eql (sb-name (sc-sb (tn-sc ea))) - 'registers)) + (member (sb-name (sc-sb (tn-sc ea))) + '(float-registers registers))) 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)) + (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))) @@ -964,13 +1189,17 @@ ;; 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))) + (:printer rex-reg-reg/mem-dir ((op #b100010))) ;; 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))) @@ -984,14 +1213,6 @@ #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 @@ -999,10 +1220,6 @@ #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 @@ -1021,6 +1238,15 @@ (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) @@ -1044,12 +1270,14 @@ (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 - (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))) @@ -1080,14 +1308,16 @@ ;;; 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))) + (:printer rex-reg-no-width ((op #b01010))) ;; 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)) @@ -1105,10 +1335,6 @@ ;; 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))) @@ -1127,7 +1353,9 @@ (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 rex-reg/mem ((op '(#b10001111 #b000)))) (: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)) - (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) + (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) @@ -1173,10 +1404,12 @@ (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 - (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)))) @@ -1279,7 +1512,8 @@ (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) @@ -1312,10 +1546,15 @@ (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)))) + (rex-reg/mem-imm ((op (#b10000001 ,subop)))) (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) @@ -1339,7 +1578,10 @@ (: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 + ;; (:printer rex-reg/mem ((op '(#b11111111 #b001)))) (:printer reg/mem ((op '(#b1111111 #b000)))) (:emitter (let ((size (operand-size dst))) @@ -1354,13 +1596,14 @@ (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) - (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) @@ -1376,26 +1619,6 @@ (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 @@ -1471,19 +1694,6 @@ (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 @@ -1511,7 +1721,6 @@ ;;; 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))) @@ -1550,9 +1759,15 @@ (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)) + (rex-reg/mem ((op (#b1101001 ,subop))) + (:name :tab reg/mem ", " 'cl)) (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) @@ -1638,13 +1853,17 @@ (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 rex-reg/mem-imm ((op '(#b11110111 #b000)))) (: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) + (maybe-emit-rex-for-ea segment something nil) (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))) + (:printer rex-string-op ((op #b1010011))) (: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))) + (:printer rex-string-op ((op #b0110110))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1710,6 +1931,7 @@ (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)) @@ -1719,6 +1941,7 @@ (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) @@ -1726,6 +1949,7 @@ (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)) @@ -1735,6 +1959,7 @@ (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)) @@ -1744,6 +1969,7 @@ (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)) @@ -1853,6 +2079,7 @@ (:emitter (typecase where (label + (maybe-emit-rex-for-ea segment where nil) (emit-byte segment #b11101000) ; 32 bit relative (emit-back-patch segment 4 @@ -1861,9 +2088,11 @@ (- (label-position where) (+ posn 4)))))) (fixup + (maybe-emit-rex-for-ea segment where nil) (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))))) @@ -1925,6 +2154,7 @@ (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))))) @@ -2860,4 +3090,286 @@ (: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 --- 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-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))) @@ -58,9 +60,10 @@ (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))))) @@ -150,10 +153,65 @@ ;;; 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) - (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)) @@ -167,7 +225,7 @@ (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)) ;;;; error code diff --git a/src/compiler/x86-64/memory.lisp b/src/compiler/x86-64/memory.lisp index ca8c2e2..bd529b2 100644 --- 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))) + (:temporary (:sc unsigned-reg) temp) (: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)))) diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp index 856c7fe..7e750fb 100644 --- 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) - 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-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) @@ -44,7 +44,7 @@ (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)) @@ -52,7 +52,7 @@ (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)) @@ -67,6 +67,7 @@ (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 @@ -77,19 +78,13 @@ (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) - base-char-widetag))))) - (move y x)))) + character-widetag))))) + (move y x)))) (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) +(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. ;;; @@ -124,16 +135,12 @@ ((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) - base-char-widetag))))) + character-widetag))))) (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) - base-char-widetag) + character-widetag) 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) - base-char-widetag) + character-widetag) 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. -;;; -;;; 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)) @@ -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. - (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) diff --git a/src/compiler/x86-64/nlx.lisp b/src/compiler/x86-64/nlx.lisp index 57e7748..f177bb2 100644 --- 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) - (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 @@ -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) - (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) @@ -211,7 +211,7 @@ ;; Copy them down. (inst std) (inst rep) - (inst movs :dword) + (inst movs :qword) 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 --- a/src/compiler/x86-64/parms.lisp +++ b/src/compiler/x86-64/parms.lisp @@ -99,18 +99,21 @@ ;;;; 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) ;;;; other miscellaneous constants @@ -169,6 +172,7 @@ 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 diff --git a/src/compiler/x86-64/pred.lisp b/src/compiler/x86-64/pred.lisp index 6babdd8..01d1d9a 100644 --- 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))))) + (:temporary (:sc descriptor-reg) temp) (: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 - (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) - 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))) @@ -58,12 +65,18 @@ (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) - base-char-widetag)))))) + character-widetag)))))) (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 --- 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) + (:temporary (:sc signed-reg) temp) (: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 - (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 - (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-) diff --git a/src/compiler/x86-64/show.lisp b/src/compiler/x86-64/show.lisp index bc475e4..f0e0201 100644 --- a/src/compiler/x86-64/show.lisp +++ b/src/compiler/x86-64/show.lisp @@ -22,11 +22,16 @@ :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)) - (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))) diff --git a/src/compiler/x86-64/static-fn.lisp b/src/compiler/x86-64/static-fn.lisp index 1842dff..20e808e 100644 --- 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) + (:temporary (:sc unsigned-reg) call-target) (: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?) - (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)) diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp index c9f111d..994ce44 100644 --- 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) - (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))) @@ -142,7 +142,7 @@ (: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)))))) diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index dfd41ca..46d6bc2 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/src/compiler/x86-64/type-vops.lisp @@ -13,26 +13,24 @@ ;;;; 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))) - (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))) - 7)) + sb!vm::fixnum-tag-mask)) (t - (inst test value 7))))) + (inst test value sb!vm::fixnum-tag-mask))))) (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. - (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)) -(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 - &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. @@ -76,7 +67,7 @@ (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)) @@ -177,49 +168,151 @@ (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)) - (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) - (:generator 45 + (:generator 8 (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) - (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) - (: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)) - (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) - (: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) - (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)))) + +;;; 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)))) ;;;; list/symbol types ;;; diff --git a/src/compiler/x86-64/values.lisp b/src/compiler/x86-64/values.lisp index e833d7b..3250a4e 100644 --- a/src/compiler/x86-64/values.lisp +++ b/src/compiler/x86-64/values.lisp @@ -16,6 +16,35 @@ (: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. diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp index 341f7eb..fd8b94b 100644 --- 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) - (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 *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")) @@ -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. - (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) @@ -102,24 +116,24 @@ 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 ;; @@ -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))) - (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)) ;;;; SB definitions @@ -140,7 +155,7 @@ ;;; 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) @@ -191,6 +206,9 @@ ;; non-immediate constants in the constant pool (constant constant) + (fp-single-zero immediate-constant) + (fp-double-zero 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) - (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) @@ -246,12 +264,14 @@ :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 - :alternate-scs (base-char-stack)) + :alternate-scs (character-stack)) ;; 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 - (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 - (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)) - (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)) - (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 () @@ -324,12 +344,14 @@ (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 - 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... ;;; @@ -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) - (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 - 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* @@ -436,7 +459,7 @@ (svref name-vec offset)) ;; FIXME: Shouldn't this be an ERROR? (format nil "" 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") @@ -446,14 +469,27 @@ ;;; The loader uses this to convert alien names to the form they need in ;;; the symbol table (for example, prepending an underscore). + +;;; 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) - (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)))) - (hi (ash (- value lo) -32))) + (hi (ash value -32))) (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 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -503,122 +503,7 @@ (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 @@ -925,173 +810,7 @@ (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)))) ;;; 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 -(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) @@ -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)) -#!+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 @@ -1605,27 +1309,7 @@ (: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. diff --git a/src/runtime/Config.x86_64-linux b/src/runtime/Config.x86_64-linux index 7fefc14..f78a14d 100644 --- 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. -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 --- a/src/runtime/backtrace.c +++ b/src/runtime/backtrace.c @@ -28,7 +28,7 @@ #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. */ diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c index 63383f5..1227d43 100644 --- a/src/runtime/cheneygc.c +++ b/src/runtime/cheneygc.c @@ -90,19 +90,19 @@ zero_stack(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 copy_large_unboxed_object(lispobj object, int nwords) { +lispobj copy_large_unboxed_object(lispobj object, long 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); } -lispobj copy_large_object(lispobj object, int nwords) { +lispobj copy_large_object(lispobj object, long nwords) { return copy_object(object,nwords); } @@ -495,47 +495,9 @@ print_garbage(lispobj *from_space, lispobj *from_space_free_pointer) } -/* 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 - - - /* vector-like objects */ -static int +static long 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) -static int +static long 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 --- 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/static-symbols.h" #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 --- 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; } -int (*scavtab[256])(lispobj *where, lispobj object); +long (*scavtab[256])(lispobj *where, 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; @@ -95,7 +95,7 @@ unsigned long bytes_consed_between_gcs = 12*1024*1024; /* to copy a boxed object */ lispobj -copy_object(lispobj object, int nwords) +copy_object(lispobj object, long nwords) { int tag; lispobj *new; @@ -115,7 +115,7 @@ copy_object(lispobj object, int nwords) 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 @@ -125,8 +125,9 @@ scavenge(lispobj *start, long n_words) { lispobj *end = start + n_words; lispobj *object_ptr; - int n_words_scavenged; + long n_words_scavenged; for (object_ptr = start; + 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 int +static long 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; - int nheader_words, ncode_words, nwords; + long nheader_words, ncode_words, nwords; unsigned long displacement; lispobj fheaderl, *prev_pointer; @@ -301,7 +302,7 @@ trans_code(struct code *code) /* 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; @@ -311,19 +312,19 @@ trans_code(struct code *code) 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; } -static int +static long 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 */ @@ -365,11 +366,11 @@ trans_code_header(lispobj object) } -static int +static long size_code_header(lispobj *where) { struct code *code; - int nheader_words, ncode_words, nwords; + long nheader_words, ncode_words, nwords; code = (struct code *) where; @@ -381,8 +382,8 @@ size_code_header(lispobj *where) 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", @@ -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. */ -#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; @@ -436,8 +437,8 @@ scav_closure_header(lispobj *where, lispobj object) } #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", @@ -470,7 +471,7 @@ trans_fun_header(lispobj object) * instances */ -static int +static long 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 int +static long scav_list_pointer(lispobj *where, lispobj object) { lispobj first, *first_pointer; @@ -580,7 +581,7 @@ trans_list(lispobj object) * scavenging and transporting other pointers */ -static int +static long 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 */ -static int +static long size_pointer(lispobj *where) { return 1; } -static int +static long 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 */ } -static int +static long size_immediate(lispobj *where) { return 1; } -static int +static long 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; @@ -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 -static int +static long scav_fdefn(lispobj *where, lispobj object) { struct fdefn *fdefn; @@ -702,7 +703,7 @@ scav_fdefn(lispobj *where, lispobj object) } #endif -static int +static long scav_unboxed(lispobj *where, lispobj object) { unsigned long length; @@ -729,7 +730,7 @@ trans_unboxed(lispobj object) return copy_unboxed_object(object, length); } -static int +static long size_unboxed(lispobj *where) { lispobj header; @@ -742,13 +743,13 @@ size_unboxed(lispobj *where) return length; } -static int + /* vector-like objects */ - +static long 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. */ @@ -763,7 +764,7 @@ static lispobj trans_base_string(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -778,11 +779,11 @@ trans_base_string(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int -size_character_string(lispobj *where) +static long +size_base_string(lispobj *where) { 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 @@ -790,11 +791,12 @@ size_character_string(lispobj *where) 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; } +static long 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); } -static int -size_base_string(lispobj *where) +static long +size_character_string(lispobj *where) { 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; - nwords = CEILING(NWORDS(length, 8) + 2, 2); + nwords = CEILING(NWORDS(length, 32) + 2, 2); return nwords; } @@ -849,7 +851,7 @@ static lispobj trans_vector(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -861,11 +863,11 @@ trans_vector(lispobj object) return copy_large_object(object, nwords); } -static int +static long size_vector(lispobj *where) { struct vector *vector; - int length, nwords; + long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); @@ -874,7 +876,7 @@ size_vector(lispobj *where) return nwords; } -static int +static long scav_vector_nil(lispobj *where, lispobj object) { return 2; @@ -887,18 +889,18 @@ trans_vector_nil(lispobj object) 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; } -static int +static long 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); @@ -911,7 +913,7 @@ static lispobj trans_vector_bit(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -922,11 +924,11 @@ trans_vector_bit(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long size_vector_bit(lispobj *where) { struct vector *vector; - int length, nwords; + long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); @@ -935,11 +937,11 @@ size_vector_bit(lispobj *where) return nwords; } -static int +static long 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); @@ -952,7 +954,7 @@ static lispobj trans_vector_unsigned_byte_2(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -963,11 +965,11 @@ trans_vector_unsigned_byte_2(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -976,11 +978,11 @@ size_vector_unsigned_byte_2(lispobj *where) return nwords; } -static int +static long 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); @@ -993,7 +995,7 @@ static lispobj trans_vector_unsigned_byte_4(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1003,11 +1005,11 @@ trans_vector_unsigned_byte_4(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -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; - int length, nwords; + long length, nwords; 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; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1049,11 +1051,11 @@ trans_vector_unsigned_byte_8(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -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; - int length, nwords; + long length, nwords; 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; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1091,11 +1093,11 @@ trans_vector_unsigned_byte_16(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1104,11 +1106,11 @@ size_vector_unsigned_byte_16(lispobj *where) return nwords; } -static int +static long 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); @@ -1121,7 +1123,7 @@ static lispobj trans_vector_unsigned_byte_32(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1132,11 +1134,11 @@ trans_vector_unsigned_byte_32(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1146,11 +1148,11 @@ size_vector_unsigned_byte_32(lispobj *where) } #if N_WORD_BITS == 64 -static int +static long 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); @@ -1163,7 +1165,7 @@ static lispobj trans_vector_unsigned_byte_64(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1174,11 +1176,11 @@ trans_vector_unsigned_byte_64(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1188,11 +1190,11 @@ size_vector_unsigned_byte_64(lispobj *where) } #endif -static int +static long 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); @@ -1205,7 +1207,7 @@ static lispobj trans_vector_single_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1216,11 +1218,11 @@ trans_vector_single_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long size_vector_single_float(lispobj *where) { struct vector *vector; - int length, nwords; + long length, nwords; vector = (struct vector *) where; length = fixnum_value(vector->length); @@ -1229,11 +1231,11 @@ size_vector_single_float(lispobj *where) return nwords; } -static int +static long 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); @@ -1246,7 +1248,7 @@ static lispobj trans_vector_double_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1257,11 +1259,11 @@ trans_vector_double_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long size_vector_double_float(lispobj *where) { struct vector *vector; - int length, nwords; + long length, nwords; 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 -static int +static long 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); @@ -1289,7 +1291,7 @@ static lispobj trans_vector_long_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1300,11 +1302,11 @@ trans_vector_long_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long size_vector_long_float(lispobj *where) { struct vector *vector; - int length, nwords; + long length, nwords; 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 -static int +static long 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); @@ -1333,7 +1335,7 @@ static lispobj trans_vector_complex_single_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1344,11 +1346,11 @@ trans_vector_complex_single_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1359,11 +1361,11 @@ size_vector_complex_single_float(lispobj *where) #endif #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG -static int +static long 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); @@ -1376,7 +1378,7 @@ static lispobj trans_vector_complex_double_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1387,11 +1389,11 @@ trans_vector_complex_double_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1403,11 +1405,11 @@ size_vector_complex_double_float(lispobj *where) #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG -static int +static long 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); @@ -1420,7 +1422,7 @@ static lispobj trans_vector_complex_long_float(lispobj object) { struct vector *vector; - int length, nwords; + long length, nwords; gc_assert(is_lisp_pointer(object)); @@ -1431,11 +1433,11 @@ trans_vector_complex_long_float(lispobj object) return copy_large_unboxed_object(object, nwords); } -static int +static long 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); @@ -1476,7 +1478,7 @@ trans_weak_pointer(lispobj object) return copy; } -static int +static long size_weak_pointer(lispobj *where) { return WEAK_POINTER_NWORDS; @@ -1518,7 +1520,7 @@ void scan_weak_pointers(void) * initialization */ -static int +static long 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 */ } -static int +static long 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) { - int i; + long i; /* 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 -#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 diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index 114f514..c5bb423 100644 --- 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))) -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) { - 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; } @@ -48,6 +48,17 @@ NWORDS(unsigned int x, unsigned int n_bits) } /* 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 */ @@ -60,21 +71,21 @@ NWORDS(unsigned int x, unsigned int n_bits) #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 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); -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); diff --git a/src/runtime/gencgc-alloc-region.h b/src/runtime/gencgc-alloc-region.h index 8e9dbed..da881b4 100644 --- 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. */ - 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; -extern int from_space, new_space; +extern long from_space, new_space; 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 --- a/src/runtime/gencgc-internal.h +++ b/src/runtime/gencgc-internal.h @@ -29,8 +29,8 @@ 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 *); 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). */ - 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 */ - int first_object_offset; + long first_object_offset; }; /* 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); -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); @@ -102,12 +102,12 @@ void gc_set_region_empty(struct alloc_region *region); * 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 = - ((unsigned int)page_index)/PAGE_BYTES) < NUM_PAGES) + ((unsigned long)page_index)/PAGE_BYTES) < NUM_PAGES) && (page_table[page_index].gen == space)); } diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index c6009cc..f7f45a7 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -49,7 +49,7 @@ 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 *); @@ -141,8 +141,8 @@ unsigned long auto_gc_trigger = 0; /* 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. @@ -154,23 +154,28 @@ struct page page_table[NUM_PAGES]; * 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 * -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. */ -inline int +inline long find_page_index(void *addr) { - int index = addr-heap_base; + long index = addr-heap_base; if (index >= 0) { - index = ((unsigned int)index)/PAGE_BYTES; + index = ((unsigned long)index)/PAGE_BYTES; 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 */ - int alloc_start_page; + long alloc_start_page; /* 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.) */ - 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.) */ - int alloc_large_unboxed_start_page; + long alloc_large_unboxed_start_page; /* the bytes allocated to this generation */ - int bytes_allocated; + long bytes_allocated; /* the number of bytes at which to trigger a GC */ - int gc_trigger; + long 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; @@ -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. */ - 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 @@ -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. */ -static int last_free_page; +static long last_free_page; /* 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. */ -static int +static long 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) @@ -285,11 +290,11 @@ count_write_protect_generation_pages(int generation) } /* Count the number of pages within the given generation. */ -static int +static long 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) @@ -299,11 +304,11 @@ count_generation_pages(int generation) } #ifdef QSHOW -static int +static long 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; @@ -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. */ -static int +static long 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; @@ -495,12 +500,12 @@ static int gc_alloc_generation; * 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, @@ -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)); - 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; @@ -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) { - 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 @@ -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; -static int new_areas_ignore_page; +static long new_areas_ignore_page; struct new_area { - int page; - int offset; - int size; + long page; + long offset; + long size; }; 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_new_area(int first_page, int offset, int size) +add_new_area(long first_page, long offset, long size) { unsigned new_area_start,c; - int i; + long i; /* 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) { - 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; @@ -711,7 +716,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region) 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; @@ -820,21 +825,21 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *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 * -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 = @@ -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)); } -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 @@ -1024,7 +1029,7 @@ gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed) * 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; @@ -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; + /* 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; @@ -1066,7 +1074,7 @@ gc_alloc_with_region(int nbytes,int unboxed_p, struct alloc_region *my_region, * 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; @@ -1074,31 +1082,31 @@ gc_general_alloc(int nbytes,int unboxed_p,int quick_p) } 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 * -gc_quick_alloc_large(int nbytes) +gc_quick_alloc_large(long nbytes) { 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 * -gc_quick_alloc_unboxed(int nbytes) +gc_quick_alloc_unboxed(long nbytes) { 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); } @@ -1107,9 +1115,9 @@ gc_quick_alloc_large_unboxed(int nbytes) * 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 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 @@ -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 -copy_large_object(lispobj object, int nwords) +copy_large_object(lispobj object, long nwords) { int tag; lispobj *new; - int first_page; + long first_page; 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. */ - 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 @@ -1208,8 +1216,9 @@ copy_large_object(lispobj object, int nwords) 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. */ @@ -1232,9 +1241,9 @@ copy_large_object(lispobj object, int nwords) /* 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)); @@ -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 -copy_large_unboxed_object(lispobj object, int nwords) +copy_large_unboxed_object(lispobj object, long nwords) { int tag; lispobj *new; - int first_page; + long first_page; 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. */ - 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); @@ -1397,7 +1406,7 @@ static lispobj trans_boxed(lispobj object); 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; @@ -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) { - 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; @@ -1624,12 +1633,11 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) /*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. */ - 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. */ @@ -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; } + } else { + fprintf(stderr, "widetag of fixup vector is %d\n", widetag_of(fixups_vector->header)); } /* Check for possible errors. */ @@ -1703,14 +1713,14 @@ int gencgc_hash = 1; static int scav_vector(lispobj *where, lispobj object) { - unsigned int kv_length; + unsigned long kv_length; 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; - 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; @@ -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)) == - 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));*/ - 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); @@ -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)) == - 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));*/ - 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); @@ -1810,11 +1820,11 @@ scav_vector(lispobj *where, lispobj object) 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));*/ - 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; @@ -1831,10 +1841,15 @@ scav_vector(lispobj *where, lispobj object) /* Work through the KV vector. */ { - int i; + long 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); @@ -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]; - 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))) { - /*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) { - /*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) { @@ -1871,7 +1890,7 @@ scav_vector(lispobj *where, lispobj object) /*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]; @@ -1909,7 +1928,7 @@ scav_vector(lispobj *where, lispobj object) #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; @@ -1973,7 +1992,7 @@ search_static_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. */ @@ -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: +#ifdef 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: +#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 @@ -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_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 @@ -2237,13 +2273,13 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer) 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; @@ -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: +#ifdef 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: +#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 @@ -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_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 @@ -2399,9 +2452,9 @@ maybe_adjust_large_object(lispobj *where) 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. */ @@ -2526,13 +2579,13 @@ preserve_pointer(void *addr) * * 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 j; + long j; 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); @@ -2549,7 +2602,7 @@ update_page_write_prot(int page) 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) @@ -2618,7 +2671,7 @@ update_page_write_prot(int page) static void scavenge_generation(int generation) { - int i; + long i; 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)) { - int last_page,j; + long last_page,j; int write_protected=1; /* This should be the start of a region */ @@ -2651,8 +2704,9 @@ scavenge_generation(int generation) 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. */ @@ -2722,7 +2776,7 @@ static struct new_area new_areas_2[NUM_NEW_AREAS]; static void scavenge_newspace_generation_one_scan(int generation) { - int i; + long i; 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))) { - int last_page; + long last_page; 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) { - int size; + long size; 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) + @@ -2790,15 +2844,15 @@ scavenge_newspace_generation_one_scan(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; - 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; - int previous_new_areas_index; + long previous_new_areas_index; /* 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++) { - 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); } @@ -2916,7 +2970,7 @@ scavenge_newspace_generation(int generation) 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) @@ -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. */ -static int +static long free_oldspace(void) { - int bytes_freed = 0; - int first_page, last_page; + long bytes_freed = 0; + long first_page, last_page; first_page = 0; @@ -3004,9 +3058,9 @@ free_oldspace(void) 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)); } @@ -3024,11 +3078,11 @@ static void 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", - (unsigned int) addr, + (unsigned long) addr, pi1, page_table[pi1].allocated, page_table[pi1].gen, @@ -3048,7 +3102,7 @@ print_ptr(lispobj *addr) } #endif -extern int undefined_tramp; +extern long undefined_tramp; 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)) { - 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)); - int to_static_space = + long to_static_space = (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; - int nheader_words, ncode_words, nwords; + long nheader_words, ncode_words, nwords; 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: +#ifdef 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: +#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 @@ -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_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 @@ -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. */ - int read_only_space_size = + long read_only_space_size = (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) { - 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); @@ -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)) { - int last_page; + long last_page; 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 - + (last_page-i)*PAGE_BYTES)/4); + + (last_page-i)*PAGE_BYTES)/N_WORD_BYTES); i = last_page; } } @@ -3332,26 +3403,26 @@ verify_generation(int generation) 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. */ - 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 { - int free_bytes = PAGE_BYTES - page_table[page].bytes_used; + long free_bytes = PAGE_BYTES - page_table[page].bytes_used; 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); - 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); @@ -3375,7 +3446,7 @@ gencgc_verify_zero_fill(void) static void verify_dynamic_space(void) { - int i; + long 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) { - int i; + long i; 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. */ - 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; @@ -3488,7 +3560,7 @@ garbage_collect_generation(int generation, int raise) 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 { @@ -3515,7 +3587,7 @@ garbage_collect_generation(int generation, int raise) #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, @@ -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. */ { - 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); @@ -3671,13 +3743,13 @@ garbage_collect_generation(int generation, int raise) } /* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */ -int +long 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; @@ -3704,7 +3776,7 @@ collect_garbage(unsigned last_gen) int gen = 0; int raise; int gen_to_wp; - int i; + long i; FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen)); @@ -3822,7 +3894,7 @@ collect_garbage(unsigned last_gen) void gc_free_heap(void) { - int page; + long page; 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. */ - 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); - 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); @@ -3905,7 +3977,7 @@ gc_free_heap(void) void gc_init(void) { - int i; + long i; gc_init_tables(); scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector; @@ -3961,8 +4033,8 @@ gc_init(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 { @@ -4007,7 +4079,7 @@ gc_initialize_pointers(void) * 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= @@ -4018,10 +4090,11 @@ alloc(int nbytes) #endif void *new_obj; void *new_free_pointer; - + gc_assert(nbytes>0); /* 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, @@ -4039,6 +4112,7 @@ alloc(int nbytes) #else gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th)); #endif +#endif /* 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 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", diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 0067a10..8a5a20f 100644 --- 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) { -#ifndef LISP_FEATURE_X86 +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK 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(); -#ifndef LISP_FEATURE_X86 +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) 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; } -#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 @@ -440,7 +440,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *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 { @@ -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 ( -#ifndef LISP_FEATURE_X86 +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) (!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 +#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 */ diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c index 2c91308..dd7808d 100644 --- 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); -#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 -#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); -#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 @@ -393,7 +393,7 @@ catchers_cmd(char **ptr) 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), diff --git a/src/runtime/parse.c b/src/runtime/parse.c index f6c6360..fd89930 100644 --- 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; -#if !defined(LISP_FEATURE_X86) +#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)) 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 --- 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 *pscav(lispobj *addr, int nwords, boolean constant); +static lispobj *pscav(lispobj *addr, long nwords, boolean constant); #define LATERBLOCKSIZE 1020 #define LATERMAXCOUNT 10 @@ -76,10 +76,16 @@ later { struct later *next; union { lispobj *ptr; - int count; + long count; } 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 */ @@ -115,7 +121,7 @@ dynamic_pointer_p(lispobj ptr) } static inline lispobj * -newspace_alloc(int nwords, int constantp) +newspace_alloc(long nwords, int constantp) { lispobj *ret; nwords=CEILING(nwords,2); @@ -131,7 +137,7 @@ newspace_alloc(int nwords, int constantp) -#ifdef LISP_FEATURE_X86 +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) #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: - if ((int)pointer != ((int)start_addr+FUN_POINTER_LOWTAG)) { + if ((long)pointer != ((long)start_addr+FUN_POINTER_LOWTAG)) { 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) { - 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: - if ((int)pointer != ((int)start_addr+LIST_POINTER_LOWTAG)) { + if ((long)pointer != ((long)start_addr+LIST_POINTER_LOWTAG)) { 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? */ @@ -208,40 +215,40 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) 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: - if ((int)pointer != ((int)start_addr+INSTANCE_POINTER_LOWTAG)) { + if ((long)pointer != ((long)start_addr+INSTANCE_POINTER_LOWTAG)) { 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) { - 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: - if ((int)pointer != ((int)start_addr+OTHER_POINTER_LOWTAG)) { + if ((long)pointer != ((long)start_addr+OTHER_POINTER_LOWTAG)) { 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) { - 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; } @@ -249,8 +256,8 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) 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; @@ -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) { - 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) { - 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; @@ -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: +#ifdef 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: +#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 @@ -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_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 @@ -349,16 +373,16 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) 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) { - 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; } @@ -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]; -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]; -unsigned int num_valid_stack_ra_locations; +unsigned long num_valid_stack_ra_locations; /* 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++] = - (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); @@ -421,7 +445,7 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base) 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); @@ -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], - (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] = - ((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 @@ -446,7 +470,7 @@ pscav_i386_stack(void) static void -pscav_later(lispobj *where, int count) +pscav_later(lispobj *where, long count) { struct later *new; @@ -477,10 +501,10 @@ pscav_later(lispobj *where, int count) static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant) { - int nwords; + long nwords; lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* 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. */ - int nwords; + long nwords; lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* 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) { - int nwords; + long nwords; 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); @@ -580,10 +604,10 @@ ptrans_fdefn(lispobj thing, lispobj header) static lispobj ptrans_unboxed(lispobj thing, lispobj header) { - int nwords; + long nwords; lispobj result, *new, *old; - nwords = 1 + HeaderValue(header); + nwords = CEILING(1 + HeaderValue(header), 2); /* Allocate it */ old = (lispobj *)native_pointer(thing); @@ -600,15 +624,22 @@ ptrans_unboxed(lispobj thing, lispobj header) } 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; - int nwords; + long nwords; lispobj result, *new; + long length; 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)); @@ -622,11 +653,11 @@ ptrans_vector(lispobj thing, int bits, int extra, 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) { - 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; @@ -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; - 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. */ @@ -668,12 +699,11 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code) (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. */ - int length = fixnum_value(fixups_vector->length); - int i; + long length = fixnum_value(fixups_vector->length); + long i; for (i=0; idata[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) - && (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; @@ -710,17 +740,18 @@ static lispobj ptrans_code(lispobj thing) { struct code *code, *new; - int nwords; + long nwords; 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)); -#ifdef LISP_FEATURE_X86 +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) 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)); -#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); -#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 @@ -784,7 +815,7 @@ ptrans_code(lispobj thing) static lispobj ptrans_func(lispobj thing, lispobj header) { - int nwords; + long nwords; 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. */ - 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 @@ -862,7 +893,7 @@ static lispobj ptrans_list(lispobj thing, boolean constant) { struct cons *old, *new, *orig; - int length; + long length; 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, 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); @@ -982,6 +1013,25 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean 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); @@ -1028,13 +1078,14 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) 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; } } -static int +static long pscav_fdefn(struct fdefn *fdefn) { boolean fix_func; @@ -1047,14 +1098,15 @@ pscav_fdefn(struct fdefn *fdefn) 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 */ -static int +static long pscav_code(struct code*code) { - int nwords; + long nwords; 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); @@ -1070,14 +1122,14 @@ pscav_code(struct code*code) 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); -#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 @@ -1089,10 +1141,10 @@ pscav_code(struct code*code) #endif static lispobj * -pscav(lispobj *addr, int nwords, boolean constant) +pscav(lispobj *addr, long nwords, boolean constant) { 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) { @@ -1134,7 +1186,7 @@ pscav(lispobj *addr, int nwords, boolean constant) } 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)) { @@ -1146,7 +1198,7 @@ pscav(lispobj *addr, int nwords, boolean constant) #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: @@ -1154,7 +1206,7 @@ pscav(lispobj *addr, int nwords, boolean constant) *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG; } - count = 1; + count = 2; 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; - 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: @@ -1244,7 +1297,8 @@ pscav(lispobj *addr, int nwords, boolean constant) 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 @@ -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; - count = fixnum_value(vector->length)*4+2; + count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2, + 2); break; #endif @@ -1279,7 +1334,7 @@ pscav(lispobj *addr, int nwords, boolean constant) #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); @@ -1293,7 +1348,7 @@ pscav(lispobj *addr, int nwords, boolean constant) 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 @@ -1342,7 +1397,7 @@ int purify(lispobj static_roots, lispobj read_only_roots) { lispobj *clean; - int count, i; + long count, i; struct later *laters, *next; struct thread *thread; @@ -1371,7 +1426,7 @@ purify(lispobj static_roots, lispobj read_only_roots) 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 @@ -1386,7 +1441,7 @@ purify(lispobj static_roots, lispobj read_only_roots) 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 */ @@ -1410,7 +1465,7 @@ purify(lispobj static_roots, lispobj read_only_roots) 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, @@ -1425,7 +1480,7 @@ purify(lispobj static_roots, lispobj read_only_roots) 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, @@ -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. */ -#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 - diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index c6e8a6e..69560b8 100644 --- 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 */ -#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; -#endif /* 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 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -30,6 +30,12 @@ #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) { @@ -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"}; - putw(id, file); + write_lispobj(id, file); words = end - addr; - putw(words, file); + write_lispobj(words, file); 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); - 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 @@ -115,14 +121,14 @@ save(char *filename, lispobj init_function) 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), @@ -130,11 +136,11 @@ save(char *filename, lispobj init_function) { 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, @@ -162,11 +168,11 @@ save(char *filename, lispobj init_function) (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"); diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 8662682..2a174d6 100644 --- 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 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); @@ -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 - + ALIEN_STACK_SIZE-4); /* naked 4. FIXME */ + + ALIEN_STACK_SIZE-N_WORD_BYTES); #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 @@ -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); -#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); diff --git a/src/runtime/thread.h b/src/runtime/thread.h index a4318fe..2ff59e6 100644 --- 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 -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 @@ -56,7 +56,7 @@ static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) { #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 @@ -67,7 +67,7 @@ static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) { #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 @@ -82,7 +82,7 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t #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); diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c new file mode 100644 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 + +#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) +{} + +/* + * 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 + * 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 +} + +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()); +} + +/* + * 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; +} + +/* 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 +} + +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, "/\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, "\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()"); +} + +/* 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 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 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. + */ + +#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) + + +/* 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) + + + .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 + + .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) + +/* 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) + +/* + * 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): + + + .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) + +#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 + + + + .end diff --git a/src/runtime/x86-64-linux-os.c b/src/runtime/x86-64-linux-os.c new file mode 100644 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 +#include +#include +#include +#include +#include +#include + +#define __USE_GNU +#include +#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 +#include + +#include +#include +/* #include */ +#include +#include +#include +#include +#include +#include +#include +#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(offsetuc_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 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 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 --- 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) - (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)))) diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp index 137d19d..bd37acb 100644 --- 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... + #-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) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index e8f86a0..d371ea9 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -898,7 +898,7 @@ ;;;; 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*)))) diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp index b61f5e5..9521ae4 100644 --- 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)))) + #-x86-64 (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 --- 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 - (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 - :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 - :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, @@ -151,8 +151,8 @@ (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 diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp index 25bc891..66e883b 100644 --- a/tools-for-build/ldso-stubs.lisp +++ b/tools-for-build/ldso-stubs.lisp @@ -55,7 +55,7 @@ ldso_stub__~A: ; \\ #endif .text" -#!+x86 " +#!+(or x86 x86-64) " #define LDSO_STUBIFY(fct) \\ .align 16 ; \\ .globl ldso_stub__ ## fct ; \\ diff --git a/version.lisp-expr b/version.lisp-expr index 284ec4b..bdda81f 100644 --- 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".) -"0.8.18.13" +"0.8.18.14" -- 1.7.10.4