From 0bb093a109ec94a021e413bd0ae6ae7fdf54d774 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Thu, 8 May 2008 07:14:01 +0000 Subject: [PATCH] 1.0.16.21: lose informatively when the tls is full Instead of eventually producing a segv or some random corruption: (progv (loop for i below 5000 collect (make-symbol (format nil "xxx~D" i))) (loop for i below 5000 collect i)) --- package-data-list.lisp-expr | 2 + src/assembly/x86-64/alloc.lisp | 85 +++++++++++++++++++------------------ src/assembly/x86/alloc.lisp | 86 ++++++++++++++++++++------------------ src/code/interr.lisp | 9 ++++ src/compiler/generic/interr.lisp | 2 + src/compiler/generic/parms.lisp | 4 ++ src/runtime/dynbind.c | 3 ++ src/runtime/thread.c | 2 +- version.lisp-expr | 2 +- 9 files changed, 112 insertions(+), 83 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4c7049c..e8b95e7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1554,6 +1554,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%INSTANCE-REF" "%INSTANCE-SET" "SYSTEM-AREA-CLEAR" + "TLS-EXHAUSTED-ERROR" "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV" @@ -2505,6 +2506,7 @@ structure representations" #!+linkage-table "LINKAGE-TABLE-SPACE-START" #!+linkage-table "LINKAGE-TABLE-SPACE-END" #!+linkage-table "LINKAGE-TABLE-ENTRY-SIZE" + "TLS-SIZE" "TRACE-TABLE-CALL-SITE" "TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE" "TRACE-TABLE-NORMAL" "N-WIDETAG-BITS" "WIDETAG-MASK" diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp index aa1fa7e..68a8ce3 100644 --- a/src/assembly/x86-64/alloc.lisp +++ b/src/assembly/x86-64/alloc.lisp @@ -72,46 +72,51 @@ (def r15)) #+sb-assembling -(macrolet ((def (reg) - (declare (ignorable reg)) - #!+sb-thread - (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg))) - (target-offset (intern (format nil "~A-OFFSET" reg))) - (other-offset (if (eql 'rax reg) - 'rcx-offset - 'rax-offset))) - ;; Symbol starts in TARGET, where the TLS-INDEX ends up in. - `(define-assembly-routine ,name - ((:temp other descriptor-reg ,other-offset) - (:temp target descriptor-reg ,target-offset)) - (let ((get-tls-index-lock (gen-label)) - (release-tls-index-lock (gen-label))) - (pseudo-atomic - ;; Save OTHER & push the symbol. RAX is either one of the two. - (inst push other) - (inst push target) - (emit-label get-tls-index-lock) - (inst mov target 1) - (zeroize rax-tn) - (inst lock) - (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target) - (inst jmp :ne get-tls-index-lock) - ;; The symbol is now in OTHER. - (inst pop other) - ;; Now with the lock held, see if the symbol's tls index has been - ;; set in the meantime. - (loadw target other symbol-tls-index-slot other-pointer-lowtag) - (inst or target target) - (inst jmp :ne release-tls-index-lock) - ;; Allocate a new tls-index. - (load-symbol-value target *free-tls-index*) - (inst add (make-ea-for-symbol-value *free-tls-index*) (fixnumize 1)) - (storew target other symbol-tls-index-slot other-pointer-lowtag) - (emit-label release-tls-index-lock) - (store-symbol-value 0 *tls-index-lock*) - ;; Restore OTHER. - (inst pop other)) - (inst ret)))))) +(macrolet + ((def (reg) + (declare (ignorable reg)) + #!+sb-thread + (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg))) + (target-offset (intern (format nil "~A-OFFSET" reg))) + (other-offset (if (eql 'rax reg) + 'rcx-offset + 'rax-offset))) + ;; Symbol starts in TARGET, where the TLS-INDEX ends up in. + `(define-assembly-routine ,name + ((:temp other descriptor-reg ,other-offset) + (:temp target descriptor-reg ,target-offset)) + (let ((get-tls-index-lock (gen-label)) + (release-tls-index-lock (gen-label))) + (pseudo-atomic + ;; Save OTHER & push the symbol. RAX is either one of the two. + (inst push other) + (inst push target) + (emit-label get-tls-index-lock) + (inst mov target 1) + (zeroize rax-tn) + (inst lock) + (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target) + (inst jmp :ne get-tls-index-lock) + ;; The symbol is now in OTHER. + (inst pop other) + ;; Now with the lock held, see if the symbol's tls index has been + ;; set in the meantime. + (loadw target other symbol-tls-index-slot other-pointer-lowtag) + (inst or target target) + (inst jmp :ne release-tls-index-lock) + ;; Allocate a new tls-index. + (load-symbol-value target *free-tls-index*) + (let ((error (generate-error-code nil 'tls-exhausted-error))) + (inst cmp target (fixnumize tls-size)) + (inst jmp :ge error)) + (inst add (make-ea-for-symbol-value *free-tls-index*) + (fixnumize 1)) + (storew target other symbol-tls-index-slot other-pointer-lowtag) + (emit-label release-tls-index-lock) + (store-symbol-value 0 *tls-index-lock*) + ;; Restore OTHER. + (inst pop other)) + (inst ret)))))) (def rax) (def rcx) (def rdx) diff --git a/src/assembly/x86/alloc.lisp b/src/assembly/x86/alloc.lisp index e52052d..030d002 100644 --- a/src/assembly/x86/alloc.lisp +++ b/src/assembly/x86/alloc.lisp @@ -80,50 +80,54 @@ (frob-cons-routines)) #+sb-assembling -(macrolet ((def (reg) - (declare (ignorable reg)) - #!+sb-thread - (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg))) - (target-offset (intern (format nil "~A-OFFSET" reg))) - (other-offset (if (eql 'eax reg) - 'ecx-offset - 'eax-offset))) - ;; Symbol starts in TARGET, where the TLS-INDEX ends up in. - `(define-assembly-routine ,name - ((:temp other descriptor-reg ,other-offset) - (:temp target descriptor-reg ,target-offset)) - (let ((get-tls-index-lock (gen-label)) - (release-tls-index-lock (gen-label))) - (pseudo-atomic - ;; Save OTHER & push the symbol. EAX is either one of the two. - (inst push other) - (inst push target) - (emit-label get-tls-index-lock) - (inst mov target 1) - (inst xor eax-tn eax-tn) - (inst lock) - (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target) - (inst jmp :ne get-tls-index-lock) - ;; The symbol is now in OTHER. - (inst pop other) - ;; Now with the lock held, see if the symbol's tls index has been - ;; set in the meantime. - (loadw target other symbol-tls-index-slot other-pointer-lowtag) - (inst or target target) - (inst jmp :ne release-tls-index-lock) - ;; Allocate a new tls-index. - (load-symbol-value target *free-tls-index*) - (inst add (make-ea-for-symbol-value *free-tls-index*) (fixnumize 1)) - (storew target other symbol-tls-index-slot other-pointer-lowtag) - (emit-label release-tls-index-lock) - (store-symbol-value 0 *tls-index-lock*) - ;; Restore OTHER. - (inst pop other)) - (inst ret)))))) +(macrolet + ((def (reg) + (declare (ignorable reg)) + #!+sb-thread + (let* ((name (intern (format nil "ALLOC-TLS-INDEX-IN-~A" reg))) + (target-offset (intern (format nil "~A-OFFSET" reg))) + (other-offset (if (eql 'eax reg) + 'ecx-offset + 'eax-offset))) + ;; Symbol starts in TARGET, where the TLS-INDEX ends up in. + `(define-assembly-routine ,name + ((:temp other descriptor-reg ,other-offset) + (:temp target descriptor-reg ,target-offset)) + (let ((get-tls-index-lock (gen-label)) + (release-tls-index-lock (gen-label))) + (pseudo-atomic + ;; Save OTHER & push the symbol. EAX is either one of the two. + (inst push other) + (inst push target) + (emit-label get-tls-index-lock) + (inst mov target 1) + (inst xor eax-tn eax-tn) + (inst lock) + (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target) + (inst jmp :ne get-tls-index-lock) + ;; The symbol is now in OTHER. + (inst pop other) + ;; Now with the lock held, see if the symbol's tls index has been + ;; set in the meantime. + (loadw target other symbol-tls-index-slot other-pointer-lowtag) + (inst or target target) + (inst jmp :ne release-tls-index-lock) + ;; Allocate a new tls-index. + (load-symbol-value target *free-tls-index*) + (let ((error (generate-error-code nil 'tls-exhausted-error))) + (inst cmp target (fixnumize tls-size)) + (inst jmp :ge error)) + (inst add (make-ea-for-symbol-value *free-tls-index*) + (fixnumize 1)) + (storew target other symbol-tls-index-slot other-pointer-lowtag) + (emit-label release-tls-index-lock) + (store-symbol-value 0 *tls-index-lock*) + ;; Restore OTHER. + (inst pop other)) + (inst ret)))))) (def eax) (def ebx) (def ecx) (def edx) (def edi) (def esi)) - diff --git a/src/code/interr.lisp b/src/code/interr.lisp index a939c85..3f2a45d 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -282,6 +282,15 @@ :datum object :expected-type '(unsigned-byte 32))) +(deferr tls-exhausted-error () + ;; There is nothing we can do about it. A number of entries in the + ;; tls could be reserved and made available for recovery but since + ;; tls indices are never reused it would be kind of silly and + ;; without it signalling an error is more than likely to end in a + ;; recursive error. + (%primitive print "Thread local storage exhausted.") + (sb!impl::%halt)) + (macrolet ((define-simple-array-internal-errors () `(progn diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp index fd992ab..a733652 100644 --- a/src/compiler/generic/interr.lisp +++ b/src/compiler/generic/interr.lisp @@ -145,6 +145,8 @@ "Object layout is invalid. (indicates obsolete instance)") (object-not-complex-vector "Object is not a complex (non-SIMPLE-ARRAY) vector.") + (tls-exhausted + "Thread local storage exhausted.") . #.(map 'list (lambda (saetp) diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index c39ffe5..c134c87 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -71,3 +71,7 @@ :value :key-and-value :key-or-value)) + +;;; Number of entries in the thread local storage. Limits the number +;;; of symbols with thread local bindings. +(def!constant tls-size 4096) diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c index f2e51ef..77dfd88 100644 --- a/src/runtime/dynbind.c +++ b/src/runtime/dynbind.c @@ -51,6 +51,9 @@ void bind_variable(lispobj symbol, lispobj value, void *th) sym->tls_index=SymbolValue(FREE_TLS_INDEX,0); SetSymbolValue(FREE_TLS_INDEX, make_fixnum(fixnum_value(sym->tls_index)+1),0); + if(fixnum_value(sym->tls_index)>=TLS_SIZE) { + lose("Thread local storage exhausted."); + } } release_spinlock(tls_index_lock); clear_pseudo_atomic_atomic(th); diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 6489d7d..3dcae1b 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -82,7 +82,7 @@ pthread_mutex_t freeable_stack_lock = PTHREAD_MUTEX_INITIALIZER; static struct freeable_stack * volatile freeable_stack = 0; #endif -int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */ +int dynamic_values_bytes=TLS_SIZE*sizeof(lispobj); /* same for all threads */ struct thread * volatile all_threads; extern struct interrupt_data * global_interrupt_data; diff --git a/version.lisp-expr b/version.lisp-expr index 130860f..7d6374b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.16.20" +"1.0.16.21" -- 1.7.10.4