common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.8.18.14:

Browse source 
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.
This commit is contained in:
Christophe Rhodes 2005-01-06 12:47:55 +00:00
parent 77d94d36bc
commit 78fa16bf55
104 changed files with 5360 additions and 4237 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
CREDITS
View file

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

86
contrib/sb-bsd-sockets/constants.lisp
View file

@ -133,62 +133,62 @@
(integer type "int" "h_addrtype")
(integer length "int" "h_length")
((* (* (unsigned 8))) addresses "char **" "h_addr_list")))
(:function socket ("socket" integer
(domain integer)
(type integer)
(protocol integer)))
(:function bind ("bind" integer
(sockfd integer)
(:function socket ("socket" int
(domain int)
(type int)
(protocol int)))
(:function bind ("bind" int
(sockfd int)
(my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(addrlen integer)))
(:function listen ("listen" integer
(socket integer)
(backlog integer)))
(:function accept ("accept" integer
(socket integer)
(addrlen int)))
(:function listen ("listen" int
(socket int)
(backlog int)))
(:function accept ("accept" int
(socket int)
(my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(addrlen integer :in-out)))
(:function getpeername ("getpeername" integer
(socket integer)
(addrlen int :in-out)))
(:function getpeername ("getpeername" int
(socket int)
(her-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(addrlen integer :in-out)))
(:function getsockname ("getsockname" integer
(socket integer)
(addrlen int :in-out)))
(:function getsockname ("getsockname" int
(socket int)
(my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(addrlen integer :in-out)))
(:function connect ("connect" integer
(socket integer)
(addrlen int :in-out)))
(:function connect ("connect" int
(socket int)
(his-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(addrlen integer )))
(addrlen int )))
(:function close ("close" integer
(fd integer)))
(:function recvfrom ("recvfrom" integer
(socket integer)
(:function close ("close" int
(fd int)))
(:function recvfrom ("recvfrom" int
(socket int)
(buf (* t))
(len integer)
(flags integer)
(flags int)
(sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un?
(socklen (* socklen-t))))
(:function gethostbyname ("gethostbyname" (* hostent) (name c-string)))
(:function gethostbyaddr ("gethostbyaddr" (* hostent)
(addr (* t))
(len integer)
(af integer)))
(:function setsockopt ("setsockopt" integer
(socket integer)
(level integer)
(optname integer)
(len int)
(af int)))
(:function setsockopt ("setsockopt" int
(socket int)
(level int)
(optname int)
(optval (* t))
(optlen integer)))
(:function fcntl ("fcntl" integer
(fd integer)
(cmd integer)
(arg integer)))
(:function getsockopt ("getsockopt" integer
(socket integer)
(level integer)
(optname integer)
(optlen int)))
(:function fcntl ("fcntl" int
(fd int)
(cmd int)
(arg long)))
(:function getsockopt ("getsockopt" int
(socket int)
(level int)
(optname int)
(optval (* t))
(optlen (* integer)))))
(optlen (* int)))))
)

8
contrib/sb-bsd-sockets/sockopt.lisp
View file

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

4
contrib/sb-posix/interface.lisp
View file

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

10
contrib/sb-posix/posix-tests.lisp
View file

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

10
contrib/sb-sprof/sb-sprof.lisp
View file

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

5
make-config.sh
View file

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

16
package-data-list.lisp-expr
View file

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

59
src/assembly/x86-64/alloc.lisp Normal file
View file

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

303
src/assembly/x86-64/arith.lisp Normal file
View file

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

39
src/assembly/x86-64/array.lisp Normal file
View file

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

263
src/assembly/x86-64/assem-rtns.lisp Normal file
View file

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

12
src/assembly/x86-64/bit-bash.lisp Normal file
View file

@ -0,0 +1,12 @@
;;;; just a dummy file to maintain parallelism with other VMs
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")

46
src/assembly/x86-64/support.lisp Normal file
View file

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

21
src/code/bignum.lisp
View file

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

17
src/code/bit-bash.lisp
View file

@ -109,24 +109,27 @@
(type index offset)
(values system-area-pointer index))
(let ((address (sap-int sap)))
(values (int-sap #!-alpha (word-logical-andc2 address 3)
(values (int-sap #!-alpha (word-logical-andc2 address
sb!vm::fixnum-tag-mask)
#!+alpha (ash (ash address -2) 2))
(+ (* (logand address 3) n-byte-bits) offset))))
(+ (* (logand address sb!vm::fixnum-tag-mask) n-byte-bits)
offset))))
#!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
(defun word-sap-ref (sap offset)
(declare (type system-area-pointer sap)
(type index offset)
(values (unsigned-byte 32))
(values sb!vm:word)
(optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
(sap-ref-32 sap (the index (ash offset 2))))
(sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits))))
(defun %set-word-sap-ref (sap offset value)
(declare (type system-area-pointer sap)
(type index offset)
(type (unsigned-byte 32) value)
(values (unsigned-byte 32))
(type sb!vm:word value)
(values sb!vm:word)
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setf (sap-ref-32 sap (the index (ash offset 2))) value))
(setf (sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits)))
value))
;;;; CONSTANT-BIT-BASH

4
src/code/cold-init.lisp
View file

@ -184,10 +184,10 @@
(setf (svref *!load-time-values* (third toplevel-thing))
(funcall (second toplevel-thing))))
(:load-time-value-fixup
(setf (sap-ref-32 (second toplevel-thing) 0)
(setf (sap-ref-word (second toplevel-thing) 0)
(get-lisp-obj-address
(svref *!load-time-values* (third toplevel-thing)))))
#!+(and x86 gencgc)
#!+(and (or x86 x86-64) gencgc)
(:load-time-code-fixup
(sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
(third toplevel-thing)

4
src/code/cross-misc.lisp
View file

@ -145,10 +145,10 @@
(assert (typep array '(simple-array * (*))))
(values array start end 0))
#!-alpha
#!-(or alpha x86-64)
(defun sb!vm::ash-left-mod32 (integer amount)
(ldb (byte 32 0) (ash integer amount)))
#!+alpha
#!+(or alpha x86-64)
(defun sb!vm::ash-left-mod64 (integer amount)
(ldb (byte 64 0) (ash integer amount)))

6
src/code/cross-sap.lisp
View file

@ -54,9 +54,13 @@
'(sap-ref-8
sap-ref-16
sap-ref-32
sap-ref-64
sap-ref-sap
sap-ref-word
sap-ref-single
sap-ref-double
signed-sap-ref-8
signed-sap-ref-16
signed-sap-ref-32)))
signed-sap-ref-32
signed-sap-ref-64
signed-sap-ref-word)))

