Fix arena inefficiency and minor bugs

* The wasted space calculation was completely wrong
* Initialize per-arena mutex in NEW-ARENA
* Use sysV ABI C call convention for win32
* Record enough state for every thread to remember where it
  last allocated in every arena
* Improve heap->arena pointer finder

src/code/arena.lisp

@@ -24,12 +24,6 @@
 (defmacro arena-memblk-next (memblk) `(sap-ref-sap ,memblk ,(ash 2 word-shift)))
 (defmacro arena-memblk-padword (memblk) `(sap-ref-sap ,memblk ,(ash 3 word-shift)))
 
-;;; Initial block holds a memblk (4 words) plus the arena structure itself,
-;;; and so the initial free pointer is immediately after those.
-;;; ARENA length must be rounded to even after adding the header, as is tradition.
-(defconstant memblk-preamble-size
-  (ash (+ (align-up (1+ (sb-kernel::type-dd-length arena)) 2) 4) word-shift))
-
 (defmacro do-arena-blocks ((blkvar arena) &body body)
   ;; bind BLK to a SAP pointing to successive 'struct memblk' in arena
   `(let ((,blkvar (int-sap (arena-first-block ,arena))))
@@ -47,19 +41,21 @@
   (when (arena-p (thread-current-arena))
     (switch-to-arena 0)))
 
+(define-load-time-global *arena-index-generator* 0)
+(declaim (fixnum *arena-index-generator*))
+(define-load-time-global *arena-lock* (sb-thread:make-mutex))
+
 ;;; Release all memblks back to the OS, except the first one associated with this arena.
 (defun rewind-arena (arena)
   #+system-tlabs
-  (let ((first (arena-first-block arena)))
-    (when (eql (arena-link arena) 0) ; never used
-      (return-from rewind-arena arena))
-    (alien-funcall (extern-alien "arena_release_memblks" (function void unsigned))
-                   (get-lisp-obj-address arena))
-    (let ((blk (int-sap first)))
-      (setf (arena-memblk-next blk) (int-sap 0) ; no next
-            (arena-memblk-freeptr blk) (sap+ blk memblk-preamble-size)))
-    (setf (arena-length arena) (arena-initial-size arena)
-          (arena-cookie arena) (cons t t)))
+  (cond ((= (arena-token arena) most-positive-word)
+         (bug "Arena token overflow. Need to implement double-precision count"))
+        ((eql (arena-link arena) 0)) ; never used - do nothing
+        (t
+         (alien-funcall (extern-alien "arena_release_memblks" (function void unsigned))
+                        (get-lisp-obj-address arena))
+         (setf (arena-bytes-wasted arena) 0)
+         (incf (arena-token arena))))
   arena)
 
 ;;; The arena structure has to be created in the arena,
@@ -74,36 +70,19 @@
 one or more times, not to exceed MAX-EXTENSIONS times"
   #-system-tlabs :placeholder
   #+system-tlabs
-  (let* ((memblk (sb-alien::%make-alien size)) ; use malloc()
-         (layout (find-layout 'arena))
-         ;; size of 'struct arena_memblk'
-         (struct-base (sap+ memblk (* 4 n-word-bytes))))
-    ;; This memory isn't pre-zeroed
-    (setf (sap-ref-word struct-base 0)
-          (compute-object-header (1+ (dd-length (wrapper-dd layout)))
-                                 instance-widetag))
-    (let ((arena (%make-lisp-obj (sap-int (sap+ struct-base instance-pointer-lowtag)))))
-      (%set-instance-layout arena layout)
-      (setf (arena-max-extensions arena) max-extensions
-            (arena-growth-amount arena) growth-amount)
-      (setf (arena-initial-size arena) size
-            (arena-growth-amount arena) growth-amount
-            (arena-max-extensions arena) max-extensions
-            (arena-length arena) size
-            (arena-extension-count arena) 0
-            (arena-pthr-mutex arena) 0
-            (arena-cookie arena) 0
-            (arena-link arena) 0
-            (arena-userdata arena) nil)
-      (setf (arena-memblk-freeptr memblk) (sap+ memblk memblk-preamble-size)
-            (arena-memblk-limit memblk) (sap+ memblk size)
-            (arena-memblk-next memblk) (int-sap 0)
-            (arena-memblk-padword memblk) (int-sap 0))
-      ;; Point the arena to its block
-      (setf (arena-first-block arena) (sap-int memblk)
-            (arena-current-block arena) (sap-int memblk))
-      (setf (arena-cookie arena) (cons t t)) ; any unique object
-      arena)))
+  (let ((layout (find-layout 'arena))
+        (index (with-system-mutex (*arena-lock*) (incf *arena-index-generator*)))
+        (arena (%make-lisp-obj
+                (alien-funcall (extern-alien "sbcl_new_arena" (function unsigned unsigned))
+                               size))))
+    (%set-instance-layout arena layout)
+    (setf (arena-max-extensions arena) max-extensions
+          (arena-growth-amount arena) growth-amount
+          (arena-max-extensions arena) max-extensions
+          (arena-index arena) index
+          (arena-token arena) 1
+          (arena-userdata arena) nil)
+    arena))
 
 ;;; Once destroyed, it is not legal to access the structure
 ;;; since the structure itself is in the arena.
@@ -228,3 +207,10 @@ one or more times, not to exceed MAX-EXTENSIONS times"
       (dotimes (i 10) (sb-ext:atomic-push (cons 3 i) *foo*))
       (sb-thread:join-thread t1)
       (sb-thread:join-thread t2))))
+
+(defmethod print-object ((self arena) stream)
+  (print-unreadable-object (self stream :type t :identity t)
+    (format stream "id=~D used=~D waste=~D"
+            (arena-index self)
+            (arena-bytes-used self)
+            (arena-bytes-wasted self))))

src/code/thread-structs.lisp

@@ -141,7 +141,6 @@ in future versions."
 
   ;; On succesful execution of the thread's lambda, a list of values.
   (result 0)
-  (arena-cookie)
   ;; The completion condition _could_ be manifested as a condition var, but a difficulty
   ;; in doing so is that condition vars can always experience a spurious wakeup.
   ;; Dealing with timeouts becomes troublesome then. But we can utilize the fact that

src/cold/warm.lisp

@@ -170,7 +170,9 @@ sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**))
                     (ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
                      ((t)
                       (let ((sb-c::*source-namestring* fullname)
-                            (sb-c::*force-system-tlab* (search "src/pcl" stem))
+                            (sb-c::*force-system-tlab*
+                             (or (search "src/pcl" stem)
+                                 (search "src/code/aprof" stem)))
                             (sb-ext:*derive-function-types*
                               (unless (search "/pcl/" stem)
                                 t)))

src/compiler/generic/late-objdef.lisp

@@ -252,7 +252,6 @@ static inline lispobj compute_lispobj(lispobj* base_addr) {
   ;; Address of the one mandatory 'struct arena_memblk' for this arena
   (first-block 0 :type word)
   ;; Arena allocation parameters
-  (initial-size 0 :type word)
   (growth-amount 0 :type word) ; additive
   (max-extensions 0 :type word)
   ;; Sum of sizes of currently allocated blocks
@@ -263,11 +262,11 @@ static inline lispobj compute_lispobj(lispobj* base_addr) {
   ;; How may times extended since allocation or most recent rewind.
   ;; This is for bounding the maximum extension.
   (extension-count 0 :type word)
-  ;; A mutex needed when extending the arena.
-  (pthr-mutex 0 :type word)
-  ;; an opaque value which can be used by a threads in a thread pool to detect
-  ;; that this arena was reset, by comparing to a cached value in the thread.
-  (cookie 0)
+  ;; Small integer identifier starting from 0
+  (index 0 :type fixnum)
+  ;; a counter that increments on each rewind, and which can be used by a threads
+  ;; in a pool to detect that their cached TLAB pointers are invalid
+  (token 0 :type word)
   userdata
   ;; Link for global chain of all arenas, needed for GC when 'scavenge_arenas' is 1,
   ;; so that GC can find all in-use arenas.

src/compiler/generic/objdef.lisp

@@ -562,7 +562,6 @@ during backtrace.
   ;; Statistical CPU profiler data recording buffer
   (sprof-data)
   ;;
-  (arena-savearea :c-type "arena_state" :length 7)
   (arena)
 
   #+x86 (tls-cookie)                          ;  LDT index

src/runtime/arena.c

@@ -12,7 +12,7 @@
 #include "gencgc-private.h"
 #include "lispregs.h"
 #include "genesis/arena.h"
-#include "thread.h" // for mutex_acquire() stub if no pthreads
+#include "thread.h"
 
 extern void acquire_gc_page_table_lock(), release_gc_page_table_lock();
 extern lispobj * component_ptr_from_pc(char *pc);
@@ -26,7 +26,36 @@ struct arena_memblk {
     uword_t padding; // always 0
 };
 
-void switch_to_arena(lispobj arena_taggedptr,
+lispobj sbcl_new_arena(size_t size)
+{
+    // First 3 objects in the arena:
+    //   Arena
+    //   Mutex
+    //   Memblk
+    struct arena* arena = malloc(size);
+    memset(arena, 0, sizeof *arena);
+    struct arena_memblk* block =
+      (void*)((char*)arena + ALIGN_UP(sizeof (struct arena), 2*N_WORD_BYTES));
+    // arenas require threads, but the header for the mutex definition
+    // might not have been included if #-sb-thread
+#ifdef LISP_FEATURE_SB_THREAD
+#ifdef LISP_FEATURE_WIN32
+    CRITICAL_SECTION *mutex = (void*)block;
+    InitializeCriticalSection(mutex);
+#else
+    pthread_mutex_t* mutex = (void*)block;
+    pthread_mutex_init(mutex, 0);
+#endif
+    block = (void*)((char*)block + ALIGN_UP(sizeof *mutex, 2*N_WORD_BYTES));
+#endif
+    block->freeptr = (char*)block + sizeof *block;
+    block->limit = (char*)arena + size;
+    arena->uw_length = size;
+    arena->uw_current_block = arena->uw_first_block = (uword_t)block;
+    return make_lispobj(arena, INSTANCE_POINTER_LOWTAG);
+}
+
+void AMD64_SYSV_ABI switch_to_arena(lispobj arena_taggedptr,
                      __attribute__((unused)) lispobj* ra) // return address
 {
     struct arena* arena = (void*)native_pointer(arena_taggedptr);
@@ -39,73 +68,76 @@ void switch_to_arena(lispobj arena_taggedptr,
             (arena ? arena : (void*)th->arena),
             (uword_t)ra, id);
 #endif
-    arena_state* savearea = &th->arena_savearea;
-    struct thread_instance *lispthread = (void*)native_pointer(th->lisp_thread);
-    if (!arena) { // finished with the arena
-        gc_assert(th->arena); // must have been an arena in use
-        // Compute the number of bytes that could have been used
-        int remaining = 0;
-        if (th->mixed_tlab.start_addr)
-            remaining += (char*)th->mixed_tlab.free_pointer - (char*)th->mixed_tlab.start_addr;
-        if (th->cons_tlab.start_addr)
-            remaining += (char*)th->cons_tlab.free_pointer - (char*)th->cons_tlab.start_addr;
-        struct arena* in_use_arena = (void*)native_pointer(th->arena);
-        __sync_fetch_and_add(&in_use_arena->uw_bytes_wasted, remaining);
-        lispthread->arena_cookie = // Capture the timestamp of last use (a/k/a cookie)
-            ((struct arena*)native_pointer(th->arena))->cookie;
-        // Copy the TLABs to the thread's arena save area
-        // so that allocation might pick up where it left off.
-        savearea->arena = th->arena;
-        savearea->mixed = th->mixed_tlab;
-        savearea->cons = th->cons_tlab;
-        // Indicate that the tlabs have no space remaining.
-        gc_set_region_empty(&th->mixed_tlab);
-        gc_set_region_empty(&th->cons_tlab);
-
-    } else { // switching from the dynamic space to an arena
+    if (arena) { // switching from the dynamic space to an arena
         if (th->arena)
             lose("arena error: can't switch from %p to %p", (void*)th->arena, arena);
+        // Page table lock guards the arena chain, as well as the page table
         acquire_gc_page_table_lock();
         // See if this arena has ever been switched to,
         // and if not, then add it into 'arena_chain'.
         if (!arena->link) {
             arena->link = arena_chain ? arena_chain : NIL;
             arena_chain = arena_taggedptr;
-#ifdef LISP_FEATURE_SB_THREAD
-            // And ensure that this arena has a mutex for growing it
-#ifndef LISP_FEATURE_WIN32
-            pthread_mutex_t* arena_mutex = malloc(sizeof (pthread_mutex_t));
-            pthread_mutex_init(arena_mutex, 0);
-#else
-            CRITICAL_SECTION* arena_mutex = malloc(sizeof(CRITICAL_SECTION));
-            InitializeCriticalSection(arena_mutex);
-#endif
-            arena->uw_pthr_mutex = (uword_t)arena_mutex;
-#endif
         }
         // Close only the non-system regions
         if (th->mixed_tlab.start_addr) gc_close_region(&th->mixed_tlab, PAGE_TYPE_MIXED);
         if (th->cons_tlab.start_addr) gc_close_region(&th->cons_tlab, PAGE_TYPE_CONS);
         release_gc_page_table_lock();
-        /* If the last arena that this thread worked with is the same as 'arena'
-         * and the cookie in 'arena' matches the thread's cached copy,
-         * then restore the TLABs to their prior state. This way we aren't forced to
-         * discard memory every time a thread-pool worker dequeues a task.
-         * It can usually pick up where it was in the arena, as long as
-         * it is acting on the same arena as before */
-        if (savearea->arena == arena_taggedptr && arena->cookie == lispthread->arena_cookie) {
-            th->mixed_tlab = savearea->mixed;
-            th->cons_tlab = savearea->cons;
+        // Ensure that this thread has enough space in its save area for the arena index.
+        // Note that indices are 1-based, so subtract 1 to get an array index.
+        int arena_index = fixnum_value(arena->index);
+        struct extra_thread_data *extra_data = thread_extra_data(th);
+        if (arena_index > extra_data->arena_count) {
+            arena_state* new = calloc(arena_index, sizeof (arena_state));
+            if (extra_data->arena_count > 0) {
+                memcpy(new, extra_data->arena_savearea,
+                       extra_data->arena_count * sizeof (arena_state));
+                free(extra_data->arena_savearea);
+            }
+            extra_data->arena_count = arena_index;
+            extra_data->arena_savearea = new;
         }
-        memset(&th->arena_savearea, 0, sizeof th->arena_savearea);
+        arena_state* state = &extra_data->arena_savearea[arena_index-1];
+        /* If the state's token matches the arena token, then the TLAB free/end pointers
+         * are valid, and this thread can resume allocating where it left off. */
+        if (state->token == arena->uw_token) { // arena was not rewound
+            th->mixed_tlab = state->mixed;
+            th->cons_tlab  = state->cons;
+        } else {
+#if 0
+            // Rewinding which causes the tail of a TLAB not to be used doesn't
+            // count as waste, but I may want to see the number anyway
+            int waste = 0;
+            if (state->mixed.start_addr)
+                waste += (char*)state->mixed.end_addr - (char*)state->mixed.free_pointer;
+            if (state->cons.start_addr)
+                waste += (char*)state->cons.end_addr - (char*)state->cons.free_pointer;
+#endif
+        }
+        memset(state, 0, sizeof (arena_state));
+    } else { // finished with the arena
+        gc_assert(th->arena); // must have been an arena in use
+        struct arena* old_arena = (void*)native_pointer(th->arena);
+        int arena_index = fixnum_value(old_arena->index);
+        struct extra_thread_data *extra_data = thread_extra_data(th);
+        arena_state* state = &extra_data->arena_savearea[arena_index-1];
+        // Copy the TLABs to the thread's arena save area
+        state->token = old_arena->uw_token;
+        state->mixed = th->mixed_tlab;
+        state->cons  = th->cons_tlab;
+        // Indicate that the tlabs have no space remaining.
+        gc_set_region_empty(&th->mixed_tlab);
+        gc_set_region_empty(&th->cons_tlab);
     }
     th->arena = arena_taggedptr;
 }
 
-/* lisp defstructs manifested as C structs have all fields as 'unsigned word'
- * but the mutex is a pthread_mutex_t* which is annoying to cast all the time */
-#define ARENA_MUTEX_ACQUIRE(a) ignore_value(mutex_acquire((void*)a->uw_pthr_mutex))
-#define ARENA_MUTEX_RELEASE(a) ignore_value(mutex_release((void*)a->uw_pthr_mutex))
+static inline void* arena_mutex(struct arena* a) {
+    return (void*)((char*)a + ALIGN_UP(sizeof (struct arena), 2*N_WORD_BYTES));
+}
+
+#define ARENA_MUTEX_ACQUIRE(a) ignore_value(mutex_acquire(arena_mutex(a)))
+#define ARENA_MUTEX_RELEASE(a) ignore_value(mutex_release(arena_mutex(a)))
 
 static void* memblk_claim_subrange(struct arena* a, struct arena_memblk* mem,
                                    sword_t nbytes, int filler)
@@ -124,12 +156,12 @@ static void* memblk_claim_subrange(struct arena* a, struct arena_memblk* mem,
             }  else {
                 // really add an extension block
                 if (a->uw_extension_count == a->uw_max_extensions) { // can't extend further
-                    ignore_value(mutex_release((void*)a->uw_pthr_mutex));
+                    ARENA_MUTEX_RELEASE(a);
                     lose("Fatal: arena memory exhausted");
                 }
                 char* new_mem = malloc(a->uw_growth_amount);
                 if (new_mem == 0) {
-                    ignore_value(mutex_release((void*)a->uw_pthr_mutex));
+                    ARENA_MUTEX_RELEASE(a);
                     lose("Fatal: arena memory exhausted and could not obtain more memory");
                 }
                 struct arena_memblk* extension= (void*)new_mem;
@@ -138,6 +170,7 @@ static void* memblk_claim_subrange(struct arena* a, struct arena_memblk* mem,
                 extension->next = NULL;
                 extension->padding = 0;
                 a->uw_length += a->uw_growth_amount; // tally up the total length
+                a->uw_extension_count++;
                 mem->next = extension;
                 // Other threads can start using the new block already
                 a->uw_current_block = (lispobj)extension;
@@ -182,6 +215,8 @@ lispobj* handle_arena_alloc(struct thread* th, struct alloc_region* region,
      *     Don't refill the TLAB; just make the new object as a discrete claim.
      */
     if (avail < min_keep) { // case 1
+        struct arena* in_use_arena = (void*)native_pointer(th->arena);
+        __sync_fetch_and_add(&in_use_arena->uw_bytes_wasted, avail);
         long total_request = nbytes + 8192;
         region->start_addr = claim_new_subrange((void*)native_pointer(th->arena),
                                                 total_request, filler);
@@ -207,6 +242,7 @@ long arena_bytes_used(lispobj arena_taggedptr)
     return sum;
 }
 /* Release successor blocks of this arena, keeping only the first */
+/* TODO: in debug mode, assert that no threads are using the arena */
 void arena_release_memblks(lispobj arena_taggedptr)
 {
     struct arena* arena = (void*)native_pointer(arena_taggedptr);
@@ -219,7 +255,10 @@ void arena_release_memblks(lispobj arena_taggedptr)
         block = next;
     }
     arena->uw_current_block = arena->uw_first_block;
+    first->freeptr = (char*)first + sizeof (struct arena_memblk);
     first->next = NULL;
+    arena->uw_extension_count = 0;
+    arena->uw_length = first->limit - (char*)arena;
     ARENA_MUTEX_RELEASE(arena);
 }
 
@@ -250,22 +289,11 @@ void unlink_gc_arena(lispobj arena) // arena is a tagged pointer
 int scavenge_arenas = 1;
 void gc_scavenge_arenas()
 {
-    /* Always scavenge the 'cookie' in each arena since that's a heap object.
-     * It has to be, so that threads don't point to an object that can disappear.
-     * The cookie could probably be a raw word, but it'd be subject to wraparound. */
-    lispobj chain = arena_chain;
-    if (chain) {
-        do {
-            struct arena* a = (void*)native_pointer(chain);
-            fprintf(stderr, "arena %p has cookie %"OBJ_FMTX"\n", a, a->cookie);
-            scavenge(&a->cookie, 1);
-            chain = a->link;
-        } while (chain != NIL);
-    }
     if (!scavenge_arenas) {
       fprintf(stderr, "GC will NOT scavenge arena contents\n");
       return;
     }
+    lispobj chain = arena_chain;
     /*
      * If there are arenas in use, then treat them as roots.
      * TODO: devise a way to avoid scanning all of all arenas.
@@ -310,16 +338,6 @@ static lispobj find_containing_arena(lispobj ptr) {
     return 0;
 }
 
-static void add_to_result(struct result* res, lispobj val)
-{
-    if (res->count >= vector_len(res->v)) {
-      fprintf(stderr, "WARNING: out of buffer space\n");
-      return;
-    }
-    res->v->data[res->count] = val;
-    ++res->count;
-}
-
 static lispobj target_arena;
 static inline boolean interesting_arena_pointer_p(lispobj ptr)
 {
@@ -334,79 +352,68 @@ static inline boolean interesting_arena_pointer_p(lispobj ptr)
     return 1;
 }
 
-static void scan_thread_words(lispobj* start, lispobj* end, struct result* res,
-                              __attribute__((unused)) char* legend,
-                              struct thread* th, int *printed)
-{
-    gc_assert(arena_chain);
-    int precise = res != NULL;
-    lispobj* where = start;
-    for ( ; where < end ; ++where) {
-        lispobj word = *where;
-        if (interesting_arena_pointer_p(word)) {
-            if (!*printed) { // print thread identifier once only
-              fprintf(stderr, "in thread %p:\n", th);
-              *printed = 1;
-            }
-            /*
-            fprintf(stderr, "word @ %p -> %lx %s (%s)\n", where, word, precise?"precise":"ambiguous",
-            legend);*/
-            if (precise) add_to_result(res, (lispobj)where);
-        }
-    }
-}
-
 extern void gc_stop_the_world(), gc_start_the_world();
 extern void prepare_for_full_mark_phase(), execute_full_mark_phase(), dispose_markbits();
 extern int (*stray_pointer_detector_fn)(lispobj);
 extern lispobj stray_pointer_source_obj;
 
-static int points_to_arena_interior(lispobj ptr) {
-    if (!interesting_arena_pointer_p(ptr)) return 0;
-    // So this pointer points an arena of interest
+static void add_to_result(lispobj val)
+{
     if (searchresult.count >= vector_len(searchresult.v)) {
         fprintf(stderr, "WARNING: out of buffer space\n");
     } else {
         int ct = searchresult.count;
-        searchresult.v->data[ct] = stray_pointer_source_obj;
+        searchresult.v->data[ct] = val;
         searchresult.count++;
     }
+}
+
+static int record_if_points_to_arena_interior(lispobj ptr) {
+    if (!interesting_arena_pointer_p(ptr)) return 0;
+    add_to_result(stray_pointer_source_obj);
     return 0; // Returned value does nothing now.
 }
 
+static void scan_thread_words(lispobj* start, lispobj* end)
+{
+    gc_assert(arena_chain);
+    lispobj* where = start;
+    for ( ; where < end ; ++where) {
+        lispobj word = *where;
+        if (interesting_arena_pointer_p(word)) add_to_result((lispobj)where);
+    }
+}
+
 int find_dynspace_to_arena_ptrs(lispobj arena, lispobj result_buffer)
 {
     target_arena = arena;
     // check for suspcious pointers to arena from thread roots
     searchresult.v = VECTOR(result_buffer);
-    stray_pointer_detector_fn = points_to_arena_interior;
+    stray_pointer_detector_fn = record_if_points_to_arena_interior;
 
     gc_stop_the_world();
     prepare_for_full_mark_phase();
     fprintf(stderr, "Checking threads...\n");
     struct thread* th;
-    int printed;
     for_each_thread(th) {
         if (th->state_word.state == STATE_DEAD) continue;
         stray_pointer_source_obj = (lispobj)th;
-        printed = 0;
-#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+        // This produces false positives
+#if 0 /*def LISP_FEATURE_C_STACK_IS_CONTROL_STACK*/
         if (th == get_sb_vm_thread()) {
-          scan_thread_words(&result_buffer, th->control_stack_end, 0, "stack", th, &printed);
+          scan_thread_words(&result_buffer, th->control_stack_end);
         } else {
           int ici = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX, th));
           if (ici != 1) lose("can't find interrupt context");
           lispobj sp = *os_context_register_addr(nth_interrupt_context(0, th), reg_SP);
-          scan_thread_words((lispobj*)sp, th->control_stack_end, 0, "stack", th, &printed);
+          scan_thread_words((lispobj*)sp, th->control_stack_end);
         }
 #endif
         scan_thread_words((lispobj*)th->binding_stack_start,
-                          (lispobj*)get_binding_stack_pointer(th), 0,
-                          "bindings", th,  &printed);
+                          (lispobj*)get_binding_stack_pointer(th));
         lispobj* from = &th->lisp_thread;
         lispobj* to = (lispobj*)(SymbolValue(FREE_TLS_INDEX,0) + (char*)th);
-        scan_thread_words(from,to, 0, "TLS", th, &printed);
-        stray_pointer_source_obj = 0;
+        scan_thread_words(from, to);
     }
     fprintf(stderr, "Checking dynamic space...\n");
     execute_full_mark_phase();

src/runtime/gencgc-alloc-region.h

@@ -24,7 +24,7 @@ struct alloc_region {
 typedef struct {
     struct alloc_region cons;
     struct alloc_region mixed;
-    lispobj arena; // tagged pointer
+    uword_t token;
 } arena_state;
 
 // Macro to statically initialize instead of using set_region_empty()

src/runtime/thread.h

@@ -116,6 +116,8 @@ struct extra_thread_data
     HANDLE synchronous_io_handle_and_flag;
     void* waiting_on_address; // used only if #+sb-futex
 #endif
+    int arena_count; // number of structures in arena_saveareas
+    arena_state* arena_savearea;
 };
 #define thread_extra_data(thread) \
   ((struct extra_thread_data*)((char*)(thread) + dynamic_values_bytes))

tests/arena.impure.lisp

@@ -1,8 +1,11 @@
 #-system-tlabs (invoke-restart 'run-tests::skip-file)
-
+#+parallel-test-runner (invoke-restart 'run-tests::skip-file) ; crashes and hangs
 (in-package sb-vm)
 
-(defvar *arena* (new-arena 1048576 1048576))
+(defvar *many-arenas*
+  (coerce (loop for i below 10 collect (new-arena 1048576)) 'vector))
+
+(defvar *arena* (aref *many-arenas* 0))
 ;;; This REWIND is strictly unnecessary. It simply should not crash
 (rewind-arena *arena*)
 
@@ -59,15 +62,37 @@
       (assert (heap-allocated-p namestring))
       (assert (pathname-parts-heap-p pathname))
       (assert (not (heap-allocated-p answer)))
-      ;; FIXME: special bindings aren't found- a regression or new finder just never did it?
-      ;;    (declare (special *answerstring*))
+      ;; 1. check that a global symbol value can be found
       (unwind-protect
            (progn
-             (setq *answerstring* answer) ; simulate special binding I guess
+             (setq *answerstring* answer)
              ;; user's string went to the arena, and detector finds the source object
              (let ((finder-result (sb-vm:c-find-heap->arena)))
                (assert (equal finder-result '(*answerstring*)))))
-        (makunbound '*answerstring*)))))
+        (makunbound '*answerstring*))
+      ;; 2. check that a thread-local binding can be found
+      (let ((*answerstring* answer))
+        (let ((finder-result (sb-vm:c-find-heap->arena)))
+          (assert (and finder-result (fixnump (car finder-result))))
+          ;; Ideally the result of c-find-heap->arena would have already converted
+          ;; thread stack locations to the symbol name in that location,
+          (let* ((sap (int-sap (ash (car finder-result) n-fixnum-tag-bits)))
+                 (val (sap-ref-lispobj sap 0))
+                 (tlsindex (sap- sap
+                                (int-sap (sb-thread::thread-primitive-thread
+                                          sb-thread:*current-thread*))))
+                 (symbol (sb-impl::find-symbol-from-tls-index tlsindex)))
+            (assert (eq val answer))
+            (assert (eq symbol '*answerstring*))))
+        ;; 3. check that a shadowed binding can be found
+        (let ((*answerstring* "hi"))
+          (let ((finder-result (sb-vm:c-find-heap->arena)))
+            (assert (and finder-result (fixnump (car finder-result))))
+            (let* ((sap (sap+ (int-sap (ash (car finder-result) n-fixnum-tag-bits))
+                              (- n-word-bytes)))
+                   (tlsindex (sap-ref-word sap 0))
+                   (symbol (sb-impl::find-symbol-from-tls-index tlsindex)))
+              (assert (eq symbol '*answerstring*)))))))))
 
 ;;;
 
@@ -159,7 +184,7 @@
 (defvar ptr1 (cons (f arena1) 'foo))
 (defvar ptr2 (g arena2))
 
-(test-util:with-test (:name :find-ptrs-all-arenas)
+(test-util:with-test (:name :find-ptrs-all-arenas :skipped-on :win32)
   (let ((result (c-find-heap->arena)))
     ;; There should be a cons pointing to ARENA1,
     ;; the cons which happens to be in PTR1
@@ -169,8 +194,38 @@
     ;; There should not be anything else
     (assert (= (length result) 2))))
 
-(test-util:with-test (:name :find-ptrs-specific-arena)
+(test-util:with-test (:name :find-ptrs-specific-arena :skipped-on :win32)
   (let ((result (c-find-heap->arena arena1)))
     (assert (equal result (list ptr1))))
   (let ((result (c-find-heap->arena arena2)))
     (assert (equal result '(ptr2)))))
+
+(defun use-up-some-space (n &aux (arenas *many-arenas*)
+                                 (bytes-used (make-array (length arenas)
+                                                         :initial-element 0)))
+  (dotimes (k n)
+    (let* ((i (mod k (length arenas)))
+           (arena (aref arenas i)))
+      (sb-vm:with-arena (arena)
+        (let ((object (make-array (+ 100 (random 100)))))
+          (incf (aref bytes-used i) (primitive-object-size object)))))
+    #+nil
+    (when (zerop (random 1000))
+      (let ((i (random (length arenas))))
+        (let ((arena (aref arenas i)))
+          (format t "~&REWINDING ~D~%" (arena-index arena))
+          (sb-vm:rewind-arena arena)
+          (sb-vm:with-arena (arena)
+            (test-util:opaque-identity (make-array 5)))))))
+  bytes-used)
+(test-util:with-test (:name :allocator-resumption)
+  (map nil 'rewind-arena *many-arenas*)
+  (let ((bytes-used-per-arena (use-up-some-space 10000)))
+    (dotimes (i (length *many-arenas*))
+      (let* ((est (aref bytes-used-per-arena i))
+             (act (arena-bytes-used (aref *many-arenas* i)))
+             (delta (- act est))
+             (frac (* 100 (/ delta act))))
+      (format t "Used: estimate=~D actual=~D diff=~,2f%~%"
+              est act frac)
+      (assert (< frac 1))))))