* Bug fix: OPEN no longer fails when *PRINT-READABLY* is T. (thanks
to Zach Beane)
* threads
+ ** added x86-64 support
** incompatible change: the threading api now works with thread
objects instead of thread ids
** bug fix: threads are protected from signals and interruption when
;; :X86. (Note that non-X86 ports mention
;; pseudo-atomicity too, but they handle it without
;; messing with special variables.)
- #!+x86 *pseudo-atomic-atomic*
- #!+x86 *pseudo-atomic-interrupted*
+ #!+(or x86 x86-64) *pseudo-atomic-atomic*
+ #!+(or x86 x86-64) *pseudo-atomic-interrupted*
sb!unix::*interrupts-enabled*
sb!unix::*interrupt-pending*
*free-interrupt-context-index*
;;; FIXME: These could be converted to DEFVARs.
(declaim (special *gc-inhibit* *need-to-collect-garbage*
*after-gc-hooks*
- #!+x86 *pseudo-atomic-atomic*
- #!+x86 *pseudo-atomic-interrupted*
+ #!+(or x86 x86-64) *pseudo-atomic-atomic*
+ #!+(or x86 x86-64) *pseudo-atomic-interrupted*
sb!unix::*interrupts-enabled*
sb!unix::*interrupt-pending*
*type-system-initialized*))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
(inst mov temp
- (make-ea :dword
+ (make-ea :qword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst sub (make-ea :dword :scale 1 :index temp) delta)))
+ (inst sub (make-ea :qword :base thread-base-tn
+ :scale 1 :index temp) delta)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
(inst mov temp
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst add (make-ea :dword :scale 1 :index temp) delta))))
+ (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp)
+ delta))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
(inst or tls tls)
(inst jmp :z global-val)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :scale 1 :index tls) unbound-marker-widetag)
+ (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
+ unbound-marker-widetag)
(inst jmp :z global-val)
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :scale 1 :index tls) value)
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
+ value)
(inst jmp done)
(emit-label global-val)
(storew value symbol symbol-value-slot other-pointer-lowtag)
(let* ((err-lab (generate-error-code vop unbound-symbol-error object))
(ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov value (make-ea :dword :index value :scale 1))
+ (inst mov value (make-ea :qword :base thread-base-tn
+ :index value :scale 1))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(:generator 8
(let ((ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov value (make-ea :dword :index value :scale 1))
+ (inst mov value
+ (make-ea :qword :base thread-base-tn :index value :scale 1))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(:generator 4
(move result value)
(inst lock)
- (inst add (make-ea :dword :base object
+ (inst add (make-ea :qword :base object
:disp (- (* symbol-value-slot n-word-bytes)
other-pointer-lowtag))
value)))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne not-target)
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
+ (inst cmp (make-ea :qword :base thread-base-tn
+ :index value :scale 1) unbound-marker-widetag)
(inst jmp :e target)
(emit-label not-target))
(progn
(inst cmp value unbound-marker-widetag)
(inst jmp :ne target)
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
+ (inst cmp (make-ea :qword :base thread-base-tn :index value :scale 1)
+ unbound-marker-widetag)
(inst jmp :ne target)))))
#!-sb-thread
(inst jmp :ne tls-index-valid)
;; allocate a new tls-index
(load-symbol-value tls-index *free-tls-index*)
- (inst add tls-index 4) ;XXX surely we can do this more
+ (inst add tls-index 8) ;XXX surely we can do this more
(store-symbol-value tls-index *free-tls-index*) ;succintly
- (inst sub tls-index 4)
+ (inst sub tls-index 8)
(storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(emit-label tls-index-valid)
- (inst fs-segment-prefix)
- (inst mov temp (make-ea :dword :scale 1 :index tls-index))
+ (inst mov temp
+ (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :scale 1 :index tls-index) val))))
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
+ val))))
#!-sb-thread
(define-vop (bind)
(loadw value bsp (- binding-value-slot binding-size))
(loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst mov (make-ea :dword :scale 1 :index tls-index) value)
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
+ value)
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
(inst or symbol symbol)
(inst jmp :z SKIP)
(loadw value bsp (- binding-value-slot binding-size))
- #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
-
- #!+sb-thread (loadw
- tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
- #!+sb-thread (inst fs-segment-prefix)
- #!+sb-thread (inst mov (make-ea :dword :scale 1 :index tls-index) value)
+ #!-sb-thread
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ #!+sb-thread
+ (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+ #!+sb-thread
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
+ value)
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(:translate %instance-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
(slot :scs (any-reg) :to :result)
- (old-value :scs (descriptor-reg any-reg) :target eax)
+ (old-value :scs (descriptor-reg any-reg) :target rax)
(new-value :scs (descriptor-reg any-reg)))
(:arg-types instance positive-fixnum * *)
- (:temporary (:sc descriptor-reg :offset eax-offset
- :from (:argument 2) :to :result :target result) eax)
+ (:temporary (:sc descriptor-reg :offset rax-offset
+ :from (:argument 2) :to :result :target result) rax)
(:results (result :scs (descriptor-reg any-reg)))
;(:guard (backend-featurep :i486))
(:policy :fast-safe)
(:generator 5
- (move eax old-value)
+ (move rax old-value)
(inst lock)
- (inst cmpxchg (make-ea :dword :base object :index slot :scale 1
+ (inst cmpxchg (make-ea :qword :base object :index slot :scale 1
:disp (- (* instance-slots-offset n-word-bytes)
instance-pointer-lowtag))
new-value)
- (move result eax)))
+ (move result rax)))
\f
(static-symbol-offset ',symbol)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst mov ,reg (make-ea :qword :scale 1 :index ,reg))))
+ (inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
#!-sb-thread
(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
(static-symbol-offset ',symbol)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst mov (make-ea :qword :scale 1 :index ,temp) ,reg)))
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
(declare (ignore temp))
(DONE (gen-label))
;; Yuck.
(in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
+ ;; thread->alloc_region.free_pointer
(free-pointer
- (make-ea :qword :disp
- #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
- #!-sb-thread (make-fixup "boxed_region" :foreign)
- :scale 1)) ; thread->alloc_region.free_pointer
+ #!+sb-thread
+ (make-ea :qword
+ :base thread-base-tn :scale 1
+ :disp (* n-word-bytes thread-alloc-region-slot))
+ #!-sb-thread
+ (make-ea :qword
+ :scale 1 :disp
+ (make-fixup (extern-alien-name "boxed_region") :foreign)))
+ ;; thread->alloc_region.end_addr
(end-addr
- (make-ea :qword :disp
- #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
- #!-sb-thread (make-fixup "boxed_region" :foreign 8)
- :scale 1))) ; thread->alloc_region.end_addr
+ #!+sb-thread
+ (make-ea :qword
+ :base thread-base-tn :scale 1
+ :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
+ #!-sb-thread
+ (make-ea :qword
+ :scale 1 :disp
+ (make-fixup (extern-alien-name "boxed_region") :foreign 8))))
(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*)
(progn ,@body)
(pseudo-atomic ,@body)))
+#!+sb-thread
+(defmacro pseudo-atomic (&rest forms)
+ (with-unique-names (label)
+ `(let ((,label (gen-label)))
+ (inst mov (make-ea :byte
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst mov (make-ea :byte
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-atomic-slot))
+ (fixnumize 1))
+ ,@forms
+ (inst mov (make-ea :byte
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-atomic-slot)) 0)
+ (inst cmp (make-ea :byte
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst jmp :eq ,label)
+ ;; if PAI was set, interrupts were disabled at the same
+ ;; time using the process signal mask.
+ (inst break pending-interrupt-trap)
+ (emit-label ,label))))
+
+
+#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
`(let ((,label (gen-label)))
(inst break pending-interrupt-trap)))
#!+sb-thread
-(defknown current-thread-offset-sap ((unsigned-byte 32))
+(defknown current-thread-offset-sap ((unsigned-byte 64))
system-area-pointer (flushable))
#!+sb-thread
(:arg-types unsigned-num)
(:policy :fast-safe)
(:generator 2
- (inst fs-segment-prefix)
- (inst mov sap (make-ea :dword :disp 0 :index n :scale 4))))
+ (inst mov sap
+ (make-ea :qword :base thread-base-tn :disp 0 :index n :scale 8))))
(define-vop (halt)
(:generator 1
(defreg r13 26 :qword)
(defreg r14 28 :qword)
(defreg r15 30 :qword)
+ ;; for no good reason at the time, r12 and r13 were missed from the
+ ;; list of qword registers. However
+ ;; <jsnell> r13 is already used as temporary [#lisp irc 2005/01/30]
+ ;; and we're now going to use r12 for the struct thread*
(defregset *qword-regs* rax rcx rdx rbx rsi rdi
- r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15)
+ r8 r9 r10 r11 r14 r15)
;; floating point registers
(defreg float0 0 :float)
(symbol-value (symbolicate register-arg-name "-TN")))
*register-arg-names*))
+(defparameter thread-base-tn
+ (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg )
+ :offset r12-offset))
(defparameter fp-single-zero-tn
(make-random-tn :kind :normal
LINKFLAGS += -Wl,--export-dynamic
OS_LIBS = -ldl
+OS_LIBS += $(shell if grep LISP_FEATURE_SB_THREAD genesis/config.h \
+ > /dev/null 2>&1; \
+ then echo "-lpthread"; fi)
+
CFLAGS += -fno-omit-frame-pointer
GC_SRC = gencgc.c
#elif defined(LISP_FEATURE_X86_64)
u64 *sp=(u64 *)*os_context_register_addr(context,reg_RSP);
- *(sp-20) = post_signal_tramp; /* return address for call_into_lisp */
-
- *(sp-19)=*os_context_register_addr(context,reg_R15);
- *(sp-18)=*os_context_register_addr(context,reg_R14);
- *(sp-17)=*os_context_register_addr(context,reg_R13);
- *(sp-16)=*os_context_register_addr(context,reg_R12);
- *(sp-15)=*os_context_register_addr(context,reg_R11);
- *(sp-14)=*os_context_register_addr(context,reg_R10);
- *(sp-13)=*os_context_register_addr(context,reg_R9);
- *(sp-12)=*os_context_register_addr(context,reg_R8);
- *(sp-11)=*os_context_register_addr(context,reg_RDI);
- *(sp-10)=*os_context_register_addr(context,reg_RSI);
- *(sp-9)=*os_context_register_addr(context,reg_RSP)-16;
- *(sp-8)=0;
+ *(sp-18) = post_signal_tramp; /* return address for call_into_lisp */
+
+ *(sp-17)=*os_context_register_addr(context,reg_R15);
+ *(sp-16)=*os_context_register_addr(context,reg_R14);
+ *(sp-15)=*os_context_register_addr(context,reg_R13);
+ *(sp-14)=*os_context_register_addr(context,reg_R12);
+ *(sp-13)=*os_context_register_addr(context,reg_R11);
+ *(sp-12)=*os_context_register_addr(context,reg_R10);
+ *(sp-11)=*os_context_register_addr(context,reg_R9);
+ *(sp-10)=*os_context_register_addr(context,reg_R8);
+ *(sp-9)=*os_context_register_addr(context,reg_RDI);
+ *(sp-8)=*os_context_register_addr(context,reg_RSI);
+ /* skip RBP and RSP */
*(sp-7)=*os_context_register_addr(context,reg_RBX);
*(sp-6)=*os_context_register_addr(context,reg_RDX);
*(sp-5)=*os_context_register_addr(context,reg_RCX);
*os_context_pc_addr(context) = call_into_lisp;
*os_context_register_addr(context,reg_RCX) = 0;
*os_context_register_addr(context,reg_RBP) = sp-2;
- *os_context_register_addr(context,reg_RSP) = sp-20;
+ *os_context_register_addr(context,reg_RSP) = sp-18;
#else
/* this much of the calling convention is common to all
non-x86 ports */
STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
STATIC_TLS_INIT(CONTROL_STACK_END,control_stack_end);
STATIC_TLS_INIT(ALIEN_STACK,alien_stack_pointer);
-#ifdef LISP_FEATURE_X86
+#if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic);
STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted);
#endif
#ifndef _X86_64_ARCH_H
#define _X86_64_ARCH_H
+#ifndef SBCL_GENESIS_CONFIG
+#error genesis/config.h (or sbcl.h) must be included before this file
+#endif
+
#define ARCH_HAS_STACK_POINTER
/* FIXME: Do we also want
* here? (The answer wasn't obvious to me when merging the
* architecture-abstracting patches for CSR's SPARC port. -- WHN 2002-02-15) */
+extern never_returns lose(char *fmt, ...);
+
static inline void
-get_spinlock(lispobj *word,long value)
+get_spinlock(volatile lispobj *word,long value)
{
#ifdef LISP_FEATURE_SB_THREAD
u64 rax=0;
+ if(*word==value)
+ lose("recursive get_spinlock: 0x%x,%ld\n",word,value);
do {
asm ("xor %0,%0\n\
lock cmpxchg %1,%2"
}
static inline void
-release_spinlock(lispobj *word)
+release_spinlock(volatile lispobj *word)
{
*word=0;
}
mov %rsp,%rbp # Establish new frame.
Lstack:
/* FIXME x86 saves FPU state here */
- push %rbx
- push %r12
- push %r13
- push %r14
- push %r15
-
+ push %rbx # these regs are callee-saved according to C
+ push %r12 # so must be preserved and restored when
+ push %r13 # the lisp function returns
+ 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
+ push %rdi # args from C
+ push %rsi #
+ push %rdx #
+#ifdef LISP_FEATURE_SB_THREAD
+ mov specials,%rdi
+ call pthread_getspecific
+ mov %rax,%r12
+#endif
+ pop %rcx # num args
+ pop %rbx # arg vector
+ pop %rax # function ptr/lexenv
xor %rdx,%rdx # clear any descriptor registers
xor %rdi,%rdi # that we can't be sure we'll
popq %r8
popq %rdi
popq %rsi
- addq $8, %rsp
- popq %rsp
- popq %rdx
+ /* skip RBP and RSP */
popq %rbx
+ popq %rdx
popq %rcx
popq %rax
popfq
int arch_os_thread_init(struct thread *thread) {
stack_t sigstack;
#ifdef LISP_FEATURE_SB_THREAD
-#error Threads are not supported on x86-64 in this SBCL version
+ pthread_setspecific(specials,thread);
#endif
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
/* Signal handlers are run on the control stack, so if it is exhausted
sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
sigstack.ss_flags=0;
sigstack.ss_size = 32*SIGSTKSZ;
- sigaltstack(&sigstack,0);
+ if(sigaltstack(&sigstack,0)<0) {
+ lose("Cannot sigaltstack: %s\n",strerror(errno));
+ }
#endif
return 1;
}
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.2.9"
+"0.9.2.10"
projects / sbcl.git / commitdiff