117
src/code/debug-int.lisp
View file

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

8
src/code/defsetfs.lisp
View file

@ -41,12 +41,10 @@
(defsetf %instance-ref %instance-set)
(defsetf %raw-ref-single %raw-set-single)
(defsetf %raw-ref-double %raw-set-double)
#!+long-float
(defsetf %raw-ref-long %raw-set-long)
(defsetf %raw-ref-complex-single %raw-set-complex-single)
(defsetf %raw-ref-complex-double %raw-set-complex-double)
#!+long-float
(defsetf %raw-ref-complex-long %raw-set-complex-long)
(defsetf %instance-layout %set-instance-layout)
(defsetf %funcallable-instance-info %set-funcallable-instance-info)
@ -118,6 +116,8 @@
(defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
(defsetf sap-ref-64 %set-sap-ref-64)
(defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
(defsetf sap-ref-word %set-sap-ref-word)
(defsetf signed-sap-ref-word %set-signed-sap-ref-word)
(defsetf sap-ref-sap %set-sap-ref-sap)
(defsetf sap-ref-single %set-sap-ref-single)
(defsetf sap-ref-double %set-sap-ref-double)

9
src/code/defstruct.lisp
View file

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

10
src/code/fop.lisp
View file

@ -89,11 +89,11 @@
#+sb-xc-host (bug "READ-STRING-AS-WORDS called")
(dotimes (i length)
(setf (aref string i)
(sb!xc:code-char (logior
(read-byte stream)
(ash (read-byte stream) 8)
(ash (read-byte stream) 16)
(ash (read-byte stream) 24)))))
(let ((code 0))
;; FIXME: is this the same as READ-WORD-ARG?
(dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
(setf code (logior code (ash (read-byte stream)
(* k sb!vm:n-byte-bits))))))))
(values))
;;;; miscellaneous fops

3
src/code/foreign.lisp
View file

@ -52,8 +52,7 @@
;; If the address is from linkage-table and refers to data
;; we need to do a bit of juggling.
(if (and sharedp datap)
;; FIXME: 64bit badness here
(int-sap (sap-ref-32 (int-sap addr) 0))
(int-sap (sap-ref-word (int-sap addr) 0))
(int-sap addr)))))
#-sb-xc-host

9
src/code/hash-table.lisp
View file

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

13
src/code/kernel.lisp
View file

