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.
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,
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
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
(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)))))
)
(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)
;;; 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)
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
;;; 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))
(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 "/")))
(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.")
(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)))))))
(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))
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 ;;
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!
"%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"
"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"
"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"
"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"
"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"
--- /dev/null
+;;;; allocating simple objects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; from signed/unsigned
+
+;;; KLUDGE: Why don't we want vops for this one and the next
+;;; one? -- WHN 19990916
+#+sb-assembling ; We don't want a vop for this one.
+(define-assembly-routine
+ (move-from-signed)
+ ((:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset))
+ (inst mov ebx eax)
+ (inst shl ebx 1)
+ (inst jmp :o bignum)
+ (inst shl ebx 1)
+ (inst jmp :o bignum)
+ (inst shl ebx 1)
+ (inst jmp :o bignum)
+ (inst ret)
+ BIGNUM
+
+ (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1))
+ (storew eax ebx bignum-digits-offset other-pointer-lowtag))
+
+ (inst ret))
+
+#+sb-assembling ; We don't want a vop for this one either.
+(define-assembly-routine
+ (move-from-unsigned)
+ ((:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset))
+
+ (inst bsr ebx eax)
+ (inst cmp ebx 61)
+ (inst jmp :z DONE)
+ (inst jmp :ge BIGNUM)
+ ;; Fixnum
+ (inst mov ebx eax)
+ (inst shl ebx 3)
+ DONE
+ (inst ret)
+
+ BIGNUM
+ (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2))
+ (storew eax ebx bignum-digits-offset other-pointer-lowtag))
+ (inst ret))
+
+
--- /dev/null
+;;;; simple cases for generic arithmetic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; addition, subtraction, and multiplication
+
+(macrolet ((define-generic-arith-routine ((fun cost) &body body)
+ `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
+ (:cost ,cost)
+ (:return-style :full-call)
+ (:translate ,fun)
+ (:policy :safe)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) rdx-offset)
+ (:arg y (descriptor-reg any-reg)
+ ;; this seems wrong esi-offset -- FIXME: What's it mean?
+ rdi-offset)
+
+ (:res res (descriptor-reg any-reg) rdx-offset)
+
+ (:temp rax unsigned-reg rax-offset)
+ (:temp rbx unsigned-reg rbx-offset)
+ (:temp rcx unsigned-reg rcx-offset))
+
+ (declare (ignorable rbx))
+
+ (inst test x 7) ; fixnum?
+ (inst jmp :nz DO-STATIC-FUN) ; no - do generic
+ (inst test y 7) ; fixnum?
+ (inst jmp :z DO-BODY) ; yes - doit here
+
+ DO-STATIC-FUN
+ (inst pop rax)
+ (inst push rbp-tn)
+ (inst lea
+ rbp-tn
+ (make-ea :qword :base rsp-tn :disp n-word-bytes))
+ (inst sub rsp-tn (fixnumize 2))
+ (inst push rax) ; callers return addr
+ (inst mov rcx (fixnumize 2)) ; arg count
+ (inst jmp
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-fun-offset
+ ',(symbolicate "TWO-ARG-" fun)))))
+
+ DO-BODY
+ ,@body)))
+
+ (define-generic-arith-routine (+ 10)
+ (move res x)
+ (inst add res y)
+ (inst jmp :no OKAY)
+ (inst rcr res 1) ; carry has correct sign
+ (inst sar res 2) ; remove type bits
+
+ (move rcx res)
+
+ (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+ (storew rcx res bignum-digits-offset other-pointer-lowtag))
+
+ OKAY)
+
+ (define-generic-arith-routine (- 10)
+ ;; FIXME: This is screwed up.
+ ;;; I can't figure out the flags on subtract. Overflow never gets
+ ;;; set and carry always does. (- 0 most-negative-fixnum) can't be
+ ;;; easily detected so just let the upper level stuff do it.
+ (inst jmp DO-STATIC-FUN)
+
+ (move res x)
+ (inst sub res y)
+ (inst jmp :no OKAY)
+ (inst rcr res 1)
+ (inst sar res 2) ; remove type bits
+
+ (move rcx res)
+
+ (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+ (storew rcx res bignum-digits-offset other-pointer-lowtag))
+ OKAY)
+
+ (define-generic-arith-routine (* 30)
+ (move rax x) ; must use eax for 64-bit result
+ (inst sar rax 3) ; remove *4 fixnum bias
+ (inst imul y) ; result in edx:eax
+ (inst jmp :no okay) ; still fixnum
+
+ ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
+ ;; pfw says that loses big -- edx is target for arg x and result res
+ ;; note that 'edx' is not defined -- using x
+ (inst shrd rax x 3) ; high bits from edx
+ (inst sar x 3) ; now shift edx too
+
+ (move rcx x) ; save high bits from cqo
+ (inst cqo) ; edx:eax <- sign-extend of eax
+ (inst cmp x rcx)
+ (inst jmp :e SINGLE-WORD-BIGNUM)
+
+ (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
+ (storew rax res bignum-digits-offset other-pointer-lowtag)
+ (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
+ (inst jmp DONE)
+
+ SINGLE-WORD-BIGNUM
+
+ (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+ (storew rax res bignum-digits-offset other-pointer-lowtag))
+ (inst jmp DONE)
+
+ OKAY
+ (move res rax)
+ DONE))
+\f
+;;;; negation
+
+(define-assembly-routine (generic-negate
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate %negate)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) rdx-offset)
+ (:res res (descriptor-reg any-reg) rdx-offset)
+
+ (:temp rax unsigned-reg rax-offset)
+ (:temp rcx unsigned-reg rcx-offset))
+ (inst test x 7)
+ (inst jmp :z FIXNUM)
+
+ (inst pop rax)
+ (inst push rbp-tn)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+ (inst sub rsp-tn (fixnumize 2))
+ (inst push rax)
+ (inst mov rcx (fixnumize 1)) ; arg count
+ (inst jmp (make-ea :qword
+ :disp (+ nil-value (static-fun-offset '%negate))))
+
+ FIXNUM
+ (move res x)
+ (inst neg res) ; (- most-negative-fixnum) is BIGNUM
+ (inst jmp :no OKAY)
+ (inst shr res 3) ; sign bit is data - remove type bits
+ (move rcx res)
+
+ (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
+ (storew rcx res bignum-digits-offset other-pointer-lowtag))
+
+ OKAY)
+\f
+;;;; comparison
+
+(macrolet ((define-cond-assem-rtn (name translate static-fn test)
+ `(define-assembly-routine (,name
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate ,translate)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) rdx-offset)
+ (:arg y (descriptor-reg any-reg) rdi-offset)
+
+ (:res res descriptor-reg rdx-offset)
+
+ (:temp eax unsigned-reg rax-offset)
+ (:temp ecx unsigned-reg rcx-offset))
+
+ ;; KLUDGE: The "3" here is a mask for the bits which will be
+ ;; zero in a fixnum. It should have a symbolic name. (Actually,
+ ;; it might already have a symbolic name which the coder
+ ;; couldn't be bothered to use..) -- WHN 19990917
+ (inst test x 7)
+ (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
+ (inst test y 7)
+ (inst jmp :z INLINE-FIXNUM-COMPARE)
+
+ TAIL-CALL-TO-STATIC-FN
+ (inst pop eax)
+ (inst push rbp-tn)
+ (inst lea rbp-tn (make-ea :qword
+ :base rsp-tn
+ :disp n-word-bytes))
+ (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
+ ; weirdly?
+ (inst push eax)
+ (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
+ ; SINGLE-FLOAT-BITS are parallel,
+ ; should be named parallelly.
+ (inst jmp (make-ea :qword
+ :disp (+ nil-value
+ (static-fun-offset ',static-fn))))
+
+ INLINE-FIXNUM-COMPARE
+ (inst cmp x y)
+ (inst jmp ,test RETURN-TRUE)
+ (inst mov res nil-value)
+ ;; FIXME: A note explaining this return convention, or a
+ ;; symbolic name for it, would be nice. (It looks as though we
+ ;; should be hand-crafting the same return sequence as would be
+ ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
+ ;; not clear why we don't just jump to the end of this function
+ ;; to share the return sequence there.
+ (inst pop eax)
+ (inst add eax 3)
+ (inst jmp eax)
+
+ RETURN-TRUE
+ (load-symbol res t))))
+
+ (define-cond-assem-rtn generic-< < two-arg-< :l)
+ (define-cond-assem-rtn generic-> > two-arg-> :g))
+
+(define-assembly-routine (generic-eql
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate eql)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) rdx-offset)
+ (:arg y (descriptor-reg any-reg) rdi-offset)
+
+ (:res res descriptor-reg rdx-offset)
+
+ (:temp eax unsigned-reg rax-offset)
+ (:temp ecx unsigned-reg rcx-offset))
+ (inst cmp x y)
+ (inst jmp :e RETURN-T)
+ (inst test x 7)
+ (inst jmp :z RETURN-NIL)
+ (inst test y 7)
+ (inst jmp :nz DO-STATIC-FN)
+
+ RETURN-NIL
+ (inst mov res nil-value)
+ (inst pop eax)
+ (inst add eax 3)
+ (inst jmp eax)
+
+ DO-STATIC-FN
+ (inst pop eax)
+ (inst push rbp-tn)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+ (inst sub rsp-tn (fixnumize 2))
+ (inst push eax)
+ (inst mov ecx (fixnumize 2))
+ (inst jmp (make-ea :qword
+ :disp (+ nil-value (static-fun-offset 'eql))))
+
+ RETURN-T
+ (load-symbol res t)
+ ;; FIXME: I don't understand how we return from here..
+ )
+
+(define-assembly-routine (generic-=
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate =)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) rdx-offset)
+ (:arg y (descriptor-reg any-reg) rdi-offset)
+
+ (:res res descriptor-reg rdx-offset)
+
+ (:temp eax unsigned-reg rax-offset)
+ (:temp ecx unsigned-reg rcx-offset)
+ )
+ (inst test x 7) ; descriptor?
+ (inst jmp :nz DO-STATIC-FN) ; yes, do it here
+ (inst test y 7) ; descriptor?
+ (inst jmp :nz DO-STATIC-FN)
+ (inst cmp x y)
+ (inst jmp :e RETURN-T) ; ok
+
+ (inst mov res nil-value)
+ (inst pop eax)
+ (inst add eax 3)
+ (inst jmp eax)
+
+ DO-STATIC-FN
+ (inst pop eax)
+ (inst push rbp-tn)
+ (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
+ (inst sub rsp-tn (fixnumize 2))
+ (inst push eax)
+ (inst mov ecx (fixnumize 2))
+ (inst jmp (make-ea :qword
+ :disp (+ nil-value (static-fun-offset 'two-arg-=))))
+
+ RETURN-T
+ (load-symbol res t))
+
+
--- /dev/null
+;;;; various array operations that are too expensive (in space) to do
+;;;; inline
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; allocation
+
+(define-assembly-routine (allocate-vector
+ (:policy :fast-safe)
+ (:translate allocate-vector)
+ (:arg-types positive-fixnum
+ positive-fixnum
+ positive-fixnum))
+ ((:arg type unsigned-reg eax-offset)
+ (:arg length any-reg ebx-offset)
+ (:arg words any-reg ecx-offset)
+ (:res result descriptor-reg edx-offset))
+ (inst mov result (+ (1- (ash 1 n-lowtag-bits))
+ (* vector-data-offset n-word-bytes)))
+ (inst add result words)
+ (inst and result (lognot lowtag-mask))
+ (pseudo-atomic
+ (allocation result result)
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+ (storew type result 0 other-pointer-lowtag)
+ (storew length result vector-length-slot other-pointer-lowtag))
+ (inst ret))
+\f
+;;;; Note: CMU CL had assembly language primitives for hashing strings,
+;;;; but SBCL doesn't.
--- /dev/null
+;;;; the machine specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; RETURN-MULTIPLE
+
+;;; For RETURN-MULTIPLE, we have to move the results from the end of
+;;; the frame for the function that is returning to the end of the
+;;; frame for the function being returned to.
+
+#+sb-assembling ;; We don't want a vop for this one.
+(define-assembly-routine
+ (return-multiple (:return-style :none))
+ (;; These four are really arguments.
+ (:temp eax unsigned-reg rax-offset)
+ (:temp ebx unsigned-reg rbx-offset)
+ (:temp ecx unsigned-reg rcx-offset)
+ (:temp esi unsigned-reg rsi-offset)
+
+ ;; These we need as temporaries.
+ (:temp edx unsigned-reg rdx-offset)
+ (:temp edi unsigned-reg rdi-offset))
+
+ ;; Pick off the cases where everything fits in register args.
+ (inst jecxz zero-values)
+ (inst cmp ecx (fixnumize 1))
+ (inst jmp :e one-value)
+ (inst cmp ecx (fixnumize 2))
+ (inst jmp :e two-values)
+ (inst cmp ecx (fixnumize 3))
+ (inst jmp :e three-values)
+
+ ;; Save the count, because the loop is going to destroy it.
+ (inst mov edx ecx)
+
+ ;; Blit the values down the stack. Note: there might be overlap, so
+ ;; we have to be careful not to clobber values before we've read
+ ;; them. Because the stack builds down, we are coping to a larger
+ ;; address. Therefore, we need to iterate from larger addresses to
+ ;; smaller addresses. pfw-this says copy ecx words from esi to edi
+ ;; counting down.
+ (inst shr ecx 3) ; fixnum to raw word count
+ (inst std) ; count down
+ (inst sub esi 8) ; ?
+ (inst lea edi (make-ea :qword :base ebx :disp (- n-word-bytes)))
+ (inst rep)
+ (inst movs :qword)
+
+ ;; Restore the count.
+ (inst mov ecx edx)
+
+ ;; Set the stack top to the last result.
+ (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes))
+
+ ;; Load the register args.
+ (loadw edx ebx -1)
+ (loadw edi ebx -2)
+ (loadw esi ebx -3)
+
+ ;; And back we go.
+ (inst jmp eax)
+
+ ;; Handle the register arg cases.
+ ZERO-VALUES
+ (move rsp-tn ebx)
+ (inst mov edx nil-value)
+ (inst mov edi edx)
+ (inst mov esi edx)
+ (inst jmp eax)
+
+ ONE-VALUE ; Note: we can get this, because the return-multiple vop
+ ; doesn't check for this case when size > speed.
+ (loadw edx esi -1)
+ (inst mov rsp-tn ebx)
+ (inst add eax 3)
+ (inst jmp eax)
+
+ TWO-VALUES
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (inst mov esi nil-value)
+ (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -2 n-word-bytes)))
+ (inst jmp eax)
+
+ THREE-VALUES
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (loadw esi esi -3)
+ (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -3 n-word-bytes)))
+ (inst jmp eax))
+\f
+;;;; TAIL-CALL-VARIABLE
+
+;;; For tail-call-variable, we have to copy the arguments from the end
+;;; of our stack frame (were args are produced) to the start of our
+;;; stack frame (were args are expected).
+;;;
+;;; We take the function to call in EAX and a pointer to the arguments in
+;;; ESI. EBP says the same over the jump, and the old frame pointer is
+;;; still saved in the first stack slot. The return-pc is saved in
+;;; the second stack slot, so we have to push it to make it look like
+;;; we actually called. We also have to compute ECX from the difference
+;;; between ESI and the stack top.
+#+sb-assembling ;; No vop for this one either.
+(define-assembly-routine
+ (tail-call-variable
+ (:return-style :none))
+
+ ((:temp eax unsigned-reg rax-offset)
+ (:temp ebx unsigned-reg rbx-offset)
+ (:temp ecx unsigned-reg rcx-offset)
+ (:temp edx unsigned-reg rdx-offset)
+ (:temp edi unsigned-reg rdi-offset)
+ (:temp esi unsigned-reg rsi-offset))
+
+ ;; Calculate NARGS (as a fixnum)
+ (move ecx esi)
+ (inst sub ecx rsp-tn)
+
+ ;; Check for all the args fitting the the registers.
+ (inst cmp ecx (fixnumize 3))
+ (inst jmp :le REGISTER-ARGS)
+
+ ;; Save the OLD-FP and RETURN-PC because the blit it going to trash
+ ;; those stack locations. Save the ECX, because the loop is going
+ ;; to trash it.
+ (pushw rbp-tn -1)
+ (loadw ebx rbp-tn -2)
+ (inst push ecx)
+
+ ;; Do the blit. Because we are coping from smaller addresses to
+ ;; larger addresses, we have to start at the largest pair and work
+ ;; our way down.
+ (inst shr ecx 3) ; fixnum to raw words
+ (inst std) ; count down
+ (inst lea edi (make-ea :qword :base rbp-tn :disp (- n-word-bytes)))
+ (inst sub esi (fixnumize 1))
+ (inst rep)
+ (inst movs :qword)
+
+ ;; Load the register arguments carefully.
+ (loadw edx rbp-tn -1)
+
+ ;; Restore OLD-FP and ECX.
+ (inst pop ecx)
+ (popw rbp-tn -1) ; overwrites a0
+
+ ;; Blow off the stack above the arguments.
+ (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes))
+
+ ;; remaining register args
+ (loadw edi rbp-tn -2)
+ (loadw esi rbp-tn -3)
+
+ ;; Push the (saved) return-pc so it looks like we just called.
+ (inst push ebx)
+
+ ;; And jump into the function.
+ (inst jmp
+ (make-ea :byte :base eax
+ :disp (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag)))
+
+ ;; All the arguments fit in registers, so load them.
+ REGISTER-ARGS
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (loadw esi esi -3)
+
+ ;; Clear most of the stack.
+ (inst lea rsp-tn
+ (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes)))
+
+ ;; Push the return-pc so it looks like we just called.
+ (pushw rbp-tn -2) ; XXX dan ?
+
+ ;; And away we go.
+ (inst jmp (make-ea :byte :base eax
+ :disp (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag))))
+\f
+(define-assembly-routine (throw
+ (:return-style :none))
+ ((:arg target (descriptor-reg any-reg) rdx-offset)
+ (:arg start any-reg rbx-offset)
+ (:arg count any-reg rcx-offset)
+ (:temp catch any-reg rax-offset))
+
+ (declare (ignore start count))
+
+ (load-tl-symbol-value catch *current-catch-block*)
+
+ LOOP
+
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst or catch catch) ; check for NULL pointer
+ (inst jmp :z error))
+
+ (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
+ (inst jmp :e exit)
+
+ (loadw catch catch catch-block-previous-catch-slot)
+ (inst jmp loop)
+
+ EXIT
+
+ ;; Here EAX points to catch block containing symbol pointed to by EDX.
+ (inst jmp (make-fixup 'unwind :assembly-routine)))
+
+;;;; non-local exit noise
+
+(define-assembly-routine (unwind
+ (:return-style :none)
+ (:translate %continue-unwind)
+ (:policy :fast-safe))
+ ((:arg block (any-reg descriptor-reg) rax-offset)
+ (:arg start (any-reg descriptor-reg) rbx-offset)
+ (:arg count (any-reg descriptor-reg) rcx-offset)
+ (:temp uwp unsigned-reg rsi-offset))
+ (declare (ignore start count))
+
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst or block block) ; check for NULL pointer
+ (inst jmp :z error))
+
+ (load-tl-symbol-value uwp *current-unwind-protect-block*)
+
+ ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in
+ ;; argument's CURRENT-UWP-SLOT?
+ (inst cmp uwp
+ (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
+ ;; If a match, return to context in arg block.
+ (inst jmp :e do-exit)
+
+ ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context.
+ ;; Important! Must save (and return) the arg 'block' for later use!!
+ (move rdx-tn block)
+ (move block uwp)
+ ;; Set next unwind protect context.
+ (loadw uwp uwp unwind-block-current-uwp-slot)
+ ;; we're about to reload ebp anyway, so let's borrow it here as a
+ ;; temporary. Hope this works
+ (store-tl-symbol-value uwp *current-unwind-protect-block* rbp-tn)
+
+ DO-EXIT
+
+ (loadw rbp-tn block unwind-block-current-cont-slot)
+
+ ;; Uwp-entry expects some things in known locations so that they can
+ ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
+ ;; count in ecx-tn.
+
+ (inst jmp (make-ea :byte :base block
+ :disp (* unwind-block-entry-pc-slot n-word-bytes))))
--- /dev/null
+;;;; 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")
--- /dev/null
+;;;; 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)))
(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
(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))
(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))
\f
;;;; CONSTANT-BIT-BASH
(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)
(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)))
'(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)))
(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)
(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)
(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
;;; 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))
(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))
(#.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))
(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))
(#.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)))
;;; 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)
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")
(+ 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")
(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))
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
(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)))
(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)
(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
(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)
(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)))))))
(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
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
(#.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)))
(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)))))
(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*)
;;;; 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
(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))
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
(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)
(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)
;;;
;;; 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
;; 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)))))))
,@(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
#+sb-xc-host (bug "READ-STRING-AS-WORDS called")
(dotimes (i length)
(setf (aref string i)
- (sb!xc:code-char (logior
- (read-byte stream)
- (ash (read-byte stream) 8)
- (ash (read-byte stream) 16)
- (ash (read-byte stream) 24)))))
+ (let ((code 0))
+ ;; FIXME: is this the same as READ-WORD-ARG?
+ (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
+ (setf code (logior code (ash (read-byte stream)
+ (* k sb!vm:n-byte-bits))))))))
(values))
\f
;;;; miscellaneous fops
;; 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
(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) (*)))))
\f
(defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
#!+sb-doc
(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))
+
;;; 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)))
(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)
(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
#+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
(%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)
#.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
(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)
(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)
;; 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)
(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)
(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))))))
(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
: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.
(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))
(* 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))
(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)
(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)
(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)
(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))
(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)
"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))))
(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
(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))))))
(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 ())
((= 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)
(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)))
(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)
(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))))
--- /dev/null
+;;;; X86-64-specific runtime stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+\f
+;;;; OS-CONTEXT-T
+
+;;; a POSIX signal context, i.e. the type passed as the third
+;;; argument to an SA_SIGACTION-style signal handler
+;;;
+;;; The real type does have slots, but at Lisp level, we never
+;;; access them, or care about the size of the object. Instead, we
+;;; always refer to these objects by pointers handed to us by the C
+;;; runtime library, and ask the runtime library any time we need
+;;; information about the contents of one of these objects. Thus, it
+;;; works to represent this as an object with no slots.
+;;;
+;;; KLUDGE: It would be nice to have a type definition analogous to
+;;; C's "struct os_context_t;", for an incompletely specified object
+;;; which can only be referred to by reference, but I don't know how
+;;; to do that in the FFI, so instead we just this bogus no-slots
+;;; representation. -- WHN 20000730
+;;;
+;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
+;;; it's no longer architecture-dependent, and probably belongs in
+;;; some other package, perhaps SB-KERNEL.
+(define-alien-type os-context-t (struct os-context-t-struct))
+\f
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+ #!+sb-doc
+ "Return a string describing the type of the local machine."
+ "X86-64")
+
+;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere
+(defun get-machine-version ()
+ #!+linux
+ (with-open-file (stream "/proc/cpuinfo"
+ ;; Even on Linux it's an option to build
+ ;; kernels without /proc filesystems, so
+ ;; degrade gracefully.
+ :if-does-not-exist nil)
+ (loop with line while (setf line (read-line stream nil))
+ ;; The field "model name" exists on kernel 2.4.21-rc6-ac1
+ ;; anyway, with values e.g.
+ ;; "AMD Athlon(TM) XP 2000+"
+ ;; "Intel(R) Pentium(R) M processor 1300MHz"
+ ;; which seem comparable to the information in the example
+ ;; in the MACHINE-VERSION page of the ANSI spec.
+ when (eql (search "model name" line) 0)
+ return (string-trim " " (subseq line (1+ (position #\: line))))))
+ #!-linux
+ nil)
+\f
+;;;; :CODE-OBJECT fixups
+
+;;; a counter to measure the storage overhead of these fixups
+(defvar *num-fixups* 0)
+;;; FIXME: When the system runs, it'd be interesting to see what this is.
+
+(declaim (inline adjust-fixup-array))
+(defun adjust-fixup-array (array size)
+ (let ((new (make-array size :element-type '(unsigned-byte 64))))
+ (replace new array)
+ new))
+
+;;; This gets called by LOAD to resolve newly positioned objects
+;;; with things (like code instructions) that have to refer to them.
+;;;
+;;; Add a fixup offset to the vector of fixup offsets for the given
+;;; code object.
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (flet ((add-fixup (code offset)
+ ;; (We check for and ignore fixups for code objects in the
+ ;; read-only and static spaces. (In the old CMU CL code
+ ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*,
+ ;; but in SBCL relocatable dynamic space code is always in
+ ;; use, so we always do the check.)
+ (incf *num-fixups*)
+ (let ((fixups (code-header-ref code code-constants-offset)))
+ (cond ((typep fixups '(simple-array (unsigned-byte 64) (*)))
+ (let ((new-fixups
+ (adjust-fixup-array fixups (1+ (length fixups)))))
+ (setf (aref new-fixups (length fixups)) offset)
+ (setf (code-header-ref code code-constants-offset)
+ new-fixups)))
+ (t
+ (unless (or (eq (widetag-of fixups)
+ unbound-marker-widetag)
+ (zerop fixups))
+ (format t "** Init. code FU = ~S~%" fixups)) ; FIXME
+ (setf (code-header-ref code code-constants-offset)
+ (make-array
+ 1
+ :element-type '(unsigned-byte 64)
+ :initial-element offset)))))))
+ (sb!sys:without-gcing
+ (let* ((sap (truly-the system-area-pointer
+ (sb!kernel:code-instructions code)))
+ (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code)
+ #xfffffffffffffff8))
+ (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+ code)))
+ (ncode-words (sb!kernel:code-header-ref code 1))
+ (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
+ (unless (member kind '(:absolute :absolute64 :relative))
+ (error "Unknown code-object-fixup kind ~S." kind))
+ (ecase kind
+ (:absolute64
+ ;; Word at sap + offset contains a value to be replaced by
+ ;; adding that value to fixup.
+ (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset)))
+ ;; Record absolute fixups that point within the code object.
+ (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr)
+ (add-fixup code offset)))
+ (:absolute
+ ;; Word at sap + offset contains a value to be replaced by
+ ;; adding that value to fixup.
+ (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
+ ;; Record absolute fixups that point within the code object.
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+ (add-fixup code offset)))
+ (:relative
+ ;; Fixup is the actual address wanted.
+ ;;
+ ;; Record relative fixups that point outside the code
+ ;; object.
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+ (add-fixup code offset))
+ ;; Replace word with value to add to that loc to get there.
+ (let* ((loc-sap (+ (sap-int sap) offset))
+ (rel-val (- fixup loc-sap (/ n-word-bytes 2))))
+ (declare (type (unsigned-byte 64) loc-sap)
+ (type (signed-byte 32) rel-val))
+ (setf (signed-sap-ref-32 sap offset) rel-val))))))
+ nil))
+
+;;; Add a code fixup to a code object generated by GENESIS. The fixup
+;;; has already been applied, it's just a matter of placing the fixup
+;;; in the code's fixup vector if necessary.
+;;;
+;;; KLUDGE: I'd like a good explanation of why this has to be done at
+;;; load time instead of in GENESIS. It's probably simple, I just haven't
+;;; figured it out, or found it written down anywhere. -- WHN 19990908
+#!+gencgc
+(defun !envector-load-time-code-fixup (code offset fixup kind)
+ (flet ((frob (code offset)
+ (let ((fixups (code-header-ref code code-constants-offset)))
+ (cond ((typep fixups '(simple-array (unsigned-byte 64) (*)))
+ (let ((new-fixups
+ (adjust-fixup-array fixups (1+ (length fixups)))))
+ (setf (aref new-fixups (length fixups)) offset)
+ (setf (code-header-ref code code-constants-offset)
+ new-fixups)))
+ (t
+ (unless (or (eq (widetag-of fixups)
+ unbound-marker-widetag)
+ (zerop fixups))
+ (sb!impl::!cold-lose "Argh! can't process fixup"))
+ (setf (code-header-ref code code-constants-offset)
+ (make-array
+ 1
+ :element-type '(unsigned-byte 64)
+ :initial-element offset)))))))
+ (let* ((sap (truly-the system-area-pointer
+ (sb!kernel:code-instructions code)))
+ (obj-start-addr
+ ;; FIXME: looks like (LOGANDC2 foo typebits)
+ (logand (sb!kernel:get-lisp-obj-address code) #xfffffffffffffff8))
+ (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+ code)))
+ (ncode-words (sb!kernel:code-header-ref code 1))
+ (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
+ (ecase kind
+ (:absolute
+ ;; Record absolute fixups that point within the code object.
+ ;; The fixup data is 32 bits, don't use SAP-REF-64 here.
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+ (frob code offset)))
+ (:relative
+ ;; Record relative fixups that point outside the code object.
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+ (frob code offset)))))))
+\f
+;;;; low-level signal context access functions
+;;;;
+;;;; Note: In CMU CL, similar functions were hardwired to access
+;;;; BSD-style sigcontext structures defined as alien objects. Our
+;;;; approach is different in two ways:
+;;;; 1. We use POSIX SA_SIGACTION-style signals, so our context is
+;;;; whatever the void pointer in the sigaction handler dereferences
+;;;; to, not necessarily a sigcontext.
+;;;; 2. We don't try to maintain alien definitions of the context
+;;;; structure at Lisp level, but instead call alien C functions
+;;;; which take care of access for us. (Since the C functions can
+;;;; be defined in terms of system standard header files, they
+;;;; should be easier to maintain; and since Lisp code uses signal
+;;;; contexts only in interactive or exception code (like the debugger
+;;;; and internal error handling) the extra runtime cost should be
+;;;; negligible.
+
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
+ ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
+ ;; 'unsigned *' interpretation for the 32-bit word passed to us by
+ ;; the C code, even though the C code may think it's an 'int *'.)
+ (context (* os-context-t)))
+
+(defun context-pc (context)
+ (declare (type (alien (* os-context-t)) context))
+ (let ((addr (context-pc-addr context)))
+ (declare (type (alien (* unsigned-long)) addr))
+ (int-sap (deref addr))))
+
+(define-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-long)
+ ;; (Note the mismatch here between the 'int *' value that the C code
+ ;; may think it's giving us and the 'unsigned *' value that we
+ ;; receive. It's intentional: the C header files may think of
+ ;; register values as signed, but the CMU CL code tends to think of
+ ;; register values as unsigned, and might get bewildered if we ask
+ ;; it to work with signed values.)
+ (context (* os-context-t))
+ (index int))
+
+(defun context-register (context index)
+ (declare (type (alien (* os-context-t)) context))
+ (let ((addr (context-register-addr context index)))
+ (declare (type (alien (* unsigned-long)) addr))
+ (deref addr)))
+
+(defun %set-context-register (context index new)
+ (declare (type (alien (* os-context-t)) context))
+ (let ((addr (context-register-addr context index)))
+ (declare (type (alien (* unsigned-long)) addr))
+ (setf (deref addr) new)))
+
+;;; This is like CONTEXT-REGISTER, but returns the value of a float
+;;; register. FORMAT is the type of float to return.
+;;;
+;;; As of sbcl-0.6.7, there is no working code which calls this code,
+;;; so it's stubbed out. Someday, in order to make the debugger work
+;;; better, it may be necessary to unstubify it.
+(defun context-float-register (context index format)
+ (declare (ignore context index))
+ (warn "stub CONTEXT-FLOAT-REGISTER")
+ (coerce 0.0 format))
+(defun %set-context-float-register (context index format new-value)
+ (declare (ignore context index))
+ (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
+ (coerce new-value format))
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+ (declare (ignore context)) ; stub!
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+ 0)
+
+\f
+;;;; INTERNAL-ERROR-ARGS
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream.
+(defun internal-error-args (context)
+ (declare (type (alien (* os-context-t)) context))
+ (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
+ (/hexstr context)
+ (let ((pc (context-pc context)))
+ (declare (type system-area-pointer pc))
+ (/show0 "got PC")
+ ;; using INT3 the pc is .. INT3 <here> code length bytes...
+ (let* ((length (sap-ref-8 pc 1))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
+ (/hexstr length)
+ (/hexstr vector)
+ (copy-from-system-area pc (* n-byte-bits 2)
+ vector (* n-word-bits vector-data-offset)
+ (* length n-byte-bits))
+ (let* ((index 0)
+ (error-number (sb!c:read-var-integer vector index)))
+ (/hexstr error-number)
+ (collect ((sc-offsets))
+ (loop
+ (/show0 "INDEX=..")
+ (/hexstr index)
+ (when (>= index length)
+ (return))
+ (let ((sc-offset (sb!c:read-var-integer vector index)))
+ (/show0 "SC-OFFSET=..")
+ (/hexstr sc-offset)
+ (sc-offsets sc-offset)))
+ (values error-number (sc-offsets)))))))
+\f
+;;; This is used in error.lisp to insure that floating-point exceptions
+;;; are properly trapped. The compiler translates this to a VOP.
+(defun float-wait ()
+ (float-wait))
+
+;;; float constants
+;;;
+;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
+;;; than the i387 load constant instructions to avoid consing in some
+;;; cases. Note these are initialized by GENESIS as they are needed
+;;; early.
+(defvar *fp-constant-0f0*)
+(defvar *fp-constant-1f0*)
+(defvar *fp-constant-0d0*)
+(defvar *fp-constant-1d0*)
+;;; the long-float constants
+(defvar *fp-constant-0l0*)
+(defvar *fp-constant-1l0*)
+(defvar *fp-constant-pi*)
+(defvar *fp-constant-l2t*)
+(defvar *fp-constant-l2e*)
+(defvar *fp-constant-lg2*)
+(defvar *fp-constant-ln2*)
+
+;;; the current alien stack pointer; saved/restored for non-local exits
+(defvar *alien-stack*)
+
+;;; Support for the MT19937 random number generator. The update
+;;; function is implemented as an assembly routine. This definition is
+;;; transformed to a call to the assembly routine allowing its use in
+;;; interpreted code.
+#+nil
+(defun random-mt19937 (state)
+ (declare (type (simple-array (unsigned-byte 32) (627)) state))
+ (random-mt19937 state))
(/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)))
(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)))
(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)
(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))
(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.")
dchunk=
dchunk-count-bits))
-(def!constant dchunk-bits 32)
+(def!constant dchunk-bits #.sb!vm:n-word-bits)
(deftype dchunk ()
`(unsigned-byte ,dchunk-bits))
`(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))
(: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)))))
: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
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))
(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
(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))
(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)
;; 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
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)
;; 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")
(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
(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
: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.
(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")
(define-primitive-object (complex-double-float
:lowtag other-pointer-lowtag
:widetag complex-double-float-widetag)
- (filler)
- (real :c-type "double" :length 2)
- (imag :c-type "double" :length 2))
+ #!-x86-64 (filler)
+ (real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
+ (imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that
(this :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))
(!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))
(/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")
(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))
(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)
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
;; 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))
;; 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)
(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)
(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))
(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)
;; 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))
(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
(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))
(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)
(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
(+ (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)
(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
(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))
(: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)
(: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
(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)
(:temporary (:sc unsigned-reg :from (:argument 0)) t1)
(:generator 60
(move result arg)
+ (move t1 arg)
(inst mov temp result)
(inst shr temp 1)
(inst 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)
(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)
(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
(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod64))
+(define-vop (fast-ash-left-mod64/unsigned=>unsigned
+ fast-ash-left/unsigned=>unsigned))
+(deftransform ash-left-mod64 ((integer count)
+ ((unsigned-byte 64) (unsigned-byte 6)))
+ (when (sb!c::constant-lvar-p count)
+ (sb!c::give-up-ir1-transform))
+ '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
(in-package "SB!C")
(in-package "SB!VM")
\f
+
+;; For use in constant indexing; we can't use INDEX since the displacement
+;; field of an EA can't contain 64 bit values.
+(deftype low-index () '(signed-byte 29))
+
;;;; allocator for the array header
(define-vop (make-array-header)
: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))
,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
(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)
(: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)
(: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)
(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))
(: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")
(: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")
(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")
(: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")
(: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")
(: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")
(: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")
(: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
(: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")
(: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")
(: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")
(: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")
(: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")
(: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")
(: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")
(: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)))))
\f
(: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
(: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))
(: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
(: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))
(: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)
(: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))
;;; 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
(: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
(: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)
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))
+\f
;;; signed-byte-8
(define-vop (data-vector-ref/simple-array-signed-byte-8)
(: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
(: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))
(: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
(: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)
(: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
(: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)
(: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
(define-vop (raw-ref-complex-single-c
data-vector-ref-c/simple-array-complex-single-float)
(:translate %raw-ref-complex-single)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+ (:arg-types sb!c::raw-vector (:constant low-index)))
(define-vop (raw-set-complex-single
data-vector-set/simple-array-complex-single-float)
(:translate %raw-set-complex-single)
(define-vop (raw-set-complex-single-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)
(define-vop (raw-ref-complex-double-c
data-vector-ref-c/simple-array-complex-double-float)
(:translate %raw-ref-complex-double)
- (:arg-types sb!c::raw-vector (:constant (signed-byte 61))))
+ (:arg-types sb!c::raw-vector (:constant low-index)))
(define-vop (raw-set-complex-double
data-vector-set/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(define-vop (raw-set-complex-double-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))
\f
;;;; compiler constants
-(def!constant +backend-fasl-file-implementation+ :x86)
+(def!constant +backend-fasl-file-implementation+ :x86-64)
(setf *backend-register-save-penalty* 3)
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))
(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)))))
(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)))
(: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)
((<= 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))
(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
(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
(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*))
(:args (fp)
(nfp)
(args :more t))
+ (:temporary (:sc unsigned-reg) return-label)
(:results (values :more t))
(:save-p t)
(:move-args :local-call)
((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)))))
(:args (fp)
(nfp)
(args :more t))
+ (:temporary (:sc unsigned-reg) return-label)
(:save-p t)
(:move-args :local-call)
(:info save callee target)
#+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)))))
(:args (fp)
(nfp)
(args :more t))
+ (:temporary (:sc unsigned-reg) return-label)
(:results (res :more t))
(:move-args :local-call)
(:save-p t)
#+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)))))
(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.
(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)))
\f
;;;; unknown values return
(: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)
(move rcx nvals)
(move rbx rbp-tn)
(move rbp-tn old-fp)
- (inst jmp (make-fixup 'return-multiple :assembly-routine))
+ (inst lea return-asm
+ (make-ea :qword :disp (make-fixup 'return-multiple
+ :assembly-routine)))
+ (inst jmp return-asm)
(trace-table-entry trace-table-normal)))
\f
;;;; XEP hackery
(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.
(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))))
\f
;;;; 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))
\f
;;;; other operations
(define-vop (char-code)
(:translate char-code)
(:policy :fast-safe)
- (:args (ch :scs (base-char-reg base-char-stack)))
- (:arg-types base-char)
+ (:args (ch :scs (character-reg character-stack)))
+ (:arg-types character)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
- (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)
(:temporary (:sc unsigned-reg :offset rax-offset :target res
:from (:argument 0) :to (:result 0))
eax)
- (:results (res :scs (base-char-reg)))
- (:result-types base-char)
+ (:results (res :scs (character-reg)))
+ (:result-types character)
(:generator 1
(move eax code)
(move res al-tn)))
\f
-;;; 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)
(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 :b :nb))
-(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)
(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 :b :nb))
-(define-vop (fast-char>/base-char/c base-char-compare/c)
+(define-vop (fast-char>/character/c character-compare/c)
(:translate char>)
(:variant :a :na))
(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)
;;;; 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))
\f
(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)))
\f
;;;; move VOPs
;;; float register to register moves
-(define-vop (float-move)
- (:args (x))
- (:results (y))
- (:note "float move")
- (:generator 0
- (unless (location= x y)
- (cond ((zerop (tn-offset y))
- (copy-fp-reg-to-fr0 x))
- ((zerop (tn-offset x))
- (inst fstd y))
- (t
- (inst fxch x)
- (inst fstd y)
- (inst fxch x))))))
-
-(define-vop (single-move float-move)
- (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
- (:results (y :scs (single-reg) :load-if (not (location= x y)))))
-(define-move-vop single-move :move (single-reg) (single-reg))
-
-(define-vop (double-move float-move)
- (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
- (:results (y :scs (double-reg) :load-if (not (location= x y)))))
-(define-move-vop double-move :move (double-reg) (double-reg))
+(macrolet ((frob (vop sc)
+ `(progn
+ (define-vop (,vop)
+ (:args (x :scs (,sc)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (,sc)
+ :load-if (not (location= x y))))
+ (:note "float move")
+ (:generator 0
+ (unless (location= y x)
+ (inst movq y x))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
+ (frob single-move single-reg)
+ (frob double-move double-reg))
;;; complex float register to register moves
(define-vop (complex-float-move)
(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
(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))
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)))
(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))
(: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)
(:results (y :scs (double-reg)))
(:note "pointer to float coercion")
(:generator 2
- (with-empty-tn@fp-top(y)
- (inst fldd (ea-for-df-desc x)))))
+ (inst movsd y (ea-for-df-desc x))))
(define-move-vop move-to-double :move (descriptor-reg) (double-reg))
\f
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))
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))
(: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))
\f
;;;; the move argument vops
;;;;
: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)
: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
\f
;;;; arithmetic VOPs
-;;; dtc: the floating point arithmetic vops
-;;;
-;;; Note: Although these can accept x and y on the stack or pointed to
-;;; from a descriptor register, they will work with register loading
-;;; without these. Same deal with the result - it need only be a
-;;; register. When load-tns are needed they will probably be in ST0
-;;; and the code below should be able to correctly handle all cases.
-;;;
-;;; However it seems to produce better code if all arg. and result
-;;; options are used; on the P86 there is no extra cost in using a
-;;; memory operand to the FP instructions - not so on the PPro.
-;;;
-;;; It may also be useful to handle constant args?
-;;;
-;;; 22-Jul-97: descriptor args lose in some simple cases when
-;;; a function result computed in a loop. Then Python insists
-;;; on consing the intermediate values! For example
-#|
-(defun test(a n)
- (declare (type (simple-array double-float (*)) a)
- (fixnum n))
- (let ((sum 0d0))
- (declare (type double-float sum))
- (dotimes (i n)
- (incf sum (* (aref a i)(aref a i))))
- sum))
-|#
-;;; So, disabling descriptor args until this can be fixed elsewhere.
-(macrolet
- ((frob (op fop-sti fopr-sti
- fop fopr sname scost
- fopd foprd dname dcost
- lname lcost)
- #!-long-float (declare (ignore lcost lname))
- `(progn
- (define-vop (,sname)
- (:translate ,op)
- (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc single-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (single-reg single-stack)))
- (:arg-types single-float single-float)
- (:result-types single-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,scost
- ;; Handle a few special cases
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x single-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch r)
- (inst ,fop fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x single-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (single-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fop y))
- (single-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (single-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y single-stack)
- (inst fld (ea-for-sf-stack y))
- (inst fld (ea-for-sf-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y single-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (single-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,fopr x))
- (single-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x single-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- ;; y is in ST0
- ((and (sc-is y single-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (single-reg
- (inst ,fopr x))
- (single-stack
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (copy-fp-reg-to-fr0 x))
- (single-stack
- (inst fstp fr0)
- (inst fld (ea-for-sf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fld (ea-for-sf-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (single-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (single-stack
- (inst fst (ea-for-sf-stack r))))))))
-
- (define-vop (,dname)
- (:translate ,op)
- (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (double-reg double-stack)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,dcost
- ;; Handle a few special cases.
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x double-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch x)
- (inst ,fopd fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x double-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (double-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fopd y))
- (double-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (double-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y double-stack)
- (inst fldd (ea-for-df-stack y))
- (inst fldd (ea-for-df-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y double-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (double-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,foprd x))
- (double-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- ;; y is in ST0
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (double-reg
- (inst ,foprd x))
- (double-stack
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (double-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (double-stack
- (inst fstd (ea-for-df-stack r))))))))
- )))
-
- (frob + fadd-sti fadd-sti
- fadd fadd +/single-float 2
- faddd faddd +/double-float 2
- +/long-float 2)
- (frob - fsub-sti fsubr-sti
- fsub fsubr -/single-float 2
- fsubd fsubrd -/double-float 2
- -/long-float 2)
- (frob * fmul-sti fmul-sti
- fmul fmul */single-float 3
- fmuld fmuld */double-float 3
- */long-float 3)
- (frob / fdiv-sti fdivr-sti
- fdiv fdivr //single-float 12
- fdivd fdivrd //double-float 12
- //long-float 12))
+(define-vop (float-op)
+ (:args (x) (y))
+ (:results (r))
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(macrolet ((frob (name sc ptype)
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:results (r :scs (,sc)))
+ (:arg-types ,ptype ,ptype)
+ (:result-types ,ptype))))
+ (frob single-float-op single-reg single-float)
+ (frob double-float-op double-reg double-float))
+
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:results (r :scs (single-reg)))
+ (:temporary (:sc single-reg) tmp)
+ (:generator ,scost
+ (inst movss tmp x)
+ (inst ,sinst tmp y)
+ (inst movss r tmp)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:results (r :scs (double-reg)))
+ (:temporary (:sc single-reg) tmp)
+ (:generator ,dcost
+ (inst movsd tmp x)
+ (inst ,dinst tmp y)
+ (inst movsd r tmp))))))
+ (frob + addss +/single-float 2 addsd +/double-float 2)
+ (frob - subss -/single-float 2 subsd -/double-float 2)
+ (frob * mulss */single-float 4 mulsd */double-float 5)
+ (frob / divss //single-float 12 divsd //double-float 19))
+
+
\f
-(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)))
\f
;;;; comparison
-(define-vop (=/float)
- (:args (x) (y))
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+(define-vop (float-compare)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
- (:note "inline float comparison")
- (:ignore temp)
- (:generator 3
- (note-this-location vop :internal-error)
- (cond
- ;; x is in ST0; y is in any reg.
- ((zerop (tn-offset x))
- (inst fucom y))
- ;; y is in ST0; x is in another reg.
- ((zerop (tn-offset y))
- (inst fucom x))
- ;; x and y are the same register, not ST0
- ((location= x y)
- (inst fxch x)
- (inst fucom fr0-tn)
- (inst fxch x))
- ;; x and y are different registers, neither ST0.
- (t
- (inst fxch x)
- (inst fucom y)
- (inst fxch x)))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x40)
- (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (=/single-float =/float)
- (:translate =)
- (:args (x :scs (single-reg))
- (y :scs (single-reg)))
- (:arg-types single-float single-float))
+ (:note "inline float comparison"))
-(define-vop (=/double-float =/float)
- (:translate =)
- (:args (x :scs (double-reg))
- (y :scs (double-reg)))
- (:arg-types double-float double-float))
+;;; comiss and comisd can cope with one or other arg in memory: we
+;;; could (should, indeed) extend these to cope with descriptor args
+;;; and stack args
-(define-vop (<single-float)
- (:translate <)
- (:args (x :scs (single-reg single-stack descriptor-reg))
- (y :scs (single-reg single-stack descriptor-reg)))
- (:arg-types single-float single-float)
- (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+(define-vop (single-float-compare float-compare)
+ (:args (x :scs (single-reg)) (y :scs (single-reg)))
(:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline float comparison")
- (:ignore temp)
- (:generator 3
- ;; Handle a few special cases.
- (cond
- ;; y is ST0.
- ((and (sc-is y single-reg) (zerop (tn-offset y)))
- (sc-case x
- (single-reg
- (inst fcom x))
- ((single-stack descriptor-reg)
- (if (sc-is x single-stack)
- (inst fcom (ea-for-sf-stack x))
- (inst fcom (ea-for-sf-desc x)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))
-
- ;; general case when y is not in ST0
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
- (sc-case y
- (single-reg
- (inst fcom y))
- ((single-stack descriptor-reg)
- (if (sc-is y single-stack)
- (inst fcom (ea-for-sf-stack y))
- (inst fcom (ea-for-sf-desc y)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x01)))
- (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (<double-float)
- (:translate <)
- (:args (x :scs (double-reg double-stack descriptor-reg))
- (y :scs (double-reg double-stack descriptor-reg)))
- (:arg-types double-float double-float)
- (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:arg-types single-float single-float))
+(define-vop (double-float-compare float-compare)
+ (:args (x :scs (double-reg)) (y :scs (double-reg)))
(:conditional)
+ (:arg-types double-float double-float))
+
+(define-vop (=/single-float single-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 double-reg) (zerop (tn-offset y)))
- (sc-case x
- (double-reg
- (inst fcomd x))
- ((double-stack descriptor-reg)
- (if (sc-is x double-stack)
- (inst fcomd (ea-for-df-stack x))
- (inst fcomd (ea-for-df-desc x)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))
-
- ;; General case when y is not in ST0.
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- (sc-case y
- (double-reg
- (inst fcomd y))
- ((double-stack descriptor-reg)
- (if (sc-is y double-stack)
- (inst fcomd (ea-for-df-stack y))
- (inst fcomd (ea-for-df-desc y)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x01)))
- (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (>single-float)
- (:translate >)
- (:args (x :scs (single-reg single-stack descriptor-reg))
- (y :scs (single-reg single-stack descriptor-reg)))
- (:arg-types single-float single-float)
- (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
+ (note-this-location vop :internal-error)
+ (inst comiss x y)
+ ;; if PF&CF, there was a NaN involved => not equal
+ ;; otherwise, ZF => equal
+ (cond (not-p
+ (inst jmp :p target)
+ (inst jmp :ne target))
+ (t
+ (let ((not-lab (gen-label)))
+ (inst jmp :p not-lab)
+ (inst jmp :e target)
+ (emit-label not-lab))))))
+
+(define-vop (=/double-float double-float-compare)
+ (:translate =)
(:info target not-p)
- (: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 (<double-float double-float-compare)
+ (:translate <)
(:info target not-p)
- (:policy :fast-safe)
- (:note "inline float comparison")
- (:ignore temp)
- (:generator 3
- ;; Handle a few special cases.
- (cond
- ;; y is ST0.
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- (sc-case x
- (double-reg
- (inst fcomd x))
- ((double-stack descriptor-reg)
- (if (sc-is x double-stack)
- (inst fcomd (ea-for-df-stack x))
- (inst fcomd (ea-for-df-desc x)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)
- (inst cmp ah-tn #x01))
-
- ;; general case when y is not in ST0
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- (sc-case y
- (double-reg
- (inst fcomd y))
- ((double-stack descriptor-reg)
- (if (sc-is y double-stack)
- (inst fcomd (ea-for-df-stack y))
- (inst fcomd (ea-for-df-desc y)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)))
- (inst jmp (if not-p :ne :e) target)))
-
-;;; Comparisons with 0 can use the FTST instruction.
-
-(define-vop (float-test)
- (:args (x))
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:conditional)
- (:info target not-p y)
- (:variant-vars code)
- (:policy :fast-safe)
- (:vop-var vop)
- (:save-p :compute-only)
- (:note "inline float comparison")
- (:ignore temp y)
(:generator 2
- (note-this-location vop :internal-error)
- (cond
- ;; x is in ST0
- ((zerop (tn-offset x))
- (inst ftst))
- ;; x not ST0
- (t
- (inst fxch x)
- (inst ftst)
- (inst fxch x)))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
- (unless (zerop code)
- (inst cmp ah-tn code))
- (inst jmp (if not-p :ne :e) target)))
-
-(define-vop (=0/single-float float-test)
- (:translate =)
- (:args (x :scs (single-reg)))
- (:arg-types single-float (:constant (single-float 0f0 0f0)))
- (:variant #x40))
-(define-vop (=0/double-float float-test)
- (:translate =)
- (:args (x :scs (double-reg)))
- (:arg-types double-float (:constant (double-float 0d0 0d0)))
- (:variant #x40))
-
-(define-vop (<0/single-float float-test)
- (:translate <)
- (:args (x :scs (single-reg)))
- (:arg-types single-float (:constant (single-float 0f0 0f0)))
- (:variant #x01))
-(define-vop (<0/double-float float-test)
+ (inst comisd x y)
+ (inst jmp (if not-p :nc :c) target)))
+
+(define-vop (<single-float single-float-compare)
(:translate <)
- (:args (x :scs (double-reg)))
- (:arg-types double-float (:constant (double-float 0d0 0d0)))
- (:variant #x01))
+ (:info target not-p)
+ (:generator 2
+ (inst comiss x y)
+ (inst jmp (if not-p :nc :c) target)))
-(define-vop (>0/single-float float-test)
+(define-vop (>double-float double-float-compare)
(:translate >)
- (: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)))
+
\f
;;;; conversion
-(macrolet ((frob (name translate to-sc to-type)
+(macrolet ((frob (name translate inst to-sc to-type)
`(define-vop (,name)
(:args (x :scs (signed-stack signed-reg) :target temp))
(:temporary (:sc signed-stack) temp)
(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)))
(: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)))
(: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)
(: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))
(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)
(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)
(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
(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)
(: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)
(: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)))
\f
;;;; float mode hackery
(move res new)))
\f
-(progn
-
-;;; Let's use some of the 80387 special functions.
-;;;
-;;; These defs will not take effect unless code/irrat.lisp is modified
-;;; to remove the inlined alien routine def.
-
-(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:ignore fr0)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline NPX function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op) ; clobber st0
- (cond ((zerop (tn-offset y))
- (maybe-fp-wait node))
- (t
- (inst fst y)))))))
-
- ;; Quick versions of fsin and fcos that require the argument to be
- ;; within range 2^63.
- (frob fsin-quick %sin-quick fsin)
- (frob fcos-quick %cos-quick fcos)
- (frob fsqrt %sqrt fsqrt))
-
-;;; Quick version of ftan that requires the argument to be within
-;;; range 2^63.
-(define-vop (ftan-quick)
- (:translate %tan-quick)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline tan function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (case (tn-offset x)
- (0
- (inst fstp fr1))
- (1
- (inst fstp fr0))
- (t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
- (inst fptan)
- ;; Result is in fr1
- (case (tn-offset y)
- (0
- (inst fxch fr1))
- (1)
- (t
- (inst fxch fr1)
- (inst fstd y)))))
-
-;;; These versions of fsin, fcos, and ftan try to use argument
-;;; reduction but to do this accurately requires greater precision and
-;;; it is hopelessly inaccurate.
-#+nil
-(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:translate ,trans)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :eval :to :result) eax)
- (:temporary (:sc unsigned-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc unsigned-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline sin/cos function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore eax)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fstp fr1) ; Load 2*PI
- (inst fldpi)
- (inst fadd fr0)
- (inst fxch fr1)
- LOOP
- (inst fprem1)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :nz LOOP)
- (inst ,op)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))))
- (frob fsin %sin fsin)
- (frob fcos %cos fcos))
-
-
-
-;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
-;;; the argument is out of range 2^63 and would thus be hopelessly
-;;; inaccurate.
-(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:translate ,trans)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline sin/cos function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore eax)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fstp fr0) ; Load 0.0
- (inst fldz)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))))
- (frob fsin %sin fsin)
- (frob fcos %cos fcos))
-
-(define-vop (ftan)
- (:translate %tan)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:ignore eax)
- (:policy :fast-safe)
- (:note "inline tan function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore eax)
- (:generator 5
- (note-this-location vop :internal-error)
- (case (tn-offset x)
- (0
- (inst fstp fr1))
- (1
- (inst fstp fr0))
- (t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
- (inst fptan)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fldz) ; Load 0.0
- (inst fxch fr1)
- DONE
- ;; Result is in fr1
- (case (tn-offset y)
- (0
- (inst fxch fr1))
- (1)
- (t
- (inst fxch fr1)
- (inst fstd y)))))
-
-#+nil
-(define-vop (fexp)
- (:translate %exp)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:temporary (:sc double-reg :offset fr2-offset
- :from :argument :to :result) fr2)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline exp function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (sc-case x
- (double-reg
- (cond ((zerop (tn-offset x))
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldl2e)
- (inst fmul fr1))
- (t
- ;; x is in a FP reg, not fr0
- (inst fstp fr0)
- (inst fldl2e)
- (inst fmul x))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fldl2e)
- (if (sc-is x double-stack)
- (inst fmuld (ea-for-df-stack x))
- (inst fmuld (ea-for-df-desc x)))))
- ;; Now fr0=x log2(e)
- (inst fst fr1)
- (inst frndint)
- (inst fst fr2)
- (inst fsubp-sti fr1)
- (inst f2xm1)
- (inst fld1)
- (inst faddp-sti fr1)
- (inst fscale)
- (inst fld fr0)
- (case (tn-offset y)
- ((0 1))
- (t (inst fstd y)))))
-
-;;; Modified exp that handles the following special cases:
-;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
-(define-vop (fexp)
- (:translate %exp)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:temporary (:sc double-reg :offset fr2-offset
- :from :argument :to :result) fr2)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline exp function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore temp)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- ;; Check for Inf or NaN
- (inst fxam)
- (inst fnstsw)
- (inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives 0
- (inst fldz)
- (inst jmp-short DONE)
- NOINFNAN
- (inst fstp fr1)
- (inst fldl2e)
- (inst fmul fr1)
- ;; Now fr0=x log2(e)
- (inst fst fr1)
- (inst frndint)
- (inst fst fr2)
- (inst fsubp-sti fr1)
- (inst f2xm1)
- (inst fld1)
- (inst faddp-sti fr1)
- (inst fscale)
- (inst fld fr0)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))
-
-;;; Expm1 = exp(x) - 1.
-;;; Handles the following special cases:
-;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
-(define-vop (fexpm1)
- (:translate %expm1)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:temporary (:sc double-reg :offset fr2-offset
- :from :argument :to :result) fr2)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline expm1 function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore temp)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- ;; Check for Inf or NaN
- (inst fxam)
- (inst fnstsw)
- (inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives -1.0
- (inst fld1)
- (inst fchs)
- (inst jmp-short DONE)
- NOINFNAN
- ;; Free two stack slots leaving the argument on top.
- (inst fstp fr2)
- (inst fstp fr0)
- (inst fldl2e)
- (inst fmul fr1) ; Now fr0 = x log2(e)
- (inst fst fr1)
- (inst frndint)
- (inst fsub-sti fr1)
- (inst fxch fr1)
- (inst f2xm1)
- (inst fscale)
- (inst fxch fr1)
- (inst fld1)
- (inst fscale)
- (inst fstp fr1)
- (inst fld1)
- (inst fsub fr1)
- (inst fsubr fr2)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))
-
-(define-vop (flog)
- (:translate %log)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline log function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))
- (inst fyl2x)))
- (inst fld fr0)
- (case (tn-offset y)
- ((0 1))
- (t (inst fstd y)))))
-
-(define-vop (flog10)
- (:translate %log10)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline log10 function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldlg2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldlg2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))
- (inst fyl2x)))
- (inst fld fr0)
- (case (tn-offset y)
- ((0 1))
- (t (inst fstd y)))))
-
-(define-vop (fpow)
- (:translate %pow)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (double-reg double-stack descriptor-reg) :target fr1))
- (:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
- (:temporary (:sc double-reg :offset fr2-offset
- :from :load :to :result) fr2)
- (:results (r :scs (double-reg)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline pow function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- ;; Setup x in fr0 and y in fr1
- (cond
- ;; x in fr0; y in fr1
- ((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (= 1 (tn-offset y))))
- ;; y in fr1; x not in fr0
- ((and (sc-is y double-reg) (= 1 (tn-offset y)))
- ;; Load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
- ;; x in fr0; y not in fr1
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- (inst fxch fr1)
- ;; Now load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
- (inst fxch fr1))
- ;; x in fr1; y not in fr1
- ((and (sc-is x double-reg) (= 1 (tn-offset x)))
- ;; Load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
- (inst fxch fr1))
- ;; y in fr0;
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- (inst fxch fr1)
- ;; Now load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
- ;; Neither x or y are in either fr0 or fr1
- (t
- ;; Load y then x
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))
- ;; Load x to fr0
- (sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
-
- ;; Now have x at fr0; and y at fr1
- (inst fyl2x)
- ;; Now fr0=y log2(x)
- (inst fld fr0)
- (inst frndint)
- (inst fst fr2)
- (inst fsubp-sti fr1)
- (inst f2xm1)
- (inst fld1)
- (inst faddp-sti fr1)
- (inst fscale)
- (inst fld fr0)
- (case (tn-offset r)
- ((0 1))
- (t (inst fstd r)))))
-
-(define-vop (fscalen)
- (:translate %scalbn)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (signed-stack signed-reg) :target temp))
- (:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
- (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
- (:results (r :scs (double-reg)))
- (:arg-types double-float signed-num)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline scalbn function")
- (:generator 5
- ;; Setup x in fr0 and y in fr1
- (sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- (inst fstp fr1)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (1
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (t
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fld (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- (inst fscale)
- (unless (zerop (tn-offset r))
- (inst fstd r))))
-
-(define-vop (fscale)
- (:translate %scalb)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (double-reg double-stack descriptor-reg) :target fr1))
- (:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
- (:results (r :scs (double-reg)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline scalb function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- ;; Setup x in fr0 and y in fr1
- (cond
- ;; x in fr0; y in fr1
- ((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (= 1 (tn-offset y))))
- ;; y in fr1; x not in fr0
- ((and (sc-is y double-reg) (= 1 (tn-offset y)))
- ;; Load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
- ;; x in fr0; y not in fr1
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- (inst fxch fr1)
- ;; Now load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
- (inst fxch fr1))
- ;; x in fr1; y not in fr1
- ((and (sc-is x double-reg) (= 1 (tn-offset x)))
- ;; Load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
- (inst fxch fr1))
- ;; y in fr0;
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- (inst fxch fr1)
- ;; Now load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
- ;; Neither x or y are in either fr0 or fr1
- (t
- ;; Load y then x
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))
- ;; Load x to fr0
- (sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
-
- ;; Now have x at fr0; and y at fr1
- (inst fscale)
- (unless (zerop (tn-offset r))
- (inst fstd r))))
-
-(define-vop (flog1p)
- (:translate %log1p)
- (:args (x :scs (double-reg) :to :result))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline log1p function")
- (:ignore temp)
- (:generator 5
- ;; x is in a FP reg, not fr0, fr1.
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))
- ;; Check the range
- (inst push #x3e947ae1) ; Constant 0.29
- (inst fabs)
- (inst fld (make-ea :dword :base rsp-tn))
- (inst fcompp)
- (inst add rsp-tn 4)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45)
- (inst jmp :z WITHIN-RANGE)
- ;; Out of range for fyl2xp1.
- (inst fld1)
- (inst faddd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
- (inst fldln2)
- (inst fxch fr1)
- (inst fyl2x)
- (inst jmp DONE)
-
- WITHIN-RANGE
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
- (inst fyl2xp1)
- DONE
- (inst fld fr0)
- (case (tn-offset y)
- ((0 1))
- (t (inst fstd y)))))
-
-;;; The Pentium has a less restricted implementation of the fyl2xp1
-;;; instruction and a range check can be avoided.
-(define-vop (flog1p-pentium)
- (:translate %log1p)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*))
- (:note "inline log1p with limited x range function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 4
- (note-this-location vop :internal-error)
- (sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- (inst fyl2xp1)
- (inst fld fr0)
- (case (tn-offset y)
- ((0 1))
- (t (inst fstd y)))))
-
-(define-vop (flogb)
- (:translate %logb)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline logb function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- (sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- (inst fxtract)
- (case (tn-offset y)
- (0
- (inst fxch fr1))
- (1)
- (t (inst fxch fr1)
- (inst fstd y)))))
-
-(define-vop (fatan)
- (:translate %atan)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
- (:results (r :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline atan function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- ;; Setup x in fr1 and 1.0 in fr0
- (cond
- ;; x in fr0
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- (inst fstp fr1))
- ;; x in fr1
- ((and (sc-is x double-reg) (= 1 (tn-offset x)))
- (inst fstp fr0))
- ;; x not in fr0 or fr1
- (t
- ;; Load x then 1.0
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
- (inst fld1)
- ;; Now have x at fr1; and 1.0 at fr0
- (inst fpatan)
- (inst fld fr0)
- (case (tn-offset r)
- ((0 1))
- (t (inst fstd r)))))
-
-(define-vop (fatan2)
- (:translate %atan2)
- (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
- (y :scs (double-reg double-stack descriptor-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 1) :to :result) fr0)
- (:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
- (:results (r :scs (double-reg)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline atan2 function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (note-this-location vop :internal-error)
- ;; Setup x in fr1 and y in fr0
- (cond
- ;; y in fr0; x in fr1
- ((and (sc-is y double-reg) (zerop (tn-offset y))
- (sc-is x double-reg) (= 1 (tn-offset x))))
- ;; x in fr1; y not in fr0
- ((and (sc-is x double-reg) (= 1 (tn-offset x)))
- ;; Load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y)))))
- ((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (zerop (tn-offset x)))
- ;; copy x to fr1
- (inst fst fr1))
- ;; y in fr0; x not in fr1
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- (inst fxch fr1)
- ;; Now load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
- (inst fxch fr1))
- ;; y in fr1; x not in fr1
- ((and (sc-is y double-reg) (= 1 (tn-offset y)))
- ;; Load x to fr0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
- (inst fxch fr1))
- ;; x in fr0;
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- (inst fxch fr1)
- ;; Now load y to fr0
- (sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y)))))
- ;; Neither y or x are in either fr0 or fr1
- (t
- ;; Load x then y
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))
- ;; Load y to fr0
- (sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset y)))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))))
-
- ;; Now have y at fr0; and x at fr1
- (inst fpatan)
- (inst fld fr0)
- (case (tn-offset r)
- ((0 1))
- (t (inst fstd r)))))
-) ; PROGN #!-LONG-FLOAT
-\f
-
;;;; complex float VOPs
(define-vop (make-complex-single-float)
(: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)
(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))
: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
(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
(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)
;;; 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)
: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*
#(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*)
)
(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)))
(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
(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
(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
(:byte 8)
(:word 16)
(:dword 32)
+ (:qword 64)
(:float 32)
(:double 64)))
: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
: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
: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))))
: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)
(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*
(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))
: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))
(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))
(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))
;; 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
(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))
;; 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
(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
;; 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))
: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)
(defun emit-relative-fixup (segment fixup)
(note-fixup segment :relative fixup)
(emit-dword segment (or (fixup-offset fixup) 0)))
+
\f
;;;; the effective-address (ea) structure
(defun reg-tn-encoding (tn)
(declare (type tn tn))
- (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
(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.
(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))
(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)
(and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
(t nil)))
-
(defun register-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
(defun accumulator-p (thing)
(and (register-p thing)
(= (tn-offset thing) 0)))
+
\f
;;;; utilities
(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)))))
(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)))
;; 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)))
#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
#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
(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)
(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)))
;;; 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))
;; 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)))
(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)))
(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)
(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))))
(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)
(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)
(: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)))
(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)
(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
(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
;;; 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)))
(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)
(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))
(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)
(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))
(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))
(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)
(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))
(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))
(define-instruction stos (segment acc)
(:printer string-op ((op #b1010101)))
+ (:printer rex-string-op ((op #b1010101)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(:emitter
(typecase where
(label
+ (maybe-emit-rex-for-ea segment where nil)
(emit-byte segment #b11101000) ; 32 bit relative
(emit-back-patch segment
4
(- (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)))))
(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)))))
(: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))))
(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)))
(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)))))
;;; 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))
(storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
,result-tn)
(inst lea ,result-tn
- (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
+ (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
,@forms))
\f
;;;; error code
(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))))
(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)
(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))
(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))
(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
(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)
;;; 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.
;;;
((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)
fp (tn-offset y)))
(character
(storew (logior (ash (char-code val) n-widetag-bits)
- base-char-widetag)
+ character-widetag)
fp (tn-offset y))))
;; Lisp stack
(etypecase val
fp (- (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
;;; 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))
;; 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)
(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
(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)
;; Copy them down.
(inst std)
(inst rep)
- (inst movs :dword)
+ (inst movs :qword)
DONE
;; Reset the CSP at last moved arg.
\f
;;;; description of the target address space
-;;; where to put the different spaces. untested (copied from x86, in fact)
+;;; where to put the different spaces.
+(def!constant read-only-space-start #x20000000)
+(def!constant read-only-space-end #x27ff0000)
-(def!constant read-only-space-start #x01000000)
-(def!constant read-only-space-end #x037ff000)
+(def!constant static-space-start #x40000000)
+(def!constant static-space-end #x47fff000)
-(def!constant static-space-start #x05000000)
-(def!constant static-space-end #x07fff000)
+(def!constant dynamic-space-start #x1000000000)
+(def!constant dynamic-space-end #x11ffff0000)
-(def!constant dynamic-space-start #x09000000)
-(def!constant dynamic-space-end #x29000000)
+(def!constant linkage-table-space-start #x60000000)
+(def!constant linkage-table-space-end #x63fff000)
+(def!constant linkage-table-entry-size 16)
\f
;;;; other miscellaneous constants
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
(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)
(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)))
(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)))
(: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)
(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-)
: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)))
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))
;; 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))
: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)))
(: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))))))
\f
;;;; test generation utilities
-;;; Emit the most compact form of the test immediate instruction,
-;;; using an 8 bit test when the immediate is only 8 bits and the
-;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
-;;; control stack.
+(defun make-byte-tn (tn)
+ (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'byte-reg)
+ :offset (tn-offset tn)))
+
(defun generate-fixnum-test (value)
"zero flag set if VALUE is fixnum"
(let ((offset (tn-offset value)))
- (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)
(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.
(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))
(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))))
\f
;;;; list/symbol types
;;;
(: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.
;;;; 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"))
;; 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)
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
;;
;; names and offsets for registers used to pass arguments
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *register-arg-names* '(rdx rdi rsi)))
- (defregset *register-arg-offsets* rdx rdi rsi))
+ (defregset *register-arg-offsets* rdx rdi rsi)
+ (defregset *c-call-register-arg-offsets* rdi rsi rdx rcx r8 r9))
\f
;;;; SB definitions
;;; 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)
;; non-immediate constants in the constant pool
(constant constant)
+ (fp-single-zero immediate-constant)
+ (fp-double-zero immediate-constant)
+
(immediate immediate-constant)
;;
;; 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)
: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
;; 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 ()
(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...
;;;
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*
(svref name-vec offset))
;; FIXME: Shouldn't this be an ERROR?
(format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
- (float-registers (format nil "FR~D" offset))
+ (float-registers (format nil "FLOAT~D" offset))
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
(immediate-constant "Immed")
\f
;;; The loader uses this to convert alien names to the form they need in
;;; the symbol table (for example, prepending an underscore).
+\f
+;;; The loader uses this to convert alien names to the form they need in
+;;; the symbol table (for example, prepending an underscore).
(defun extern-alien-name (name)
- (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
+
(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
(inst fxch value-imag))))
-#!+long-float
-(define-vop (data-vector-ref/simple-array-complex-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
- (:arg-types simple-array-complex-long-float positive-fixnum)
- (:temporary (:sc any-reg :from :eval :to :result) temp)
- (:results (value :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 7
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (let ((real-tn (complex-long-reg-real-tn value)))
- (with-empty-tn@fp-top (real-tn)
- (inst fldl (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
- (let ((imag-tn (complex-long-reg-imag-tn value)))
- (with-empty-tn@fp-top (imag-tn)
- (inst fldl (make-ea :dword :base object :index temp :scale 2
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 12)
- other-pointer-lowtag)))))))
-#!+long-float
-(define-vop (data-vector-ref-c/simple-array-complex-long-float)
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
- (:results (value :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 6
- (let ((real-tn (complex-long-reg-real-tn value)))
- (with-empty-tn@fp-top (real-tn)
- (inst fldl (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))))
- (let ((imag-tn (complex-long-reg-imag-tn value)))
- (with-empty-tn@fp-top (imag-tn)
- (inst fldl (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index) 12)
- other-pointer-lowtag)))))))
-
-#!+long-float
-(define-vop (data-vector-set/simple-array-complex-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg))
- (value :scs (complex-long-reg) :target result))
- (:arg-types simple-array-complex-long-float positive-fixnum
- complex-long-float)
- (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
- (:results (result :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 20
- ;; temp = 3 * index
- (inst lea temp (make-ea :dword :base index :index index :scale 2))
- (let ((value-real (complex-long-reg-real-tn value))
- (result-real (complex-long-reg-real-tn result)))
- (cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
- (let ((value-imag (complex-long-reg-imag-tn value))
- (result-imag (complex-long-reg-imag-tn result)))
- (inst fxch value-imag)
- (store-long-float
- (make-ea :dword :base object :index temp :scale 2
- :disp (- (+ (* vector-data-offset n-word-bytes) 12)
- other-pointer-lowtag)))
- (unless (location= value-imag result-imag)
- (inst fstd result-imag))
- (inst fxch value-imag))))
-
-#!+long-float
-(define-vop (data-vector-set-c/simple-array-complex-long-float)
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (complex-long-reg) :target result))
- (:info index)
- (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
- complex-long-float)
- (:results (result :scs (complex-long-reg)))
- (:result-types complex-long-float)
- (:generator 19
- (let ((value-real (complex-long-reg-real-tn value))
- (result-real (complex-long-reg-real-tn result)))
- (cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 24 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
- (let ((value-imag (complex-long-reg-imag-tn value))
- (result-imag (complex-long-reg-imag-tn result)))
- (inst fxch value-imag)
- (store-long-float
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- ;; FIXME: There are so many of these bare constants
- ;; (24, 12..) in the LONG-FLOAT code that it's
- ;; ridiculous. I should probably just delete it all
- ;; instead of appearing to flirt with supporting
- ;; this maintenance nightmare.
- (* 24 index) 12)
- other-pointer-lowtag)))
- (unless (location= value-imag result-imag)
- (inst fstd result-imag))
- (inst fxch value-imag))))
\f
;;; unsigned-byte-8
(macrolet ((define-data-vector-frobs (ptype)
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)
(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
(: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.
# 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
#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. */
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);
}
}
\f
-/* code and code-related objects */
-
-/* FIXME (1) this could probably be defined using something like
- * sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
- * - FUN_POINTER_LOWTAG
- * as I'm reasonably sure that simple_fun->code must always be the
- * last slot in the object
-
- * FIXME (2) it also appears in purify.c, and it has a different value
- * for SPARC users in that bit
- */
-
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
-
-/* Note: on the sparc we don't have to do anything special for fdefns, */
-/* 'cause the raw-addr has a function lowtag. */
-#ifndef LISP_FEATURE_SPARC
-static int
-scav_fdefn(lispobj *where, lispobj object)
-{
- struct fdefn *fdefn;
-
- fdefn = (struct fdefn *)where;
-
- if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
- == (char *)((unsigned long)(fdefn->raw_addr))) {
- scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
- fdefn->raw_addr =
- (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
- return sizeof(struct fdefn) / sizeof(lispobj);
- }
- else
- return 1;
-}
-#endif
-
-
-\f
/* vector-like objects */
-static int
+static long
scav_vector(lispobj *where, lispobj object)
{
if (HeaderValue(object) == subtype_VectorValidHashing) {
#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 */
#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))
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;
/* to copy a boxed object */
lispobj
-copy_object(lispobj object, int nwords)
+copy_object(lispobj object, long nwords)
{
int tag;
lispobj *new;
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
{
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) {
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;
{
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;
/* 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;
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 */
}
-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;
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",
* 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;
}
#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",
* instances
*/
-static int
+static long
scav_instance_pointer(lispobj *where, lispobj object)
{
lispobj copy, *first_pointer;
static lispobj trans_list(lispobj object);
-static int
+static long
scav_list_pointer(lispobj *where, lispobj object)
{
lispobj first, *first_pointer;
* scavenging and transporting other pointers
*/
-static int
+static long
scav_other_pointer(lispobj *where, lispobj object)
{
lispobj first, *first_pointer;
* 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;
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;
}
-static int
+static long
size_boxed(lispobj *where)
{
lispobj header;
/* 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;
}
#endif
-static int
+static long
scav_unboxed(lispobj *where, lispobj object)
{
unsigned long length;
return copy_unboxed_object(object, length);
}
-static int
+static long
size_unboxed(lispobj *where)
{
lispobj header;
return length;
}
-static int\f
+\f
/* 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. */
trans_base_string(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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
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;
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;
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;
}
trans_vector(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
return nwords;
}
-static int
+static long
scav_vector_nil(lispobj *where, lispobj object)
{
return 2;
return copy_unboxed_object(object, 2);
}
-static int
+static long
size_vector_nil(lispobj *where)
{
/* Just the header word and the length word */
return 2;
}
-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);
trans_vector_bit(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
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);
trans_vector_unsigned_byte_2(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
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);
trans_vector_unsigned_byte_4(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
}
-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);
trans_vector_unsigned_byte_8(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
}
-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);
trans_vector_unsigned_byte_16(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
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);
trans_vector_unsigned_byte_32(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
}
#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);
trans_vector_unsigned_byte_64(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
}
#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);
trans_vector_single_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
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);
trans_vector_double_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
}
#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);
trans_vector_long_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
#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);
trans_vector_complex_single_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
#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);
trans_vector_complex_double_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
#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);
trans_vector_complex_long_float(lispobj object)
{
struct vector *vector;
- int length, nwords;
+ long length, nwords;
gc_assert(is_lisp_pointer(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);
return copy;
}
-static int
+static long
size_weak_pointer(lispobj *where)
{
return WEAK_POINTER_NWORDS;
* initialization
*/
-static int
+static long
scav_lose(lispobj *where, lispobj object)
{
lose("no scavenge function for object 0x%08x (widetag 0x%x)",
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)",
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
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
#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;
}
}
/* FIXME: Shouldn't this be defined in sbcl.h? */
+
+/* FIXME (1) this could probably be defined using something like
+ * sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
+ * - FUN_POINTER_LOWTAG
+ * as I'm reasonably sure that simple_fun->code must always be the
+ * last slot in the object
+
+ * FIXME (2) it also appears in purify.c, and it has a different value
+ * for SPARC users in that bit
+ */
+
#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
/* values for the *_alloc_* parameters */
#define 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);
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;
void gc_free_heap(void);
-inline int find_page_index(void *);
-inline void *page_address(int);
+inline long find_page_index(void *);
+inline void *page_address(long);
int gencgc_handle_wp_violation(void *);
\f
struct page {
* 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 */
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);
* 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));
}
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 *);
/* 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.
* 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);
}
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;
* 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
* ALLOCATION_POINTER which is used by the room function to limit its
* search of the heap. XX Gencgc obviously needs to be better
* integrated with the Lisp code. */
-static int last_free_page;
+static long last_free_page;
\f
/* This lock is to prevent multiple threads from simultaneously
* allocating new regions which overlap each other. Note that the
/* 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)
}
/* 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)
}
#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;
/* 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;
* 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,
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;
/* 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
* 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)
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;
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;
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 =
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
* 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;
/* 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;
* 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;
}
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);
}
* 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
* 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));
/* 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
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. */
/* 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));
* 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));
/* 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);
void
sniff_code_object(struct code *code, unsigned displacement)
{
- int nheader_words, ncode_words, nwords;
+ long nheader_words, ncode_words, nwords;
void *p;
void *constants_start_addr, *constants_end_addr;
void *code_start_addr, *code_end_addr;
void
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;
/*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. */
*(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. */
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;
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);
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);
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;
/* 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);
/* 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) {
/*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];
#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;
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. */
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
#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
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;
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
#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
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. */
*
* 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);
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)
static void
scavenge_generation(int generation)
{
- int i;
+ long i;
int num_wp = 0;
#define SC_GEN_CK 0
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 */
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. */
static void
scavenge_newspace_generation_one_scan(int generation)
{
- int i;
+ long i;
FSHOW((stderr,
"/starting one full scan of newspace generation %d\n",
/* (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.
/* 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) +
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();
/* 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);
}
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)
* 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;
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));
}
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,
}
#endif
-extern int undefined_tramp;
+extern long undefined_tramp;
static void
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));
{
lispobj object = *start;
struct code *code;
- int nheader_words, ncode_words, nwords;
+ long nheader_words, ncode_words, nwords;
lispobj fheaderl;
struct simple_fun *fheaderp;
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
#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
* 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);
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 */
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;
}
}
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);
static void
verify_dynamic_space(void)
{
- int i;
+ long i;
for (i = 0; i < NUM_GENERATIONS; i++)
verify_generation(i);
static void
write_protect_generation_pages(int generation)
{
- int i;
+ long i;
gc_assert(generation < NUM_GENERATIONS);
* 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;
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 {
#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,
/* 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);
}
/* 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;
int gen = 0;
int raise;
int gen_to_wp;
- int i;
+ long i;
FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
void
gc_free_heap(void)
{
- int page;
+ long page;
if (gencgc_verbose > 1)
SHOW("entering gc_free_heap");
}
} 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);
void
gc_init(void)
{
- int i;
+ long i;
gc_init_tables();
scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
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 {
* 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=
#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,
#else
gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th));
#endif
+#endif
/* maybe we can do this quickly ... */
new_free_pointer = region->free_pointer + nbytes;
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",
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;
{
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;
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
(*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
{
* 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)) {
#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 */
{
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
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),
/* 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;
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
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 */
}
static inline lispobj *
-newspace_alloc(int nwords, int constantp)
+newspace_alloc(long nwords, int constantp)
{
lispobj *ret;
nwords=CEILING(nwords,2);
\f
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
#ifdef LISP_FEATURE_GENCGC
/*
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? */
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;
}
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;
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;
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
#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
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;
}
#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
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);
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);
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
\f
static void
-pscav_later(lispobj *where, int count)
+pscav_later(lispobj *where, long count)
{
struct later *new;
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);
* 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);
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);
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);
}
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));
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;
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. */
(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; i<length; i++) {
unsigned offset = fixups_vector->data[i];
/* Now check the current value of offset. */
/* 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;
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
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
static lispobj
ptrans_func(lispobj thing, lispobj header)
{
- int nwords;
+ long nwords;
lispobj code, *new, *old, result;
struct simple_fun *function;
}
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
ptrans_list(lispobj thing, boolean constant)
{
struct cons *old, *new, *orig;
- int length;
+ long length;
orig = (struct cons *) newspace_alloc(0,constant);
length = 0;
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);
#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);
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;
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);
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
#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) {
}
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)) {
#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:
*addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
SIMPLE_VECTOR_WIDETAG;
}
- count = 1;
+ count = 2;
break;
case SIMPLE_ARRAY_NIL_WIDETAG:
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:
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
#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
#endif
case CODE_HEADER_WIDETAG:
-#ifndef LISP_FEATURE_X86
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
gc_abort(); /* no code headers in static space */
#else
count = pscav_code((struct code*)addr);
gc_abort();
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
purify(lispobj static_roots, lispobj read_only_roots)
{
lispobj *clean;
- int count, i;
+ long count, i;
struct later *laters, *next;
struct thread *thread;
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
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 */
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,
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,
/* 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 -
/* 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 ;
#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)
{
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);
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
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),
{
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,
(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");
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);
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
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);
#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
#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
#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
#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);
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+
+#include "sbcl.h"
+#include "runtime.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "sbcl.h"
+#include "arch.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+#include "monitor.h"
+#include "thread.h"
+
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
+#define BREAKPOINT_INST 0xcc /* INT3 */
+
+unsigned long fast_random_state = 1;
+
+void arch_init(void)
+{}
+\f
+/*
+ * hacking signal contexts
+ *
+ * (This depends both on architecture, which determines what we might
+ * want to get to, and on OS, which determines how we get to it.)
+ */
+
+int *
+context_eflags_addr(os_context_t *context)
+{
+#if defined __linux__
+ /* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
+ * <sys/ucontext.h> file to define symbolic names for offsets into
+ * gregs[], but it's conditional on __USE_GNU and not defined, so
+ * we need to do this nasty absolute index magic number thing
+ * instead. */
+ return &context->uc_mcontext.gregs[16];
+#elif defined __FreeBSD__
+ return &context->uc_mcontext.mc_eflags;
+#elif defined __OpenBSD__
+ return &context->sc_eflags;
+#else
+#error unsupported OS
+#endif
+}
+\f
+void arch_skip_instruction(os_context_t *context)
+{
+ /* Assuming we get here via an INT3 xxx instruction, the PC now
+ * points to the interrupt code (a Lisp value) so we just move
+ * past it. Skip the code; after that, if the code is an
+ * error-trap or cerror-trap then skip the data bytes that follow. */
+
+ int vlen;
+ long code;
+
+
+ /* Get and skip the Lisp interrupt code. */
+ code = *(char*)(*os_context_pc_addr(context))++;
+ switch (code)
+ {
+ case trap_Error:
+ case trap_Cerror:
+ /* Lisp error arg vector length */
+ vlen = *(char*)(*os_context_pc_addr(context))++;
+ /* Skip Lisp error arg data bytes. */
+ while (vlen-- > 0) {
+ ( (char*)(*os_context_pc_addr(context)) )++;
+ }
+ break;
+
+ case trap_Breakpoint: /* not tested */
+ case trap_FunEndBreakpoint: /* not tested */
+ break;
+
+ case trap_PendingInterrupt:
+ case trap_Halt:
+ /* only needed to skip the Code */
+ break;
+
+ default:
+ fprintf(stderr,"[arch_skip_inst invalid code %d\n]\n",code);
+ break;
+ }
+
+ FSHOW((stderr,
+ "/[arch_skip_inst resuming at %x]\n",
+ *os_context_pc_addr(context)));
+}
+
+unsigned char *
+arch_internal_error_arguments(os_context_t *context)
+{
+ return 1 + (unsigned char *)(*os_context_pc_addr(context));
+}
+
+boolean
+arch_pseudo_atomic_atomic(os_context_t *context)
+{
+ return SymbolValue(PSEUDO_ATOMIC_ATOMIC,arch_os_get_current_thread());
+}
+
+void
+arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),
+ arch_os_get_current_thread());
+}
+\f
+/*
+ * This stuff seems to get called for TRACE and debug activity.
+ */
+
+unsigned long
+arch_install_breakpoint(void *pc)
+{
+ unsigned long result = *(unsigned long*)pc;
+
+ *(char*)pc = BREAKPOINT_INST; /* x86 INT3 */
+ *((char*)pc+1) = trap_Breakpoint; /* Lisp trap code */
+
+ return result;
+}
+
+void
+arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+ *((char *)pc) = orig_inst & 0xff;
+ *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+}
+\f
+/* When single stepping, single_stepping holds the original instruction
+ * PC location. */
+unsigned long *single_stepping = NULL;
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+unsigned long single_step_save1;
+unsigned long single_step_save2;
+unsigned long single_step_save3;
+#endif
+
+void
+arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
+{
+ unsigned long *pc = (unsigned long*)(*os_context_pc_addr(context));
+
+ /* Put the original instruction back. */
+ *((char *)pc) = orig_inst & 0xff;
+ *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+ /* Install helper instructions for the single step:
+ * pushf; or [esp],0x100; popf. */
+ single_step_save1 = *(pc-3);
+ single_step_save2 = *(pc-2);
+ single_step_save3 = *(pc-1);
+ *(pc-3) = 0x9c909090;
+ *(pc-2) = 0x00240c81;
+ *(pc-1) = 0x9d000001;
+#else
+ *context_eflags_addr(context) |= 0x100;
+#endif
+
+ single_stepping = (unsigned int*)pc;
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+ *os_context_pc_addr(context) = (char *)pc - 9;
+#endif
+}
+\f
+void
+sigtrap_handler(int signal, siginfo_t *info, void *void_context)
+{
+ int code = info->si_code;
+ os_context_t *context = (os_context_t*)void_context;
+ unsigned int trap;
+ sigset_t ss;
+
+ if (single_stepping && (signal==SIGTRAP))
+ {
+ /* fprintf(stderr,"* single step trap %x\n", single_stepping); */
+
+#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
+ /* Un-install single step helper instructions. */
+ *(single_stepping-3) = single_step_save1;
+ *(single_stepping-2) = single_step_save2;
+ *(single_stepping-1) = single_step_save3;
+#else
+ *context_eflags_addr(context) ^= 0x100;
+#endif
+ /* Re-install the breakpoint if possible. */
+ if (*os_context_pc_addr(context) == (int)single_stepping + 1) {
+ fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
+ } else {
+ *((char *)single_stepping) = BREAKPOINT_INST; /* x86 INT3 */
+ *((char *)single_stepping+1) = trap_Breakpoint;
+ }
+
+ single_stepping = NULL;
+ return;
+ }
+
+ /* This is just for info in case the monitor wants to print an
+ * approximation. */
+ current_control_stack_pointer =
+ (lispobj *)*os_context_sp_addr(context);
+
+ /* FIXME: CMUCL puts the float control restoration code here.
+ Thus, it seems to me that single-stepping won't restore the
+ float control. Since SBCL currently doesn't support
+ single-stepping (as far as I can tell) this is somewhat moot,
+ but it might be worth either moving this code up or deleting
+ the single-stepping code entirely. -- CSR, 2002-07-15 */
+#ifdef LISP_FEATURE_LINUX
+ os_restore_fp_control(context);
+#endif
+
+ /* On entry %eip points just after the INT3 byte and aims at the
+ * 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a
+ * number of bytes will follow, the first is the length of the byte
+ * arguments to follow. */
+ trap = *(unsigned char *)(*os_context_pc_addr(context));
+ switch (trap) {
+
+ case trap_PendingInterrupt:
+ FSHOW((stderr, "/<trap pending interrupt>\n"));
+ arch_skip_instruction(context);
+ sigemptyset(&ss);
+ sigaddset(&ss,SIGTRAP);
+ sigprocmask(SIG_UNBLOCK,&ss,0);
+ interrupt_handle_pending(context);
+ break;
+
+ case trap_Halt:
+ /* Note: the old CMU CL code tried to save FPU state
+ * here, and restore it after we do our thing, but there
+ * seems to be no point in doing that, since we're just
+ * going to lose(..) anyway. */
+ fake_foreign_function_call(context);
+ lose("%%PRIMITIVE HALT called; the party is over.");
+
+ case trap_Error:
+ case trap_Cerror:
+ FSHOW((stderr, "<trap error/cerror %d>\n", code));
+ interrupt_internal_error(signal, info, context, code==trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ (char*)(*os_context_pc_addr(context)) -= 1;
+ handle_breakpoint(signal, info, context);
+ break;
+
+ case trap_FunEndBreakpoint:
+ (char*)(*os_context_pc_addr(context)) -= 1;
+ *os_context_pc_addr(context) =
+ (int)handle_fun_end_breakpoint(signal, info, context);
+ break;
+
+ default:
+ FSHOW((stderr,"/[C--trap default %d %d %x]\n",
+ signal, code, context));
+ interrupt_handle_now(signal, info, context);
+ break;
+ }
+}
+
+static void
+sigill_handler(int signal, siginfo_t *siginfo, void *void_context) {
+ os_context_t *context = (os_context_t*)void_context;
+ fake_foreign_function_call(context);
+ monitor_or_something();
+}
+
+void
+arch_install_interrupt_handlers()
+{
+ SHOW("entering arch_install_interrupt_handlers()");
+
+ /* Note: The old CMU CL code here used sigtrap_handler() to handle
+ * SIGILL as well as SIGTRAP. I couldn't see any reason to do
+ * things that way. So, I changed to separate handlers when
+ * debugging a problem on OpenBSD, where SBCL wasn't catching
+ * SIGILL properly, but was instead letting the process be
+ * terminated with an "Illegal instruction" output. If this change
+ * turns out to break something (maybe breakpoint handling on some
+ * OS I haven't tested on?) and we have to go back to the old CMU
+ * CL way, I hope there will at least be a comment to explain
+ * why.. -- WHN 2001-06-07 */
+ undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler);
+ undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
+
+ SHOW("returning from arch_install_interrupt_handlers()");
+}
+\f
+/* This is implemented in assembly language and called from C: */
+extern lispobj
+call_into_lisp(lispobj fun, lispobj *args, int nargs);
+
+/* These functions are an interface to the Lisp call-in facility.
+ * Since this is C we can know nothing about the calling environment.
+ * The control stack might be the C stack if called from the monitor
+ * or the Lisp stack if called as a result of an interrupt or maybe
+ * even a separate stack. The args are most likely on that stack but
+ * could be in registers depending on what the compiler likes. So we
+ * copy the args into a portable vector and let the assembly language
+ * call-in function figure it out. */
+
+lispobj
+funcall0(lispobj function)
+{
+ lispobj *args = NULL;
+
+ FSHOW((stderr, "/entering funcall0(0x%lx)\n", (long)function));
+ return call_into_lisp(function, args, 0);
+}
+lispobj
+funcall1(lispobj function, lispobj arg0)
+{
+ lispobj args[1];
+ args[0] = arg0;
+ return call_into_lisp(function, args, 1);
+}
+lispobj
+funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+ lispobj args[2];
+ args[0] = arg0;
+ args[1] = arg1;
+ return call_into_lisp(function, args, 2);
+}
+lispobj
+funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+ lispobj args[3];
+ args[0] = arg0;
+ args[1] = arg1;
+ args[2] = arg2;
+ return call_into_lisp(function, args, 3);
+}
+
+
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+/* FIXME: It might be cleaner to generate these from the lisp side of
+ * things.
+ */
+
+void
+arch_write_linkage_table_jmp(char * reloc, void * fun)
+{
+ unsigned long addr = (unsigned long) fun;
+ int i;
+
+ *reloc++ = 0xFF; /* Opcode for near jump to absolute reg/mem64. */
+ *reloc++ = 0x25; /* ModRM #b00 100 101, i.e. RIP-relative. */
+ *reloc++ = 0x00; /* 32-bit displacement field = 0 */
+ *reloc++ = 0x00; /* ... */
+ *reloc++ = 0x00; /* ... */
+ *reloc++ = 0x00; /* ... */
+
+ for (i = 0; i < 8; i++) {
+ *reloc++ = addr & 0xff;
+ addr >>= 8;
+ }
+
+ /* write a nop for good measure. */
+ *reloc = 0x90;
+}
+
+void
+arch_write_linkage_table_ref(void * reloc, void * data)
+{
+ *(unsigned long *)reloc = (unsigned long)data;
+}
+
+#endif
--- /dev/null
+/* 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 */
--- /dev/null
+/*
+ * very-low-level utilities for runtime support
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+\f
+#define LANGUAGE_ASSEMBLY
+#include "validate.h"
+#include "sbcl.h"
+#include "genesis/closure.h"
+#include "genesis/fdefn.h"
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+#include "genesis/thread.h"
+
+/* Minimize conditionalization for different OS naming schemes. */
+#if defined __linux__ || defined __FreeBSD__ /* (but *not* OpenBSD) */
+#define GNAME(var) var
+#else
+#define GNAME(var) _##var
+#endif
+
+/* Get the right type of alignment. Linux and FreeBSD (but not OpenBSD)
+ * want alignment in bytes. */
+#if defined(__linux__) || defined(__FreeBSD__)
+#define align_4byte 4
+#define align_8byte 8
+#define align_16byte 16
+#define align_32byte 32
+#else
+#define align_4byte 2
+#define align_8byte 3
+#define align_16byte 4
+#endif
+
+ .text
+ .global GNAME(foreign_function_call_active)
+ .global GNAME(all_threads)
+
+\f
+/* From lower to higher-numbered addresses, the stack contains
+ * return address, arg 0, arg 1, arg 2 ...
+ * rax contains the address of the function to call
+ * Lisp expects return value in rax, whic is already consistent with C
+ * XXXX correct floating point handling is unimplemented so far
+ * Based on comments cleaned from x86-assem.S, we believe that
+ * Lisp is expecting us to preserve rsi, rdi, rsp (no idea about r8-15)
+ */
+ .text
+ .align align_16byte,0x90
+ .global GNAME(call_into_c)
+ .type GNAME(call_into_c),@function
+GNAME(call_into_c):
+ push %rbp # Save old frame pointer.
+ mov %rsp,%rbp # Establish new frame.
+
+ push %rsi # args are going in here
+ push %rdi
+ mov 16(%rbp),%rdi
+ mov 24(%rbp),%rsi
+ mov 32(%rbp),%rdx
+ mov 40(%rbp),%rcx
+ mov 48(%rbp),%rcx
+ mov 56(%rbp),%r8
+ mov 64(%rbp),%r9
+ call *%rax
+ mov %rbp,%rsp
+ pop %rbp
+ ret
+ .size GNAME(call_into_c), . - GNAME(call_into_c)
+
+\f
+ .text
+ .global GNAME(call_into_lisp_first_time)
+ .type GNAME(call_into_lisp_first_time),@function
+
+/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when
+ * the stack changes. We don't worry too much about saving registers
+ * here, because we never expect to return from the initial call to lisp
+ * anyway */
+
+ .align align_16byte,0x90
+GNAME(call_into_lisp_first_time):
+ push %rbp # Save old frame pointer.
+ mov %rsp,%rbp # Establish new frame.
+ mov %rsp,ALIEN_STACK + SYMBOL_VALUE_OFFSET
+ mov GNAME(all_threads),%rax
+ mov THREAD_CONTROL_STACK_START_OFFSET(%rax) ,%rsp
+ /* don't think too hard about what happens if we get interrupted
+ * here */
+ add $THREAD_CONTROL_STACK_SIZE-8,%rsp
+ jmp Lstack
+\f
+ .text
+ .global GNAME(call_into_lisp)
+ .type GNAME(call_into_lisp),@function
+
+/*
+ * amd64 calling convention: C expects that
+ * arguments go in rdi rsi rdx rcx r8 r9
+ * return values in rax rdx
+ * callee saves rbp rbx r12-15 if it uses them
+ */
+
+ .align align_16byte,0x90
+GNAME(call_into_lisp):
+ push %rbp # Save old frame pointer.
+ mov %rsp,%rbp # Establish new frame.
+Lstack:
+ /* FIXME x86 saves FPU state here */
+ push %rbx
+ push %r12
+ push %r13
+ push %r14
+ push %r15
+
+
+ mov %rsp,%rbx # remember current stack
+ push %rbx # Save entry stack on (maybe) new stack.
+
+ /* Establish Lisp args. */
+ mov %rdi,%rax # lexenv?
+ mov %rsi,%rbx # address of arg vec
+ mov %rdx,%rcx # num args
+
+ xor %rdx,%rdx # clear any descriptor registers
+ xor %rdi,%rdi # that we can't be sure we'll
+ xor %rsi,%rsi # initialise properly. XX do r8-r15 too?
+ shl $3,%rcx # (fixnumize num-args)
+ cmp $0,%rcx
+ je Ldone
+ mov 0(%rbx),%rdx # arg0
+ cmp $8,%rcx
+ je Ldone
+ mov 8(%rbx),%rdi # arg1
+ cmp $16,%rcx
+ je Ldone
+ mov 16(%rbx),%rsi # arg2
+Ldone:
+ /* Registers rax, rcx, rdx, rdi, and rsi are now live. */
+ xor %rbx,%rbx # available
+
+ /* Alloc new frame. */
+ mov %rsp,%rbx # The current sp marks start of new frame.
+ push %rbp # fp in save location S0
+ sub $16,%rsp # Ensure 3 slots are allocated, one above.
+ mov %rbx,%rbp # Switch to new frame.
+
+Lcall:
+ call *CLOSURE_FUN_OFFSET(%rax)
+
+ /* If the function returned multiple values, it will return to
+ this point. Lose them */
+ mov %rbx, %rsp
+ /* A singled value function returns here */
+
+/* Restore the stack, in case there was a stack change. */
+ pop %rsp # c-sp
+
+/* Restore C regs */
+ pop %r15
+ pop %r14
+ pop %r13
+ pop %r12
+ pop %rbx
+
+/* FIXME Restore the NPX state. */
+ pop %rbp # c-sp
+ /* return value is already in rax where lisp expects it */
+ ret
+ .size GNAME(call_into_lisp), . - GNAME(call_into_lisp)
+\f
+/* support for saving and restoring the NPX state from C */
+ .text
+ .global GNAME(fpu_save)
+ .type GNAME(fpu_save),@function
+ .align 2,0x90
+GNAME(fpu_save):
+ mov 4(%rsp),%rax
+ fnsave (%rax) # Save the NPX state. (resets NPX)
+ ret
+ .size GNAME(fpu_save),.-GNAME(fpu_save)
+
+ .global GNAME(fpu_restore)
+ .type GNAME(fpu_restore),@function
+ .align 2,0x90
+GNAME(fpu_restore):
+ mov 4(%rsp),%rax
+ frstor (%rax) # Restore the NPX state.
+ ret
+ .size GNAME(fpu_restore),.-GNAME(fpu_restore)
+\f
+/*
+ * the undefined-function trampoline
+ */
+ .text
+ .align align_4byte,0x90
+ .global GNAME(undefined_tramp)
+ .type GNAME(undefined_tramp),@function
+GNAME(undefined_tramp):
+ int3
+ .byte trap_Error
+ .byte 2
+ .byte UNDEFINED_FUN_ERROR
+ .byte sc_DescriptorReg # eax in the Descriptor-reg SC
+ ret
+ .size GNAME(undefined_tramp), .-GNAME(undefined_tramp)
+
+
+ .text
+ .align align_4byte,0x90
+ .global GNAME(alloc_tramp)
+ .type GNAME(alooc_tramp),@function
+GNAME(alloc_tramp):
+ push %rbp # Save old frame pointer.
+ mov %rsp,%rbp # Establish new frame.
+ push %rax
+ push %rcx
+ push %rdx
+ push %rsi
+ push %rdi
+ push %r8
+ push %r9
+ push %r10
+ push %r11
+ mov 16(%rbp),%rdi
+ call alloc
+ mov %rax,16(%rbp)
+ pop %r11
+ pop %r10
+ pop %r9
+ pop %r8
+ pop %rdi
+ pop %rsi
+ pop %rdx
+ pop %rcx
+ pop %rax
+ pop %rbp
+ ret
+ .size GNAME(alloc_tramp),.-GNAME(alloc_tramp)
+
+
+/*
+ * the closure trampoline
+ */
+ .text
+ .align align_4byte,0x90
+ .global GNAME(closure_tramp)
+ .type GNAME(closure_tramp),@function
+GNAME(closure_tramp):
+ mov FDEFN_FUN_OFFSET(%rax),%rax
+ /* FIXME: The '*' after "jmp" in the next line is from PVE's
+ * patch posted to the CMU CL mailing list Oct 6, 1999. It looks
+ * reasonable, and it certainly seems as though if CMU CL needs it,
+ * SBCL needs it too, but I haven't actually verified that it's
+ * right. It would be good to find a way to force the flow of
+ * control through here to test it. */
+ jmp *CLOSURE_FUN_OFFSET(%rax)
+ .size GNAME(closure_tramp), .-GNAME(closure_tramp)
+
+/*
+ * fun-end breakpoint magic
+ */
+ .text
+ .global GNAME(fun_end_breakpoint_guts)
+ .align align_4byte
+GNAME(fun_end_breakpoint_guts):
+ /* Multiple Value return */
+ jmp multiple_value_return
+ /* Single value return: The eventual return will now use the
+ multiple values return convention but with a return values
+ count of one. */
+ mov %rsp,%rbx # Setup ebx - the ofp.
+ sub $4,%rsp # Allocate one stack slot for the return value
+ mov $4,%rcx # Setup ecx for one return value.
+ mov $NIL,%rdi # default second value
+ mov $NIL,%rsi # default third value
+
+multiple_value_return:
+
+ .global GNAME(fun_end_breakpoint_trap)
+GNAME(fun_end_breakpoint_trap):
+ int3
+ .byte trap_FunEndBreakpoint
+ hlt # We should never return here.
+
+ .global GNAME(fun_end_breakpoint_end)
+GNAME(fun_end_breakpoint_end):
+
+\f
+ .global GNAME(do_pending_interrupt)
+ .type GNAME(do_pending_interrupt),@function
+ .align align_4byte,0x90
+GNAME(do_pending_interrupt):
+ int3
+ .byte trap_PendingInterrupt
+ ret
+ .size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt)
+\f
+#ifdef LISP_FEATURE_GENCGC
+/* This is a fast bzero using the FPU. The first argument is the start
+ * address which needs to be aligned on an 8 byte boundary, the second
+ * argument is the number of bytes, which must be a nonzero multiple
+ * of 8 bytes. */
+/* FIXME whether this is still faster than using the OS's bzero or
+ * equivalent, we don't know */
+ .text
+ .globl GNAME(i586_bzero)
+ .type GNAME(i586_bzero),@function
+ .align align_4byte,0x90
+GNAME(i586_bzero):
+ mov 4(%rsp),%rdx # Load the start address.
+ mov 8(%rsp),%rax # Load the number of bytes.
+ fldz
+l1: fstl 0(%rdx)
+ add $8,%rdx
+ sub $8,%rax
+ jnz l1
+ fstp %st(0)
+ ret
+ .size GNAME(i586_bzero),.-GNAME(i586_bzero)
+#endif
+\f
+
+
+ .end
--- /dev/null
+/*
+ * The x86 Linux incarnation of arch-dependent OS-dependent routines.
+ * See also "linux-os.c".
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdio.h>
+#include <stddef.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
+#include <errno.h>
+
+#define __USE_GNU
+#include <sys/ucontext.h>
+#undef __USE_GNU
+
+
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <asm/ldt.h>
+#include <linux/unistd.h>
+#include <sys/mman.h>
+#include <linux/version.h>
+#include "thread.h" /* dynamic_values_bytes */
+
+#if LINUX_VERSION_CODE < KERNEL_VERSION(2,6,0)
+#define user_desc modify_ldt_ldt_s
+#endif
+
+_syscall3(int, modify_ldt, int, func, void *, ptr, unsigned long, bytecount );
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+u32 local_ldt_copy[LDT_ENTRIES*LDT_ENTRY_SIZE/sizeof(u32)];
+
+/* This is never actually called, but it's great for calling from gdb when
+ * users have thread-related problems that maintainers can't duplicate */
+
+void debug_get_ldt()
+{
+ int n=modify_ldt (0, local_ldt_copy, sizeof local_ldt_copy);
+ printf("%d bytes in ldt: print/x local_ldt_copy\n", n);
+}
+
+lispobj modify_ldt_lock; /* protect all calls to modify_ldt */
+
+int arch_os_thread_init(struct thread *thread) {
+ stack_t sigstack;
+#ifdef LISP_FEATURE_SB_THREAD
+ /* this must be called from a function that has an exclusive lock
+ * on all_threads
+ */
+ struct user_desc ldt_entry = {
+ 1, 0, 0, /* index, address, length filled in later */
+ 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1
+ };
+ int n;
+ get_spinlock(&modify_ldt_lock,thread);
+ n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy);
+ /* get next free ldt entry */
+
+ if(n) {
+ u32 *p;
+ for(n=0,p=local_ldt_copy;*p;p+=LDT_ENTRY_SIZE/sizeof(u32))
+ n++;
+ }
+ ldt_entry.entry_number=n;
+ ldt_entry.base_addr=(unsigned long) thread;
+ ldt_entry.limit=dynamic_values_bytes;
+ ldt_entry.limit_in_pages=0;
+ if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) {
+ modify_ldt_lock=0;
+ /* modify_ldt call failed: something magical is not happening */
+ return -1;
+ }
+ __asm__ __volatile__ ("movw %w0, %%fs" : : "q"
+ ((n << 3) /* selector number */
+ + (1 << 2) /* TI set = LDT */
+ + 3)); /* privilege level */
+ thread->tls_cookie=n;
+ modify_ldt_lock=0;
+
+ if(n<0) return 0;
+#endif
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ /* Signal handlers are run on the control stack, so if it is exhausted
+ * we had better use an alternate stack for whatever signal tells us
+ * we've exhausted it */
+ sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
+ sigstack.ss_flags=0;
+ sigstack.ss_size = 32*SIGSTKSZ;
+ sigaltstack(&sigstack,0);
+#endif
+ return 1;
+}
+
+struct thread *debug_get_fs() {
+ register u32 fs;
+ __asm__ __volatile__ ("movl %%fs,%0" : "=r" (fs) : );
+ return fs;
+}
+
+/* free any arch/os-specific resources used by thread, which is now
+ * defunct. Not called on live threads
+ */
+
+int arch_os_thread_cleanup(struct thread *thread) {
+ struct user_desc ldt_entry = {
+ 0, 0, 0,
+ 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0
+ };
+
+ ldt_entry.entry_number=thread->tls_cookie;
+ get_spinlock(&modify_ldt_lock,thread);
+ if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) {
+ modify_ldt_lock=0;
+ /* modify_ldt call failed: something magical is not happening */
+ return 0;
+ }
+ modify_ldt_lock=0;
+ return 1;
+}
+
+
+os_context_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+#define RCASE(name) case reg_ ## name: return &context->uc_mcontext.gregs[REG_ ## name];
+ switch(offset) {
+ RCASE(RAX)
+ RCASE(RCX)
+ RCASE(RDX)
+ RCASE(RBX)
+ RCASE(RSP)
+ RCASE(RBP)
+ RCASE(RSI)
+ RCASE(RDI)
+ RCASE(R8)
+ RCASE(R9)
+ RCASE(R10)
+ RCASE(R11)
+ RCASE(R12)
+ RCASE(R13)
+ RCASE(R14)
+ RCASE(R15)
+ default:
+ if(offset<NGREG)
+ return &context->uc_mcontext.gregs[offset/2+4];
+ else return 0;
+ }
+ return &context->uc_mcontext.gregs[offset];
+}
+
+os_context_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[REG_RIP]; /* REG_EIP */
+}
+
+os_context_register_t *
+os_context_sp_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[REG_RSP];
+}
+
+os_context_register_t *
+os_context_fp_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[REG_RBP];
+}
+
+unsigned long
+os_context_fp_control(os_context_t *context)
+{
+#if 0
+ return ((((context->uc_mcontext.fpregs->cw) & 0xffff) ^ 0x3f) |
+ (((context->uc_mcontext.fpregs->sw) & 0xffff) << 16));
+#else
+ return 0;
+#endif
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &context->uc_sigmask;
+}
+
+void
+os_restore_fp_control(os_context_t *context)
+{
+#if 0
+ asm ("fldcw %0" : : "m" (context->uc_mcontext.fpregs->cw));
+#endif
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
+
--- /dev/null
+#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 */
--- /dev/null
+/*
+ * 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 \
+}
((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))))
(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)
\f
;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
(defvar *compiler-note-count* 0)
-#-alpha ; FIXME: make a better test!
+#-(or alpha x86-64) ; FIXME: make a better test!
(handler-bind ((sb-ext:compiler-note (lambda (c)
(declare (ignore c))
(incf *compiler-note-count*))))
(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)))
(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,
(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
#endif
.text"
-#!+x86 "
+#!+(or x86 x86-64) "
#define LDSO_STUBIFY(fct) \\
.align 16 ; \\
.globl ldso_stub__ ## fct ; \\
;;; 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"
projects / sbcl.git / commitdiff