From 862c0325616a991a5bd7b50d79f7176d2115493b Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Fri, 26 Aug 2005 20:30:04 +0000 Subject: [PATCH] 0.9.4.5: * in tls use the new widetag no-tls-value-market instead of unbound-marker when a symbol has no thread local value --- NEWS | 3 +++ package-data-list.lisp-expr | 1 + src/code/target-thread.lisp | 2 +- src/compiler/generic/early-objdef.lisp | 2 +- src/compiler/generic/objdef.lisp | 8 ++++--- src/compiler/x86-64/cell.lisp | 40 +++++++++++++------------------ src/compiler/x86/cell.lisp | 41 ++++++++++++++------------------ src/runtime/gc-common.c | 3 +++ src/runtime/gencgc.c | 1 + src/runtime/thread.c | 12 +++++----- src/runtime/thread.h | 4 ++-- tests/compiler.impure-cload.lisp | 7 ++++++ version.lisp-expr | 2 +- 13 files changed, 66 insertions(+), 60 deletions(-) diff --git a/NEWS b/NEWS index 890078b..af2db8d 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: * threads ** bug fix: parent thread now can be gc'ed even with a live child thread + ** bug fix: binding a special with PROGV to no value is not + the same as that symbol not having been bound (thanks to + Hannu Koivisto) * fixed some bugs revealed by Paul Dietz' test suite: ** ENSURE-GENERIC-FUNCTION should take a method class object for the :method-class keyword argument. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 727962e..34138c3 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2271,6 +2271,7 @@ structure representations" "TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE" "TRACE-TABLE-NORMAL" "N-WIDETAG-BITS" "WIDETAG-MASK" "UNBOUND-MARKER-WIDETAG" + "NO-TLS-VALUE-MARKER-WIDETAG" "UNSIGNED-IMMEDIATE-SC-NUMBER" "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" "UNWIND-BLOCK-CURRENT-CODE-SLOT" "UNWIND-BLOCK-CURRENT-CONT-SLOT" diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index ba38649..63e282d 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -585,6 +585,6 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (let* ((index (sb!vm::symbol-tls-index symbol)) (tl-val (sb!sys:sap-ref-word thread-sap (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::unbound-marker-widetag) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) (sb!kernel:make-lisp-obj tl-val))))) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index 9ce39f8..46bd930 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -145,7 +145,7 @@ instance-header ; 01010010 fdefn ; 01010110 - unused00 ; 01011010 + no-tls-value-marker ; 01011010 unused01 ; 01011110 unused02 ; 01100010 unused03 ; 01100110 diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index fa30990..7af7802 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -405,9 +405,11 @@ ;;; Hence the even-fixnum lowtag just so we don't get odd(sic) numbers ;;; added to the slot offsets (define-primitive-object (thread :lowtag even-fixnum-lowtag) - ;; unbound_marker is borrowed very briefly at thread startup to - ;; pass the address of initial-function into new_thread_trampoline - (unbound-marker :init :unbound) ; tls[0] = UNBOUND_MARKER_WIDETAG + ;; no_tls_value_marker is borrowed very briefly at thread startup to + ;; pass the address of initial-function into new_thread_trampoline. + ;; tls[0] = NO_TLS_VALUE_MARKER_WIDETAG because a the tls index slot + ;; of a symbol is initialized to zero + (no-tls-value-marker) (os-thread :c-type "os_thread_t") (binding-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1) (binding-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 2122471..6a3a89c 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -69,7 +69,7 @@ (inst or tls tls) (inst jmp :z global-val) (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) - unbound-marker-widetag) + no-tls-value-marker-widetag) (inst jmp :z global-val) (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) value) @@ -104,14 +104,16 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let* ((err-lab (generate-error-code vop unbound-symbol-error object)) + (let* ((check-unbound-label (gen-label)) + (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 mov value (make-ea :qword :base thread-base-tn :index value :scale 1)) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne ret-lab) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab) (emit-label ret-lab)))) @@ -130,7 +132,7 @@ (loadw value object symbol-tls-index-slot other-pointer-lowtag) (inst mov value (make-ea :qword :base thread-base-tn :index value :scale 1)) - (inst cmp value unbound-marker-widetag) + (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) (emit-label ret-lab)))) @@ -183,24 +185,16 @@ (:info target not-p) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 - (if not-p - (let ((not-target (gen-label))) - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne not-target) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (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 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne target) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst cmp (make-ea :qword :base thread-base-tn :index value :scale 1) - unbound-marker-widetag) - (inst jmp :ne target))))) + (let ((check-unbound-label (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value + (make-ea :qword :base thread-base-tn :index value :scale 1)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp (if not-p :e :ne) target)))) #!-sb-thread (define-vop (boundp) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index f14185c..74c23e9 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -72,7 +72,8 @@ (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 :dword :scale 1 :index tls) + no-tls-value-marker-widetag) (inst jmp :z global-val) (inst fs-segment-prefix) (inst mov (make-ea :dword :scale 1 :index tls) value) @@ -107,14 +108,16 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let* ((err-lab (generate-error-code vop unbound-symbol-error object)) + (let* ((check-unbound-label (gen-label)) + (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 cmp value unbound-marker-widetag) - (inst jmp :ne ret-lab) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab) (emit-label ret-lab)))) @@ -133,7 +136,7 @@ (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 cmp value unbound-marker-widetag) + (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) (emit-label ret-lab)))) @@ -186,24 +189,16 @@ (:info target not-p) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 - (if not-p - (let ((not-target (gen-label))) - (loadw value object symbol-value-slot other-pointer-lowtag) - (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 jmp :e target) - (emit-label not-target)) - (progn - (loadw value object symbol-value-slot other-pointer-lowtag) - (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 jmp :ne target))))) + (let ((check-unbound-label (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 cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp (if not-p :e :ne) target)))) #!-sb-thread (define-vop (boundp) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index da410d3..a8f6aaf 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -1726,6 +1726,7 @@ gc_init_tables(void) scavtab[CHARACTER_WIDETAG] = scav_immediate; scavtab[SAP_WIDETAG] = scav_unboxed; scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; + scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate; scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance; #ifdef LISP_FEATURE_SPARC scavtab[FDEFN_WIDETAG] = scav_boxed; @@ -1860,6 +1861,7 @@ gc_init_tables(void) transother[CHARACTER_WIDETAG] = trans_immediate; transother[SAP_WIDETAG] = trans_unboxed; transother[UNBOUND_MARKER_WIDETAG] = trans_immediate; + transother[NO_TLS_VALUE_MARKER_WIDETAG] = trans_immediate; transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer; transother[INSTANCE_HEADER_WIDETAG] = trans_boxed; transother[FDEFN_WIDETAG] = trans_boxed; @@ -1999,6 +2001,7 @@ gc_init_tables(void) sizetab[CHARACTER_WIDETAG] = size_immediate; sizetab[SAP_WIDETAG] = size_unboxed; sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate; + sizetab[NO_TLS_VALUE_MARKER_WIDETAG] = size_immediate; sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer; sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed; sizetab[FDEFN_WIDETAG] = size_boxed; diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index b8df9f4..ea715e3 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -2135,6 +2135,7 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer) } switch (widetag_of(start_addr[0])) { case UNBOUND_MARKER_WIDETAG: + case NO_TLS_VALUE_MARKER_WIDETAG: case CHARACTER_WIDETAG: #if N_WORD_BITS == 64 case SINGLE_FLOAT_WIDETAG: diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 2324ca7..117e3ec 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -84,8 +84,8 @@ initial_thread_trampoline(struct thread *th) #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) lispobj *args = NULL; #endif - function = th->unbound_marker; - th->unbound_marker = UNBOUND_MARKER_WIDETAG; + function = th->no_tls_value_marker; + th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG; if(arch_os_thread_init(th)==0) return 1; if(th->os_thread < 1) lose("th->os_thread not set up right"); @@ -109,8 +109,8 @@ new_thread_trampoline(struct thread *th) { lispobj function; int result; - function = th->unbound_marker; - th->unbound_marker = UNBOUND_MARKER_WIDETAG; + function = th->no_tls_value_marker; + th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG; if(arch_os_thread_init(th)==0) { /* FIXME: handle error */ lose("arch_os_thread_init failed\n"); @@ -173,7 +173,7 @@ create_thread_struct(lispobj initial_function) { #ifdef LISP_FEATURE_SB_THREAD int i; for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++) - per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG; + per_thread->dynamic_values[i]=NO_TLS_VALUE_MARKER_WIDETAG; if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) SetSymbolValue (FREE_TLS_INDEX, @@ -268,7 +268,7 @@ create_thread_struct(lispobj initial_function) { memcpy(th->interrupt_data,global_interrupt_data, sizeof (struct interrupt_data)); - th->unbound_marker=initial_function; + th->no_tls_value_marker=initial_function; return th; } diff --git a/src/runtime/thread.h b/src/runtime/thread.h index 07b59dd..3f823cc 100644 --- a/src/runtime/thread.h +++ b/src/runtime/thread.h @@ -50,7 +50,7 @@ static inline lispobj SymbolValue(u64 tagged_symbol_pointer, void *thread) { lispobj r= ((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)]; - if(r!=UNBOUND_MARKER_WIDETAG) return r; + if(r!=NO_TLS_VALUE_MARKER_WIDETAG) return r; } #endif return sym->value; @@ -73,7 +73,7 @@ static inline void SetSymbolValue(u64 tagged_symbol_pointer,lispobj val, void *t if(thread && sym->tls_index) { lispobj *pr= &(((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)]); - if(*pr!= UNBOUND_MARKER_WIDETAG) { + if(*pr!=NO_TLS_VALUE_MARKER_WIDETAG) { *pr=val; return; } diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 7d5e99d..40462d8 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -442,5 +442,12 @@ (compiled-res (funcall (compile nil form))) (real-res (- 1 (aref (funcall (eval #'bit-not) v) 0)))) (assert (equal compiled-res real-res))) + +;; bug reported on sbcl-devel by Hannu Koivisto on 2005-08-10 +(defvar *hannu-trap* nil) +(progv '(*hannu-trap*) '() + (setq *hannu-trap* t)) +(assert (not *hannu-trap*)) + (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 6801619..157e64e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.4.4" +"0.9.4.5" -- 1.7.10.4