@ -125,17 +125,8 @@
(defun make-single-float (x) (make-single-float x))
(defun make-double-float (hi lo) (make-double-float hi lo))
#!+long-float
(defun make-long-float (exp hi #!+sparc mid lo)
(make-long-float exp hi #!+sparc mid lo))
(defun single-float-bits (x) (single-float-bits x))
(defun double-float-high-bits (x) (double-float-high-bits x))
(defun double-float-low-bits (x) (double-float-low-bits x))
#!+long-float
(defun long-float-exp-bits (x) (long-float-exp-bits x))
#!+long-float
(defun long-float-high-bits (x) (long-float-high-bits x))
#!+(and long-float sparc)
(defun long-float-mid-bits (x) (long-float-mid-bits x))
#!+long-float
(defun long-float-low-bits (x) (long-float-low-bits x))

4
src/code/numbers.lisp
View file

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

26
src/code/room.lisp
View file

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

11
src/code/run-program.lisp
View file

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

4
src/code/target-c-call.lisp
View file

@ -22,12 +22,12 @@
(define-alien-type char (integer 8))
(define-alien-type short (integer 16))
(define-alien-type int (integer 32))
(define-alien-type long (integer #!-alpha 32 #!+alpha 64))
(define-alien-type long (integer #.sb!vm::n-machine-word-bits))
(define-alien-type unsigned-char (unsigned 8))
(define-alien-type unsigned-short (unsigned 16))
(define-alien-type unsigned-int (unsigned 32))
(define-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64))
(define-alien-type unsigned-long (unsigned #.sb!vm::n-machine-word-bits))
(define-alien-type float single-float)
(define-alien-type double double-float)

4
src/code/target-defstruct.lisp
View file

@ -395,8 +395,8 @@
(when raw-index
(let* ((data (%instance-ref structure raw-index))
(raw-len (length data))
(new (make-array raw-len :element-type '(unsigned-byte 32))))
(declare (type (simple-array (unsigned-byte 32) (*)) data))
(new (make-array raw-len :element-type 'sb!vm::word)))
(declare (type (simple-array sb!vm::word (*)) data))
(setf (%instance-ref res raw-index) new)
(dotimes (i raw-len)
(setf (aref new i) (aref data i))))))

14
src/code/target-hash-table.lisp
View file

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

3
src/code/target-random.lisp
View file

@ -202,8 +202,7 @@
(* arg
(- (sb!impl::make-double-float
(dpb (ash (random-chunk state)
(- sb!vm:double-float-digits random-chunk-length
sb!vm:n-word-bits))
(- sb!vm:double-float-digits random-chunk-length 32))
sb!vm:double-float-significand-byte
(sb!impl::double-float-high-bits 1d0))
(random-chunk state))

24
src/code/target-sap.lisp
View file

@ -83,6 +83,12 @@
(fixnum offset))
(sap-ref-64 sap offset))
;;; Return the unsigned word of natural size OFFSET bytes from SAP.
(defun sap-ref-word (sap offset)
(declare (type system-area-pointer sap)
(fixnum offset))
(sap-ref-word sap offset))
;;; Return the 32-bit SAP at OFFSET bytes from SAP.
(defun sap-ref-sap (sap offset)
(declare (type system-area-pointer sap)
@ -132,6 +138,12 @@
(fixnum offset))
(signed-sap-ref-64 sap offset))
;;; Return the signed word of natural size OFFSET bytes from SAP.
(defun signed-sap-ref-word (sap offset)
(declare (type system-area-pointer sap)
(fixnum offset))
(signed-sap-ref-word sap offset))
(defun %set-sap-ref-8 (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
@ -156,6 +168,12 @@
(type (unsigned-byte 64) new-value))
(setf (sap-ref-64 sap offset) new-value))
(defun %set-sap-ref-word (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
(type (unsigned-byte #.sb!vm:n-machine-word-bits) new-value))
(setf (sap-ref-word sap offset) new-value))
(defun %set-signed-sap-ref-8 (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
@ -180,6 +198,12 @@
(type (signed-byte 64) new-value))
(setf (signed-sap-ref-64 sap offset) new-value))
(defun %set-signed-sap-ref-word (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
(type (signed-byte #.sb!vm:n-machine-word-bits) new-value))
(setf (signed-sap-ref-word sap offset) new-value))
(defun %set-sap-ref-sap (sap offset new-value)
(declare (type system-area-pointer sap new-value)
(fixnum offset))

36
src/code/target-sxhash.lisp
View file

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

12
src/code/target-thread.lisp
View file

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

4
src/code/target-unithread.lisp
View file

@ -16,11 +16,11 @@
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n 4)))
(* n sb!vm:n-word-bytes)))
(defun current-thread-id ()
(sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t)))
(* sb!vm::thread-pid-slot 4)))
(* sb!vm::thread-pid-slot sb!vm:n-word-bytes)))
(defun reap-dead-threads ())

10
src/code/toplevel.lisp
View file

@ -196,7 +196,7 @@ steppers to maintain contextual information.")
((= offset bytes-per-scrub-unit)
(look (sap+ ptr bytes-per-scrub-unit) 0 count))
(t
(setf (sap-ref-32 ptr offset) 0)
(setf (sap-ref-word ptr offset) 0)
(scrub ptr (+ offset sb!vm:n-word-bytes) count))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
@ -206,11 +206,11 @@ steppers to maintain contextual information.")
(cond ((>= (sap-int ptr) end-of-stack) 0)
((= offset bytes-per-scrub-unit)
count)
((zerop (sap-ref-32 ptr offset))
((zerop (sap-ref-word ptr offset))
(look ptr (+ offset sb!vm:n-word-bytes) count))
(t
(scrub ptr offset (+ count sb!vm:n-word-bytes))))))
(declare (type (unsigned-byte 32) csp))
(declare (type sb!vm::word csp))
(scrub (int-sap (- csp initial-offset))
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0)))
@ -232,7 +232,7 @@ steppers to maintain contextual information.")
(look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
0 count))
(t ;; need to fix bug in %SET-STACK-REF
(setf (sap-ref-32 loc 0) 0)
(setf (sap-ref-word loc 0) 0)
(scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
@ -247,7 +247,7 @@ steppers to maintain contextual information.")
(look ptr (+ offset sb!vm:n-word-bytes) count))
(t
(scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
(declare (type (unsigned-byte 32) csp))
(declare (type sb!vm::word csp))
(scrub (int-sap (+ csp initial-offset))
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0))))

341
src/code/x86-64-vm.lisp Normal file
View file

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

14
src/compiler/aliencomp.lisp
View file

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

16
src/compiler/disassem.lisp
View file

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

2
src/compiler/generic/core.lisp
View file

@ -64,7 +64,7 @@
(:foreign-dataref
(aver (stringp name))
(foreign-symbol-address-as-integer name t))
#!+x86
#!+(or x86 x86-64)
(:code-object
(aver (null name))
(values (get-lisp-obj-address code) t)))))

4
src/compiler/generic/early-objdef.lisp
View file

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

82
src/compiler/generic/genesis.lisp
View file

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

26
src/compiler/generic/objdef.lisp
View file

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

126
src/compiler/generic/primtype.lisp
View file

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

4
src/compiler/generic/vm-fndb.lisp
View file

@ -54,9 +54,9 @@
simple-array-complex-double-float-p
#!+long-float simple-array-complex-long-float-p
system-area-pointer-p realp
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
;; #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
unsigned-byte-32-p
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
;; #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
signed-byte-32-p
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
unsigned-byte-64-p

4
src/compiler/pack.lisp
View file

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

36
src/compiler/saptran.lisp
View file

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

82
src/compiler/target-disassem.lisp
View file

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

2
src/compiler/x86-64/alloc.lisp
View file

@ -172,7 +172,7 @@
(inst lea bytes
(make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
(inst mov header bytes)
(inst shl header (- n-widetag-bits 2)) ; w+1 to length field
(inst shl header (- n-widetag-bits 3)) ; w+1 to length field
(inst lea header ; (w-1 << 8) | type
(make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
(inst and bytes (lognot lowtag-mask))

25
src/compiler/x86-64/arith.lisp
View file

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

713
src/compiler/x86-64/array.lisp
View file

File diff suppressed because it is too large Load diff

2
src/compiler/x86-64/backend-parms.lisp
View file

@ -17,7 +17,7 @@
;;;; compiler constants
(def!constant +backend-fasl-file-implementation+ :x86)
(def!constant +backend-fasl-file-implementation+ :x86-64)
(setf *backend-register-save-penalty* 3)

145
src/compiler/x86-64/c-call.lisp
View file

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

33
src/compiler/x86-64/call.lisp
View file

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

37
src/compiler/x86-64/cell.lisp
View file

@ -24,31 +24,28 @@
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg immediate)))
(:temporary (:sc descriptor-reg) temp)
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(if (sc-is value immediate)
(if (sc-is value immediate)
(let ((val (tn-value value)))
(etypecase val
(integer
(inst mov
(make-ea :dword :base object
:disp (- (* offset n-word-bytes) lowtag))
(fixnumize val)))
(symbol
(inst mov
(make-ea :dword :base object
:disp (- (* offset n-word-bytes) lowtag))
(+ nil-value (static-symbol-offset val))))
(character
(inst mov
(make-ea :dword :base object
:disp (- (* offset n-word-bytes) lowtag))
(logior (ash (char-code val) n-widetag-bits)
base-char-widetag)))))
;; Else, value not immediate.
(storew value object offset lowtag))))
(move-immediate (make-ea :qword
:base object
:disp (- (* offset n-word-bytes)
lowtag))
(etypecase val
(integer
(fixnumize val))
(symbol
(+ nil-value (static-symbol-offset val)))
(character
(logior (ash (char-code val) n-widetag-bits)
character-widetag)))
temp))
;; Else, value not immediate.
(storew value object offset lowtag))))

