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

diff --git a/NEWS b/NEWS
index 890078b..af2db8d 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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*))
+
 \f
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 6801619..157e64e 100644 (file)
--- 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"