x86-64: Maintain a mapping of TLS index to symbol

src/assembly/x86-64/alloc.lisp

@@ -170,6 +170,14 @@
        ;; Must ignore the semaphore bit in the register's high half.
        (inst cmp :dword scratch-reg (thread-slot-ea thread-tls-size-slot))
        (inst jmp :ae tls-full)
+       ;; Fill in the tlsindex-to-symbol entry prior to setting the symbol's index,
+       ;; preserving the invariant in every thread that if a symbol has a nonzero index,
+       ;; then it is definitely in the map.
+       (inst push rbx-tn)
+       (inst mov rbx-tn (static-symbol-value-ea '*tls-symbol-map*))
+       (inst btc rbx-tn 63) ; fudge the array base address to "subtract out" bit 63 of scratch-reg
+       (inst mov (ea rbx-tn scratch-reg) symbol)
+       (inst pop rbx-tn)
        ;; scratch-reg goes into symbol's TLS and into the arg/result reg.
        (inst mov :dword (tls-index-of symbol) scratch-reg)
        (inst mov :dword result scratch-reg)

src/code/save.lisp

@@ -70,6 +70,7 @@
 (defconstant-eqx sb-kernel::+save-lisp-clobbered-globals+
     '#(sb-impl::*exit-lock*
        sb-vm::*allocator-mutex*
+       sb-vm::*tls-symbol-map*
        sb-thread::*make-thread-lock*
        sb-thread::*initial-thread*
        ;; Saving *JOINABLE-THREADS* could cause catastophic failure on restart.

src/compiler/generic/parms.lisp

@@ -232,6 +232,7 @@
     ;; threading support
     #+sb-thread sb-thread::*starting-threads*
     *free-tls-index* ; always exists for benefit of C runtime
+    *tls-symbol-map*
 
     #+(and x86-64 sb-thread (not gs-seg))
     sb-aprof::*n-profile-sites*

src/runtime/coreparse.c

@@ -1385,6 +1385,41 @@ init_coreparse_spaces(int n, struct coreparse_space* input)
     return output;
 }
 
+lispobj* tlsindex_to_symbol_map;
+static void construct_tls_map()
+{
+    int map_nbytes = dynamic_values_bytes;
+    tlsindex_to_symbol_map = checked_malloc(map_nbytes);
+    memset(tlsindex_to_symbol_map, 0xff, map_nbytes);
+    // A static Lisp symbol is slightly easier to access than a C symbol from Lisp
+    SYMBOL(TLS_SYMBOL_MAP)->value = (uword_t)tlsindex_to_symbol_map;
+
+    int offset;
+#define EXAMINE_OBJECT() if (widetag_of(where) == SYMBOL_WIDETAG && \
+    (offset = tls_index_of((struct symbol*)where)) != 0) \
+        tlsindex_to_symbol_map[offset>>WORD_SHIFT] = make_lispobj(where, OTHER_POINTER_LOWTAG)
+#ifdef LISP_FEATURE_MARK_REGION_GC
+# define SYMBOL_PAGE_TYPE PAGE_TYPE_MIXED
+#else
+# define SYMBOL_PAGE_TYPE PAGE_TYPE_SMALL_MIXED
+#endif
+    for (page_index_t p = 0; p < page_table_pages; p++) {
+        if ((page_table[p].type & PAGE_TYPE_MASK) != SYMBOL_PAGE_TYPE) continue;
+        lispobj* end = (lispobj*)page_address(p+1);
+        lispobj* where = next_object((lispobj*)page_address(p), 0, end);
+        for ( ; where ; where = next_object(where, object_size(where), end) ) EXAMINE_OBJECT();
+    }
+#ifdef LISP_FEATURE_IMMOBILE_SPACE
+    lispobj *where = (lispobj*)FIXEDOBJ_SPACE_START, *end = fixedobj_free_pointer;
+#elif defined LISP_FEATURE_PERMGEN
+    lispobj *where = (lispobj*)PERMGEN_SPACE_START, *end = permgen_space_free_pointer;
+#else
+    lispobj *where = (lispobj*)STATIC_SPACE_START, *end = where;
+#endif
+    for ( ; where < end ; where += object_size(where) ) EXAMINE_OBJECT();
+#undef EXAMINE_OBJECT
+}
+
 /* 'merge_core_pages': Tri-state flag to determine whether we attempt to mark
  * pages as targets for virtual memory deduplication via MADV_MERGEABLE.
  * 1: Yes
@@ -1548,6 +1583,7 @@ load_core_file(char *file, os_vm_offset_t file_offset, int merge_core_pages)
                 dynamic_values_bytes = (int)SymbolValue(FREE_TLS_INDEX,0) * 2;
                 // fprintf(stderr, "NOTE: TLS size increased to %x\n", dynamic_values_bytes);
             }
+            construct_tls_map();
 #else
             SYMBOL(FREE_TLS_INDEX)->value = sizeof (struct thread);
 #endif

src/runtime/gc-common.c

@@ -1305,6 +1305,18 @@ void smash_weak_pointers(void)
         }
     }
     weak_vectors = 0;
+
+    if (!tlsindex_to_symbol_map) return;
+    /* If the weak map is present, Lisp could potentially recycle unused TLS indices
+     * by finding an empty element below the free TLS index.  Not currently done */
+    int i;
+    int n_elements = dynamic_values_bytes / bytes_per_tls_symbol;
+    for (i=0; i<n_elements; ++i) {
+        lispobj symbol = tlsindex_to_symbol_map[i];
+        if (symbol != NO_TLS_VALUE_MARKER) {
+            TEST_WEAK_CELL(tlsindex_to_symbol_map[i], symbol, NO_TLS_VALUE_MARKER);
+        }
+    }
 }
 
 

src/runtime/globals.h

@@ -78,6 +78,7 @@ extern os_vm_address_t alloc_profile_buffer;
 extern lispobj alloc_profile_data; // Lisp SIMPLE-VECTOR
 
 extern lispobj arena_chain;
+extern lispobj* tlsindex_to_symbol_map;
 
 #if !defined(LISP_FEATURE_SB_THREAD)
 extern lispobj *current_control_stack_pointer;

src/runtime/thread.h

@@ -358,4 +358,6 @@ extern void scrub_thread_control_stack(struct thread *);
 extern void scavenge_control_stack(struct thread *th);
 extern void gc_close_thread_regions(struct thread*, int);
 
+static const int bytes_per_tls_symbol = N_WORD_BYTES;
+
 #endif /* _INCLUDE_THREAD_H_ */

tests/x86-64-codegen.impure.lisp

@@ -1427,3 +1427,13 @@
               (push (cons x y) alist)))))
     ;; should have 1 call to list-alloc-tramp, not one for the cons of x, y and one for push
     (assert (= 1 (count 'sb-c:call (get-simple-fun-instruction-model f) :key 'second)))))
+
+(with-test (:name :tls-symbol-map)
+  (let ((sap (sb-sys:int-sap (ash (symbol-value 'sb-vm::*tls-symbol-map*)
+                                  sb-vm:n-fixnum-tag-bits)))
+        (limit (ash (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits)
+                    (- sb-vm:word-shift))))
+    (dotimes (i limit)
+      (unless (= (sb-sys:sap-ref-word sap (ash i sb-vm:word-shift)) sb-vm:no-tls-value-marker)
+        (let ((sym (sb-sys:sap-ref-lispobj sap (ash i sb-vm:word-shift))))
+          (assert (= (sb-kernel:symbol-tls-index sym) (ash i sb-vm:word-shift))))))))