169
src/compiler/x86-64/char.lisp
View file

@ -14,89 +14,130 @@
;;;; moves and coercions
;;; Move a tagged char to an untagged representation.
(define-vop (move-to-base-char)
(:args (x :scs (any-reg control-stack) :target al))
(:temporary (:sc byte-reg :offset al-offset
:from (:argument 0) :to (:eval 0)) al)
(:ignore al)
(:temporary (:sc byte-reg :offset ah-offset :target y
:from (:argument 0) :to (:result 0)) ah)
(:results (y :scs (base-char-reg base-char-stack)))
#!+sb-unicode
(define-vop (move-to-character)
(:args (x :scs (any-reg descriptor-reg) :target y
:load-if (not (location= x y))))
(:results (y :scs (character-reg)
:load-if (not (location= x y))))
(:note "character untagging")
(:generator 1
(move rax-tn x)
(move y ah)))
(define-move-vop move-to-base-char :move
(any-reg control-stack) (base-char-reg base-char-stack))
(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
(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
(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))
(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 (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 base-char values.
(define-vop (base-char-move)
;;; 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))
;; 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 base-char
;;; Use standard MOVE-ARG + coercion to move an untagged character
;;; to a descriptor passing location.
(define-move-vop move-arg :move-arg
(base-char-reg) (any-reg descriptor-reg))
(character-reg) (any-reg descriptor-reg))
;;;; other operations
(define-vop (char-code)
(:translate char-code)
(:policy :fast-safe)
(:args (ch :scs (base-char-reg base-char-stack)))
(:arg-types base-char)
(:args (ch :scs (character-reg character-stack)))
(:arg-types character)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
(inst movzx res ch)))
#!-sb-unicode
(inst movzx res ch)
#!+sb-unicode
(inst mov res ch)))
#!+sb-unicode
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
(:args (code :scs (unsigned-reg unsigned-stack)))
(:arg-types positive-fixnum)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
(inst mov res code)))
#!-sb-unicode
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
@ -105,19 +146,19 @@
(:temporary (:sc unsigned-reg :offset rax-offset :target res
:from (:argument 0) :to (:result 0))
eax)
(:results (res :scs (base-char-reg)))
(:result-types base-char)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
(move eax code)
(move res al-tn)))
;;; comparison of BASE-CHARs
(define-vop (base-char-compare)
(:args (x :scs (base-char-reg base-char-stack))
(y :scs (base-char-reg)
:load-if (not (and (sc-is x base-char-reg)
(sc-is y base-char-stack)))))
(:arg-types base-char base-char)
;;; comparison of CHARACTERs
(define-vop (character-compare)
(:args (x :scs (character-reg character-stack))
(y :scs (character-reg)
:load-if (not (and (sc-is x character-reg)
(sc-is y character-stack)))))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
@ -127,21 +168,21 @@
(inst cmp x y)
(inst jmp (if not-p not-condition condition) target)))
(define-vop (fast-char=/base-char base-char-compare)
(define-vop (fast-char=/character character-compare)
(:translate char=)
(:variant :e :ne))
(define-vop (fast-char</base-char base-char-compare)
(define-vop (fast-char</character character-compare)
(:translate char<)
(:variant :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)
@ -151,14 +192,14 @@
(inst cmp x (sb!xc:char-code y))
(inst jmp (if not-p not-condition condition) target)))
(define-vop (fast-char=/base-char/c base-char-compare/c)
(define-vop (fast-char=/character/c character-compare/c)
(:translate char=)
(:variant :e :ne))
(define-vop (fast-char</base-char/c base-char-compare/c)
(define-vop (fast-char</character/c character-compare/c)
(:translate char<)
(:variant :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))

2418
src/compiler/x86-64/float.lisp
View file

File diff suppressed because it is too large Load diff

828
src/compiler/x86-64/insts.lisp
View file

File diff suppressed because it is too large Load diff

68
src/compiler/x86-64/macros.lisp
View file

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

30
src/compiler/x86-64/memory.lisp
View file

@ -95,28 +95,24 @@
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg immediate)))
(:temporary (:sc unsigned-reg) temp)
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(if (sc-is value immediate)
(let ((val (tn-value value)))
(etypecase val
(integer
(inst mov
(make-ea :dword :base object
:disp (- (* (+ base offset) n-word-bytes) lowtag))
(fixnumize val)))
(symbol
(inst mov
(make-ea :dword :base object
:disp (- (* (+ base offset) n-word-bytes) lowtag))
(+ nil-value (static-symbol-offset val))))
(character
(inst mov
(make-ea :dword :base object
:disp (- (* (+ base offset) n-word-bytes) lowtag))
(logior (ash (char-code val) n-widetag-bits)
base-char-widetag)))))
(move-immediate (make-ea :qword :base object
:disp (- (* (+ base offset) n-word-bytes)
lowtag))
(etypecase val
(integer
(fixnumize val))
(symbol
(+ nil-value (static-symbol-offset val)))
(character
(logior (ash (char-code val) n-widetag-bits)
character-widetag)))
temp))
;; Else, value not immediate.
(storew value object (+ base offset) lowtag))))

77
src/compiler/x86-64/move.lisp
View file

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

10
src/compiler/x86-64/nlx.lisp
View file

@ -79,8 +79,8 @@
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew rbp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)))
(inst lea temp (make-fixup nil :code-object entry-label))
(storew temp block catch-block-entry-pc-slot)))
;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
;;; tag, and link the block into the CURRENT-CATCH list
@ -95,8 +95,8 @@
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew rbp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)
(inst lea temp (make-fixup nil :code-object entry-label))
(storew temp block catch-block-entry-pc-slot)
(storew tag block catch-block-tag-slot)
(load-tl-symbol-value temp *current-catch-block*)
(storew temp block catch-block-previous-catch-slot)
@ -211,7 +211,7 @@
;; Copy them down.
(inst std)
(inst rep)
(inst movs :dword)
(inst movs :qword)
DONE
;; Reset the CSP at last moved arg.

18
src/compiler/x86-64/parms.lisp
View file

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

21
src/compiler/x86-64/pred.lisp
View file

@ -33,6 +33,7 @@
(y :scs (any-reg descriptor-reg immediate)
:load-if (not (and (sc-is x any-reg descriptor-reg immediate)
(sc-is y control-stack constant)))))
(:temporary (:sc descriptor-reg) temp)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
@ -45,12 +46,18 @@
(integer
(if (and (zerop val) (sc-is x any-reg descriptor-reg))
(inst test x x) ; smaller
(inst cmp x (fixnumize val))))
(let ((fixnumized (fixnumize val)))
(if (typep fixnumized
'(or (signed-byte 32) (unsigned-byte 31)))
(inst cmp x fixnumized)
(progn
(inst mov temp fixnumized)
(inst cmp x temp))))))
(symbol
(inst cmp x (+ nil-value (static-symbol-offset val))))
(character
(inst cmp x (logior (ash (char-code val) n-widetag-bits)
base-char-widetag))))))
character-widetag))))))
((sc-is x immediate) ; and y not immediate
;; Swap the order to fit the compare instruction.
(let ((val (tn-value x)))
@ -58,12 +65,18 @@
(integer
(if (and (zerop val) (sc-is y any-reg descriptor-reg))
(inst test y y) ; smaller
(inst cmp y (fixnumize val))))
(let ((fixnumized (fixnumize val)))
(if (typep fixnumized
'(or (signed-byte 32) (unsigned-byte 31)))
(inst cmp y fixnumized)
(progn
(inst mov temp fixnumized)
(inst cmp y temp))))))
(symbol
(inst cmp y (+ nil-value (static-symbol-offset val))))
(character
(inst cmp y (logior (ash (char-code val) n-widetag-bits)
base-char-widetag))))))
character-widetag))))))
(t
(inst cmp x y)))

18
src/compiler/x86-64/sap.lisp
View file

@ -112,6 +112,7 @@
(:results (res :scs (sap-reg) :from (:argument 0)
:load-if (not (location= ptr res))))
(:result-types system-area-pointer)
(:temporary (:sc signed-reg) temp)
(:policy :fast-safe)
(:generator 1
(cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
@ -120,15 +121,26 @@
(signed-reg
(inst lea res (make-ea :qword :base ptr :index offset :scale 1)))
(immediate
(inst lea res (make-ea :qword :base ptr
:disp (tn-value offset))))))
(let ((value (tn-value offset)))
(cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
(inst lea res (make-ea :qword :base ptr :disp value)))
(t
(inst mov temp value)
(inst lea res (make-ea :qword :base ptr
:index temp
:scale 1))))))))
(t
(move res ptr)
(sc-case offset
(signed-reg
(inst add res offset))
(immediate
(inst add res (tn-value offset))))))))
(let ((value (tn-value offset)))
(cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
(inst add res (tn-value offset)))
(t
(inst mov temp value)
(inst add res temp))))))))))
(define-vop (pointer-)
(:translate sap-)

7
src/compiler/x86-64/show.lisp
View file

@ -22,11 +22,16 @@
:from :eval
:to (:result 0))
rax)
(:temporary (:sc unsigned-reg) call-target)
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:generator 100
(inst push object)
(inst lea rax (make-fixup (extern-alien-name "debug_print") :foreign))
(inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
(inst lea call-target
(make-ea :qword
:disp (make-fixup (extern-alien-name "call_into_c")
:foreign)))
(inst call call-target)
(inst add rsp-tn n-word-bytes)
(move result rax)))

12
src/compiler/x86-64/static-fn.lisp
View file

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

4
src/compiler/x86-64/system.lisp
View file

@ -121,7 +121,7 @@
:from (:argument 1) :to (:result 0)) eax)
(:generator 6
(move eax data)
(inst shl eax (- n-widetag-bits 2))
(inst shl eax (- n-widetag-bits n-fixnum-tag-bits))
(inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
(storew eax x 0 other-pointer-lowtag)
(move res x)))
@ -142,7 +142,7 @@
(:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
(:generator 2
(move res val)
(inst shl res (- n-widetag-bits 2))
(inst shl res (- n-widetag-bits n-fixnum-tag-bits))
(inst or res (sc-case type
(unsigned-reg type)
(immediate (tn-value type))))))

181
src/compiler/x86-64/type-vops.lisp
View file

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

29
src/compiler/x86-64/values.lisp
View file

@ -16,6 +16,35 @@
(:generator 1
(move rsp-tn ptr)))
(define-vop (%%nip-values)
(:args (last-nipped-ptr :scs (any-reg) :target rdi)
(last-preserved-ptr :scs (any-reg) :target rsi)
(moved-ptrs :scs (any-reg) :more t))
(:results (r-moved-ptrs :scs (any-reg) :more t)
;; same as MOVED-PTRS
)
(:temporary (:sc any-reg :offset rsi-offset) rsi)
(:temporary (:sc any-reg :offset rdi-offset) rdi)
(:ignore r-moved-ptrs)
(:generator 1
(move rdi last-nipped-ptr)
(move rsi last-preserved-ptr)
(inst sub rsi n-word-bytes)
(inst sub rdi n-word-bytes)
(inst cmp rsp-tn rsi)
(inst jmp :a done)
(inst std)
LOOP
(inst movs :qword)
(inst cmp rsp-tn rsi)
(inst jmp :be loop)
DONE
(inst lea rsp-tn (make-ea :qword :base rdi :disp n-word-bytes))
(inst sub rdi rsi)
(loop for moved = moved-ptrs then (tn-ref-across moved)
while moved
do (inst add (tn-ref-tn moved) rdi))))
;;; Push some values onto the stack, returning the start and number of values
;;; pushed as results. It is assumed that the Vals are wired to the standard
;;; argument locations. Nvals is the number of values to push.

148
src/compiler/x86-64/vm.lisp
View file

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

322
src/compiler/x86/array.lisp
View file

@ -503,122 +503,7 @@
(inst fstd result))
(inst fxch value)))))))
#!+long-float
(define-vop (data-vector-ref/simple-array-long-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg)))
(:arg-types simple-array-long-float positive-fixnum)
(:temporary (:sc any-reg :from :eval :to :result) temp)
(:results (value :scs (long-reg)))
(:result-types long-float)
(:generator 7
;; temp = 3 * index
(inst lea temp (make-ea :dword :base index :index index :scale 2))
(with-empty-tn@fp-top(value)
(inst fldl (make-ea :dword :base object :index temp :scale 1
:disp (- (* vector-data-offset
n-word-bytes)
other-pointer-lowtag))))))
#!+long-float
(define-vop (data-vector-ref-c/simple-array-long-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:info index)
(:arg-types simple-array-long-float (:constant (signed-byte 30)))
(:results (value :scs (long-reg)))
(:result-types long-float)
(:generator 6
(with-empty-tn@fp-top(value)
(inst fldl (make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 12 index))
other-pointer-lowtag))))))
#!+long-float
(define-vop (data-vector-set/simple-array-long-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg))
(value :scs (long-reg) :target result))
(:arg-types simple-array-long-float positive-fixnum long-float)
(:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
(:results (result :scs (long-reg)))
(:result-types long-float)
(:generator 20
;; temp = 3 * index
(inst lea temp (make-ea :dword :base index :index index :scale 2))
(cond ((zerop (tn-offset value))
;; Value is in ST0.
(store-long-float
(make-ea :dword :base object :index temp :scale 1
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
(t
;; Value is not in ST0.
(inst fxch value)
(store-long-float
(make-ea :dword :base object :index temp :scale 1
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
(t
;; Neither value or result are in ST0
(unless (location= value result)
(inst fstd result))
(inst fxch value)))))))
#!+long-float
(define-vop (data-vector-set-c/simple-array-long-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(value :scs (long-reg) :target result))
(:info index)
(:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
(:results (result :scs (long-reg)))
(:result-types long-float)
(:generator 19
(cond ((zerop (tn-offset value))
;; Value is in ST0.
(store-long-float (make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 12 index))
other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
(t
;; Value is not in ST0.
(inst fxch value)
(store-long-float (make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 12 index))
other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
(t
;; Neither value or result are in ST0
(unless (location= value result)
(inst fstd result))
(inst fxch value)))))))
;;; complex float variants
@ -925,173 +810,7 @@
(inst fxch value-imag))))
#!+long-float
(define-vop (data-vector-ref/simple-array-complex-long-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg)))
(:arg-types simple-array-complex-long-float positive-fixnum)
(:temporary (:sc any-reg :from :eval :to :result) temp)
(:results (value :scs (complex-long-reg)))
(:result-types complex-long-float)
(:generator 7
;; temp = 3 * index
(inst lea temp (make-ea :dword :base index :index index :scale 2))
(let ((real-tn (complex-long-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
(inst fldl (make-ea :dword :base object :index temp :scale 2
:disp (- (* vector-data-offset
n-word-bytes)
other-pointer-lowtag)))))
(let ((imag-tn (complex-long-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldl (make-ea :dword :base object :index temp :scale 2
:disp (- (+ (* vector-data-offset
n-word-bytes)
12)
other-pointer-lowtag)))))))
#!+long-float
(define-vop (data-vector-ref-c/simple-array-complex-long-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:info index)
(:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
(:results (value :scs (complex-long-reg)))
(:result-types complex-long-float)
(:generator 6
(let ((real-tn (complex-long-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
(inst fldl (make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 24 index))
other-pointer-lowtag)))))
(let ((imag-tn (complex-long-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldl (make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 24 index) 12)
other-pointer-lowtag)))))))
#!+long-float
(define-vop (data-vector-set/simple-array-complex-long-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
(index :scs (any-reg))
(value :scs (complex-long-reg) :target result))
(:arg-types simple-array-complex-long-float positive-fixnum
complex-long-float)
(:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
(:results (result :scs (complex-long-reg)))
(:result-types complex-long-float)
(:generator 20
;; temp = 3 * index
(inst lea temp (make-ea :dword :base index :index index :scale 2))
(let ((value-real (complex-long-reg-real-tn value))
(result-real (complex-long-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
;; Value is in ST0.
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
(t
;; Value is not in ST0.
(inst fxch value-real)
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
(t
;; Neither value or result are in ST0
(unless (location= value-real result-real)
(inst fstd result-real))
(inst fxch value-real))))))
(let ((value-imag (complex-long-reg-imag-tn value))
(result-imag (complex-long-reg-imag-tn result)))
(inst fxch value-imag)
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (+ (* vector-data-offset n-word-bytes) 12)
other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
#!+long-float
(define-vop (data-vector-set-c/simple-array-complex-long-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(value :scs (complex-long-reg) :target result))
(:info index)
(:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
complex-long-float)
(:results (result :scs (complex-long-reg)))
(:result-types complex-long-float)
(:generator 19
(let ((value-real (complex-long-reg-real-tn value))
(result-real (complex-long-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
;; Value is in ST0.
(store-long-float
(make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 24 index))
other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
(t
;; Value is not in ST0.
(inst fxch value-real)
(store-long-float
(make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
(* 24 index))
other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
(t
;; Neither value or result are in ST0
(unless (location= value-real result-real)
(inst fstd result-real))
(inst fxch value-real))))))
(let ((value-imag (complex-long-reg-imag-tn value))
(result-imag (complex-long-reg-imag-tn result)))
(inst fxch value-imag)
(store-long-float
(make-ea :dword :base object
:disp (- (+ (* vector-data-offset
n-word-bytes)
;; FIXME: There are so many of these bare constants
;; (24, 12..) in the LONG-FLOAT code that it's
;; ridiculous. I should probably just delete it all
;; instead of appearing to flirt with supporting
;; this maintenance nightmare.
(* 24 index) 12)
other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
;;; unsigned-byte-8
(macrolet ((define-data-vector-frobs (ptype)
@ -1378,7 +1097,7 @@
simple-character-string vector-data-offset other-pointer-lowtag
(character-reg) character data-vector-ref)
#!+sb-unicode
(define-full-setter data-vector-ref/simple-character-string
(define-full-setter data-vector-set/simple-character-string
simple-character-string vector-data-offset other-pointer-lowtag
(character-reg) character data-vector-set)
@ -1552,22 +1271,7 @@
(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
(:translate %raw-set-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
#!+long-float
(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
(:translate %raw-ref-long)
(:arg-types sb!c::raw-vector positive-fixnum))
#!+long-float
(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
(:translate %raw-ref-long)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
#!+long-float
(define-vop (raw-set-double data-vector-set/simple-array-long-float)
(:translate %raw-set-long)
(:arg-types sb!c::raw-vector positive-fixnum long-float))
#!+long-float
(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
(:translate %raw-set-long)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30)) long-float))
;;;; complex-float raw structure slot accessors
@ -1605,27 +1309,7 @@
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))
complex-double-float))
#!+long-float
(define-vop (raw-ref-complex-long
data-vector-ref/simple-array-complex-long-float)
(:translate %raw-ref-complex-long)
(:arg-types sb!c::raw-vector positive-fixnum))
#!+long-float
(define-vop (raw-ref-complex-long-c
data-vector-ref-c/simple-array-complex-long-float)
(:translate %raw-ref-complex-long)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
#!+long-float
(define-vop (raw-set-complex-long
data-vector-set/simple-array-complex-long-float)
(:translate %raw-set-complex-long)
(:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
#!+long-float
(define-vop (raw-set-complex-long-c
data-vector-set-c/simple-array-complex-long-float)
(:translate %raw-set-complex-long)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))
complex-long-float))
;;; These vops are useful for accessing the bits of a vector
;;; irrespective of what type of vector it is.

24
src/runtime/Config.x86_64-linux
View file

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

2
src/runtime/backtrace.c
View file

@ -28,7 +28,7 @@
#include "genesis/primitive-objects.h"
#include "thread.h"
#ifndef LISP_FEATURE_X86
#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
/* KLUDGE: Sigh ... I know what the call frame looks like and it had
* better not change. */

50
src/runtime/cheneygc.c
View file

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

1
src/runtime/dynbind.c
View file

@ -21,6 +21,7 @@
#include "genesis/symbol.h"
#include "genesis/binding.h"
#include "genesis/thread.h"
#include "genesis/static-symbols.h"
#if defined(BINDING_STACK_POINTER)
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread))

236
src/runtime/gc-common.c
View file

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

31
src/runtime/gc-internal.h
View file

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

6
src/runtime/gencgc-alloc-region.h
View file

@ -9,14 +9,14 @@ struct alloc_region {
void *end_addr; /* pointer to the byte after the last usable byte */
/* These are needed when closing the region. */
int first_page;
int last_page;
long first_page;
long last_page;
void *start_addr;
};
extern struct alloc_region boxed_region;
extern struct alloc_region unboxed_region;
extern int from_space, new_space;
extern long from_space, new_space;
extern struct weak_pointer *weak_pointers;
extern void *current_region_free_pointer;

16
src/runtime/gencgc-internal.h
View file

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

484
src/runtime/gencgc.c
View file

File diff suppressed because it is too large Load diff

12
src/runtime/interrupt.c
View file

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

8
src/runtime/monitor.c
View file

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

2
src/runtime/parse.c
View file

@ -258,7 +258,7 @@ static boolean lookup_symbol(char *name, lispobj *result)
/* Search dynamic space. */
headerptr = (lispobj *)DYNAMIC_SPACE_START;
#if !defined(LISP_FEATURE_X86)
#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
count =
dynamic_space_free_pointer -
(lispobj *)DYNAMIC_SPACE_START;

253
src/runtime/purify.c
View file

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

7
src/runtime/runtime.h
View file

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

42
src/runtime/save.c
View file

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

8
src/runtime/thread.c
View file

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

8
src/runtime/thread.h
View file

@ -43,7 +43,7 @@ extern struct thread *find_thread_by_pid(pid_t pid);
#define for_each_thread(th) for(th=all_threads;th;th=0)
#endif
static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
static inline lispobj SymbolValue(u64 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
(pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
@ -56,7 +56,7 @@ static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
#endif
return sym->value;
}
static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
static inline lispobj SymbolTlValue(u64 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
(pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
@ -67,7 +67,7 @@ static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
#endif
}
static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
static inline void SetSymbolValue(u64 tagged_symbol_pointer,lispobj val, void *thread) {
struct symbol *sym= (struct symbol *)
(pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
@ -82,7 +82,7 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t
#endif
sym->value = val;
}
static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
static inline void SetTlSymbolValue(u64 tagged_symbol_pointer,lispobj val, void *thread) {
#ifdef LISP_FEATURE_SB_THREAD
struct symbol *sym= (struct symbol *)
(pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);

393
src/runtime/x86-64-arch.c Normal file
View file

@ -0,0 +1,393 @@
/*
* This software is part of the SBCL system. See the README file for
* more information.
*
* This software is derived from the CMU CL system, which was
* written at Carnegie Mellon University and released into the
* public domain. The software is in the public domain and is
* provided with absolutely no warranty. See the COPYING and CREDITS
* files for more information.
*/
#include <stdio.h>
#include "sbcl.h"
#include "runtime.h"
#include "globals.h"
#include "validate.h"
#include "os.h"
#include "sbcl.h"
#include "arch.h"
#include "lispregs.h"
#include "signal.h"
#include "alloc.h"
#include "interrupt.h"
#include "interr.h"
#include "breakpoint.h"
#include "monitor.h"
#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
#define BREAKPOINT_INST 0xcc /* INT3 */
unsigned long fast_random_state = 1;
void arch_init(void)
{}
/*
* 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
}
void arch_skip_instruction(os_context_t *context)
{
/* Assuming we get here via an INT3 xxx instruction, the PC now
* points to the interrupt code (a Lisp value) so we just move
* past it. Skip the code; after that, if the code is an
* error-trap or cerror-trap then skip the data bytes that follow. */
int vlen;
long code;
/* Get and skip the Lisp interrupt code. */
code = *(char*)(*os_context_pc_addr(context))++;
switch (code)
{
case trap_Error:
case trap_Cerror:
/* Lisp error arg vector length */
vlen = *(char*)(*os_context_pc_addr(context))++;
/* Skip Lisp error arg data bytes. */
while (vlen-- > 0) {
( (char*)(*os_context_pc_addr(context)) )++;
}
break;
case trap_Breakpoint: /* not tested */
case trap_FunEndBreakpoint: /* not tested */
break;
case trap_PendingInterrupt:
case trap_Halt:
/* only needed to skip the Code */
break;
default:
fprintf(stderr,"[arch_skip_inst invalid code %d\n]\n",code);
break;
}
FSHOW((stderr,
"/[arch_skip_inst resuming at %x]\n",
*os_context_pc_addr(context)));
}
unsigned char *
arch_internal_error_arguments(os_context_t *context)
{
return 1 + (unsigned char *)(*os_context_pc_addr(context));
}
boolean
arch_pseudo_atomic_atomic(os_context_t *context)
{
return SymbolValue(PSEUDO_ATOMIC_ATOMIC,arch_os_get_current_thread());
}
void
arch_set_pseudo_atomic_interrupted(os_context_t *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),
arch_os_get_current_thread());
}
/*
* This stuff seems to get called for TRACE and debug activity.
*/
unsigned long
arch_install_breakpoint(void *pc)
{
unsigned long result = *(unsigned long*)pc;
*(char*)pc = BREAKPOINT_INST; /* x86 INT3 */
*((char*)pc+1) = trap_Breakpoint; /* Lisp trap code */
return result;
}
void
arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
*((char *)pc) = orig_inst & 0xff;
*((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
}
/* When single stepping, single_stepping holds the original instruction
* PC location. */
unsigned long *single_stepping = NULL;
#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
unsigned long single_step_save1;
unsigned long single_step_save2;
unsigned long single_step_save3;
#endif
void
arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
{
unsigned long *pc = (unsigned long*)(*os_context_pc_addr(context));
/* Put the original instruction back. */
*((char *)pc) = orig_inst & 0xff;
*((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
/* Install helper instructions for the single step:
* pushf; or [esp],0x100; popf. */
single_step_save1 = *(pc-3);
single_step_save2 = *(pc-2);
single_step_save3 = *(pc-1);
*(pc-3) = 0x9c909090;
*(pc-2) = 0x00240c81;
*(pc-1) = 0x9d000001;
#else
*context_eflags_addr(context) |= 0x100;
#endif
single_stepping = (unsigned int*)pc;
#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
*os_context_pc_addr(context) = (char *)pc - 9;
#endif
}
void
sigtrap_handler(int signal, siginfo_t *info, void *void_context)
{
int code = info->si_code;
os_context_t *context = (os_context_t*)void_context;
unsigned int trap;
sigset_t ss;
if (single_stepping && (signal==SIGTRAP))
{
/* fprintf(stderr,"* single step trap %x\n", single_stepping); */
#ifdef CANNOT_GET_TO_SINGLE_STEP_FLAG
/* Un-install single step helper instructions. */
*(single_stepping-3) = single_step_save1;
*(single_stepping-2) = single_step_save2;
*(single_stepping-1) = single_step_save3;
#else
*context_eflags_addr(context) ^= 0x100;
#endif
/* Re-install the breakpoint if possible. */
if (*os_context_pc_addr(context) == (int)single_stepping + 1) {
fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
} else {
*((char *)single_stepping) = BREAKPOINT_INST; /* x86 INT3 */
*((char *)single_stepping+1) = trap_Breakpoint;
}
single_stepping = NULL;
return;
}
/* This is just for info in case the monitor wants to print an
* approximation. */
current_control_stack_pointer =
(lispobj *)*os_context_sp_addr(context);
/* FIXME: CMUCL puts the float control restoration code here.
Thus, it seems to me that single-stepping won't restore the
float control. Since SBCL currently doesn't support
single-stepping (as far as I can tell) this is somewhat moot,
but it might be worth either moving this code up or deleting
the single-stepping code entirely. -- CSR, 2002-07-15 */
#ifdef LISP_FEATURE_LINUX
os_restore_fp_control(context);
#endif
/* On entry %eip points just after the INT3 byte and aims at the
* 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a
* number of bytes will follow, the first is the length of the byte
* arguments to follow. */
trap = *(unsigned char *)(*os_context_pc_addr(context));
switch (trap) {
case trap_PendingInterrupt:
FSHOW((stderr, "/<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()");
}
/* 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

38
src/runtime/x86-64-arch.h Normal file
View file

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

335
src/runtime/x86-64-assem.S Normal file
View file

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

229
src/runtime/x86-64-linux-os.c Normal file
View file

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

14
src/runtime/x86-64-linux-os.h Normal file
View file

@ -0,0 +1,14 @@
#ifndef _X86_LINUX_OS_H
#define _X86_LINUX_OS_H
typedef struct ucontext os_context_t;
typedef long os_context_register_t;
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
}
unsigned long os_context_fp_control(os_context_t *context);
void os_restore_fp_control(os_context_t *context);
#endif /* _X86_LINUX_OS_H */

58
src/runtime/x86-64-lispregs.h Normal file
View file

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

10
tests/arith.pure.lisp
View file

@ -151,11 +151,11 @@
((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
(1 (ash most-negative-fixnum 1) nil)
(29 most-negative-fixnum t)
(30 (ash most-negative-fixnum 1) t)
(31 (ash most-negative-fixnum 1) t)
(64 (ash most-negative-fixnum 36) nil)
(65 (ash most-negative-fixnum 36) t)))
(#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t)
(#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
(#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
(#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil)
(#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t)))
(destructuring-bind (index int result) x
(assert (eq (eval `(logbitp ,index ,int)) result))))

2
tests/bit-vector.impure-cload.lisp
View file

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

2
tests/compiler.impure.lisp
View file

@ -898,7 +898,7 @@
;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
(defvar *compiler-note-count* 0)
#-alpha ; FIXME: make a better test!
#-(or alpha x86-64) ; FIXME: make a better test!
(handler-bind ((sb-ext:compiler-note (lambda (c)
(declare (ignore c))
(incf *compiler-note-count*))))

Some files were not shown because too many files have changed in this diff Show more