Interface to the SML# concurrent mark/sweep GC

This is work-in-progress, however it does usually complete self-build
on Linux (less so on macOS) and can run some of the regression suite.
This commit is mainly for other developers to view the state.

Using the "buildit" script which is for now the suggested way to build,
make-target-2 will show (in lines prefixed with "Stack scan") pause times
as low as 5 microseconds, or up to maybe 100 microseconds on the high end.

Anything having to do with thread start/exit is potentially broken,
and there are some obviously missing pieces which are denoted by purposely-
inserted lose() calls.

buildit

@@ -0,0 +1,8 @@
+#!/bin/sh
+
+export SMLGC=1
+host=$HOME/sbcl/pristine/bin/sbcl
+
+SBCL_MAKE_PARALLEL=8,0 sh make.sh $host --prefix=$HOME/sbcl/pristine \
+  --without-soft-card-marks --without-immobile-space --with-weak-vector-readbarrier \
+  --with-int4-breakpoints --without-sb-eval --with-sb-fasteval

contrib/sb-posix/interface.lisp

@@ -392,6 +392,10 @@ not supported."
     (let ((pid (posix-fork)))
       (when (= pid 0) ; child
         #+darwin (darwin-reinit)
+        (when (/= (extern-alien "use_smlgc" int) 0)
+          (alien-funcall (extern-alien "smlgc_init" (function void unsigned))
+                         (sb-ext:dynamic-space-size))
+          (alien-funcall (extern-alien "enable_collector_thread" (function void))))
         #+mark-region-gc (alien-funcall (extern-alien "thread_pool_init" (function void))))
       #+sb-thread (sb-impl::finalizer-thread-start)
       pid))

smlsharpgc/alloc_ptr.h

@@ -0,0 +1,15 @@
+#ifndef SMLSHARP__ALLOC_PTR_H__
+#define SMLSHARP__ALLOC_PTR_H__
+#include <stdint.h>
+typedef uint32_t sml_bmword_t;
+struct sml_bitptr { const sml_bmword_t *ptr; sml_bmword_t mask; };
+struct sml_bitptrw { sml_bmword_t *wptr; sml_bmword_t mask; };
+typedef struct sml_bitptr sml_bitptr_t;
+typedef struct sml_bitptrw sml_bitptrw_t;
+/* sizeof(struct alloc_ptr) must be power of 2 for performance */
+struct alloc_ptr {
+        sml_bitptr_t freebit;
+        char *free;
+        unsigned int blocksize_bytes;
+};
+#endif

smlsharpgc/control.c

@@ -4,15 +4,36 @@
  * @author UENO Katsuhiro
  */
 
+#ifdef HAVE_GENESIS_CONFIG
+#include "genesis/config.h"
+#include "genesis/thread.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
+#include "genesis/constants.h"
+#include "interr.h"
+#include <stdio.h>
+#include <string.h>
+#endif
 #include "smlsharp.h"
 #include <stdlib.h>
 #include "heap.h"
+#include <signal.h>
+
+int gc_verbose = 1;
 
 #ifndef WITHOUT_MULTITHREAD
 struct control {
-        _Atomic(unsigned int) state;
+  //_Atomic(unsigned int) state;
+        //unsigned int* statepointer;
         _Atomic(unsigned int) flags;
-        struct control *next;  /* double-linked list */
+        struct control *next;  /* singly-linked list */
+        // Deletion of the vm_thread (the 'struct thread' and all associated
+        // memory) can be done only while holding this lock.
+        // Also the thread is not allowed to completely exit (i.e. cease to be
+        // a valid pthread identifier) until clearing the vm_thread field,
+        // which is also required to be done under the lock.
+        pthread_mutex_t state_lock;
+        struct thread *vm_thread;
 };
 #endif /* !WITHOUT_MULTITHREAD */
 
@@ -43,6 +64,7 @@ struct sml_user {
                 void *bottom, *top;
                 struct frame_stack_range *next;
         } *frame_stack;
+        void *arbdata;
         void *exn_object;
 };
 
@@ -62,6 +84,9 @@ struct sml_worker {
 static _Atomic(struct control *) workers;
 static enum sml_sync_phase new_worker_phase = ASYNC;
 static sml_spinlock_t worker_creation_lock = SPIN_LOCK_INIT;
+union sml_alloc* get_worker_aps() {
+  return ((struct  sml_worker*)workers)->thread_local_heap;
+}
 #endif /* !WITHOUT_MULTITHREAD */
 
 #ifndef WITHOUT_MASSIVETHREADS
@@ -73,12 +98,22 @@ _Atomic(unsigned int) sml_check_flag;
 #define FLAG_GC      1U
 #define FLAG_SIGNAL  (~(-1U >> 1))
 
+int use_gcsignal = 1;
 #ifndef WITHOUT_CONCURRENCY
+#define USE_SYNC_SEM 1
+#ifdef USE_SYNC_SEM
+#include <semaphore.h>
+os_sem_t gc_sync_semaphore;
+#elif defined USE_SYNC_PIPE
+static int sync_pipe[2];
+#else
 static pthread_mutex_t sync_wait_lock = PTHREAD_MUTEX_INITIALIZER;
 static pthread_cond_t sync_wait_cond = PTHREAD_COND_INITIALIZER;
+#endif
 static _Atomic(unsigned int) sync_counter;
 #endif /* !WITHOUT_CONCURRENCY */
 
+#include <unistd.h>
 #ifndef WITHOUT_MULTITHREAD
 static void cancel(void *p)
 {
@@ -90,11 +125,31 @@ static void cancel(void *p)
          * but no clever programmer use it ;p).
          */
         fetch_or(relaxed, &((struct control *)p)->flags, CANCELED_FLAG);
+        TPRINTF(1, "set CANCELED_FLAG");
 }
 #endif /* WITHOUT_MULTITHREAD */
 
 worker_tlv_alloc(struct sml_worker *, current_worker, cancel);
 
+void sml_current_worker_set_thread(struct thread* thread, int set_aps) {
+    struct sml_worker *worker = worker_tlv_get(current_worker);
+    worker->control.vm_thread = thread;
+    if (thread) {
+        spin_lock(&worker_creation_lock);
+        thread->gc_phase = ACTIVE(new_worker_phase);
+        spin_unlock(&worker_creation_lock);
+    }
+    if (set_aps) {
+    }
+}
+void sml_current_user_set_arbdata(void* data) {
+    struct sml_worker *worker = worker_tlv_get(current_worker);
+    struct sml_user *user = worker->user;
+    fprintf(stderr, "current SML worker = %p, user = %p\n", worker, user);
+    user->arbdata = data;
+}
+void* get_sml_user_arbdata(struct sml_user* user) { return user->arbdata; }
+
 #ifndef WITHOUT_MASSIVETHREADS
 user_tlv_alloc(struct sml_user *, current_user, cancel);
 #endif /* !WITHOUT_MASSIVETHREADS */
@@ -168,10 +223,15 @@ control_insert(_Atomic(struct control *) *list, struct control *item)
 #endif /* !WITHOUT_MULTITHREAD */
 
 #ifndef WITHOUT_MULTITHREAD
+extern __thread struct thread *current_thread;
+// pointer to control state (stored in the SBCL 'struct thread')
+#define pCTRL_STATE(c) &(c).vm_thread->gc_phase
 static void
 control_init(struct control *control, unsigned int state)
 {
-        atomic_init(&control->state, state);
+        struct thread* vm_thread = control->vm_thread;
+        if (!vm_thread) vm_thread = control->vm_thread = current_thread;
+        if (vm_thread) atomic_init(&vm_thread->gc_phase, state);
         atomic_init(&control->flags, 0);
 }
 #endif /* !WITHOUT_MULTITHREAD */
@@ -183,12 +243,12 @@ activate(struct control *control)
         unsigned int old;
 
         /* all updates by other threads must happen before here */
-        old = fetch_and(acquire, &control->state, ~INACTIVE_FLAG);
+        old = fetch_and(acquire, pCTRL_STATE(*control), ~INACTIVE_FLAG);
         while (IS_ACTIVE(old)) {
                 sched_yield();
-                old = fetch_and(acquire, &control->state, ~INACTIVE_FLAG);
+                old = fetch_and(acquire, pCTRL_STATE(*control), ~INACTIVE_FLAG);
         }
-        assert(IS_ACTIVE(load_relaxed(&control->state)));
+        assert(IS_ACTIVE(load_relaxed(pCTRL_STATE(*control))));
 }
 #endif /* !WITHOUT_MULTITHREAD */
 
@@ -242,7 +302,11 @@ worker_register(struct sml_worker *worker)
                 atomic_init(&worker->control.flags, PTHREAD_FLAG);
 #endif /* !WITHOUT_MASSIVETHREADS */
         spin_lock(&worker_creation_lock);
-        atomic_init(&worker->control.state, ACTIVE(new_worker_phase));
+        if (worker->control.vm_thread)
+            atomic_init(pCTRL_STATE(worker->control), ACTIVE(new_worker_phase));
+        else {
+            fprintf(stderr, "WARNING: no sb-vm:thread for GC worker yet\n");
+        }
         control_insert(&workers, &worker->control);
         spin_unlock(&worker_creation_lock);
         worker_tlv_set(current_worker, worker);
@@ -253,7 +317,8 @@ static struct sml_user *
 user_new()
 {
         struct sml_user *user;
-        user = xmalloc(sizeof(struct sml_user));
+        user = xmalloc(sizeof(struct sml_user), "user");
+        user->arbdata = NULL;
         user->frame_stack = NULL;
         user->exn_object = NULL;
         return user;
@@ -263,19 +328,22 @@ static struct sml_worker *
 worker_new()
 {
         struct sml_worker *worker;
-        worker = xmalloc(sizeof(struct sml_worker));
+        worker = xmalloc(sizeof(struct sml_worker), "worker");
         worker->thread_local_heap = sml_heap_worker_init();
         worker->user = NULL;
+        worker->control.vm_thread = NULL;
+        pthread_mutex_init(&worker->control.state_lock, 0);
 #ifndef WITHOUT_MASSIVETHREADS
         atomic_init(&worker->new_users, NULL);
 #endif /* WITHOUT_MASSIVETHREADS */
+        fprintf(stderr, "GC: new worker @ %p\n", worker);
         return worker;
 }
 
 static void
 user_destroy(struct sml_user *user)
 {
-        free(user);
+        xfree(user, "user");
 }
 
 static void
@@ -285,18 +353,26 @@ worker_destroy(struct sml_worker *worker)
 #ifdef WITHOUT_MASSIVETHREADS
         user_destroy(worker->user);
 #endif /* WITHOUT_MASSIVETHREADS */
-        free(worker);
+        pthread_mutex_destroy(&worker->control.state_lock);
+        xfree(worker, "worker");
 }
 
 #ifndef WITHOUT_CONCURRENCY
+extern char* cur_thread_name();
 static void
 decr_sync_counter_relaxed()
 {
-        if (fetch_sub(relaxed, &sync_counter, 1) - 1 == 0) {
+        unsigned int oldval = fetch_sub(relaxed, &sync_counter, 1);
+        TPRINTF(1, "dec_sync_relaxed: old=%x", oldval);
+#if USE_SYNC_SEM
+        os_sem_post(&gc_sync_semaphore);
+#else
+        if (oldval == 1) {
                 mutex_lock(&sync_wait_lock);
                 cond_signal(&sync_wait_cond);
                 mutex_unlock(&sync_wait_lock);
         }
+#endif
 }
 #endif /* !WITHOUT_CONCURRENCY */
 
@@ -304,11 +380,17 @@ decr_sync_counter_relaxed()
 static void
 decr_sync_counter_release()
 {
-        if (fetch_sub(release, &sync_counter, 1) - 1 == 0) {
+        unsigned int oldval = fetch_sub(release, &sync_counter, 1);
+        TPRINTF(1, "dec_sync_release: old=%x", oldval);
+#if USE_SYNC_SEM
+        os_sem_post(&gc_sync_semaphore);
+#else
+        if (oldval == 1) {
                 mutex_lock(&sync_wait_lock);
                 cond_signal(&sync_wait_cond);
                 mutex_unlock(&sync_wait_lock);
         }
+#endif
 }
 #endif /* !WITHOUT_CONCURRENCY */
 
@@ -355,6 +437,8 @@ static void
 worker_sync2(struct sml_worker *worker)
 {
         sml_heap_worker_sync2(worker->thread_local_heap);
+        extern void sbcl_thread_sync2(struct thread*);
+        sbcl_thread_sync2(worker->control.vm_thread);
         /* all updates by this thread must happen before here */
         decr_sync_counter_release();
 }
@@ -407,10 +491,10 @@ static void
 worker_leave(struct sml_worker *worker)
 {
         unsigned int old;
-        assert(IS_ACTIVE(load_relaxed(&worker->control.state)));
+        assert(IS_ACTIVE(load_relaxed(pCTRL_STATE(worker->control))));
         /* all updates by this thread must happen before here */
         /* PRESYNC1 -> SYNC1 or PRESYNC2 -> SYNC2 */
-        old = fetch_or(release, &worker->control.state, INACTIVE_FLAG | 1);
+        old = fetch_or(release, pCTRL_STATE(worker->control), INACTIVE_FLAG | 1);
         if (old == ACTIVE(PRESYNC1)) {
                 worker_sync1(worker);
         } else if (old == ACTIVE(PRESYNC2)) {
@@ -429,6 +513,10 @@ worker_leave(struct sml_worker *worker)
 SML_PRIMITIVE void
 sml_leave()
 {
+  // transfer of control from SML to C.
+  // As long as the user has left the managed context, if the collector asks for
+  // co-operation from user code (to get roots or change phase), the collector will
+  // perform the action on behalf of the user thread.
         struct sml_worker *worker = worker_tlv_get(current_worker);
         assert(worker->user->frame_stack->top == NULL);
         worker->user->frame_stack->top = CALLER_FRAME_END_ADDRESS();
@@ -441,6 +529,7 @@ sml_leave_internal(void *frame_pointer)
 {
         struct sml_worker *worker = worker_tlv_get(current_worker);
         void *old_frame_top = worker->user->frame_stack->top;
+        TPRINTF(0, "leaving managed context. FP=%p old=%p", frame_pointer, old_frame_top);
         if (!old_frame_top)
                 worker->user->frame_stack->top = frame_pointer;
         user_leave(worker->user);
@@ -545,11 +634,13 @@ sml_enter()
         worker = worker_enter(worker, user);
         assert(worker->user->frame_stack->top == CALLER_FRAME_END_ADDRESS());
         worker->user->frame_stack->top = NULL;
+        TPRINTF(0, "re-entered Lisp");
 }
 
 void
 sml_enter_internal(void *old_frame_top)
 {
+  TPRINTF(0, "re-entering managed context with old_frame_top=%p", old_frame_top);
         struct sml_user *user = NULL;
         struct sml_worker *worker = worker_tlv_get(current_worker);
 #ifndef WITHOUT_MASSIVETHREADS
@@ -591,27 +682,96 @@ sml_check_internal(void *frame_pointer ATTR_UNUSED)
 }
 #endif /* WITHOUT_MULTITHREAD */
 
+char *phase_names[8] = {"?", "ASYNC", "PRESYNC1", "SYNC1", "PRESYNC2", "SYNC2", "", "MARK"};
+char *phase_names_inactive[8] =
+{"-?","-<ASYNC>", "-<PRESYNC1>", "-<SYNC1>", "-<PRESYNC2>", "-<SYNC2>", "", "-<MARK>"};
+
 #ifndef WITHOUT_CONCURRENCY
+extern FILE* get_log_file_for_thread();
+extern void backtrace_to_file(FILE*f);
+
+/*void poll_until_phase(long dummy, enum sml_sync_phase this_phase,
+                      enum sml_sync_phase desired_phase) {
+  enum sml_sync_phase newphase;
+  struct timespec sleeptime;
+  TPRINTF(0, "==== waiting for %s phase ====", phase_name(desired_phase));
+  FILE* f = get_log_file_for_thread();
+  if (!f) f = stderr;
+  fprintf(f, "Waiting for phase %s:\n", phase_name(desired_phase));
+  backtrace_to_file(f);
+  int i = 0;
+  sleeptime.tv_sec = 0;
+  sleeptime.tv_nsec = (1000*1000*1000)/10000;
+  for(;;) {
+    ++i;
+    sml_check_internal(&dummy);
+    newphase = sml_current_phase();
+    if (newphase != this_phase) {
+      TPRINTF(0, "detected phase change to %s (sleep iteration %d)", phase_name(newphase), i);
+      this_phase = newphase;
+      if (this_phase == desired_phase) break;
+    } else {
+      nanosleep(&sleeptime,0);
+      if (sleeptime.tv_nsec < (1000*1000*1000)/10) sleeptime.tv_nsec *= 2;
+    }
+  }
+  TPRINTF(0, "==== resuming ===");
+  fprintf(f, "Resuming\n\n");
+}*/
+
+ATTR_UNUSED static int heapdump_counter;
+
+__thread unsigned int last_observed_gc_state;
 void
 sml_check_internal(void *frame_pointer)
 {
         struct sml_worker *worker = worker_tlv_get(current_worker);
-        unsigned int state = load_relaxed(&worker->control.state);
+        unsigned int state = load_relaxed(pCTRL_STATE(worker->control));
 
         assert(IS_ACTIVE(state));
 
+        if (state != last_observed_gc_state) {
+          TPRINTF(2, "check_internal: phase chage %x to %x", last_observed_gc_state, state);
+          struct thread* th = current_thread;
+          if (th) {
+            TPRINTF(2, "new_obj=%d stack_store=%d heap_store=%d barrier=%d spinwait=%d",
+                    th->ct_new_objects, th->ct_stack_obj_stores, th->ct_heap_obj_stores,
+                    th->ct_store_barriers, th->ct_spinlock_yields);
+            th->ct_new_objects = th->ct_stack_obj_stores = th->ct_heap_obj_stores
+                               = th->ct_store_barriers = th->ct_spinlock_yields = 0;
+          }
+          last_observed_gc_state = state;
+        }
+
         switch(state) {
         case ACTIVE(PRESYNC1):
-                store_relaxed(&worker->control.state, ACTIVE(SYNC1));
+#if 0
+                if (enable_async_gc && getenv("SMLGC_SYNC1_DUMP")) {
+                    ++heapdump_counter;
+                    char pathbuf[100];
+                    int n = snprintf(pathbuf, sizeof pathbuf, "heapsnap%d.txt", heapdump_counter);
+                    (void)n;
+                    hexdump_sml_heap_to_file(pathbuf);
+                    TPRINTF(0, "Dumped heap to '%s'", pathbuf);
+                }
+#endif
+                store_relaxed(pCTRL_STATE(worker->control), ACTIVE(SYNC1));
                 worker_sync1(worker);
+                // if (!enable_async_gc) poll_until_phase(0, ACTIVE(SYNC1), ASYNC);
                 break;
         case ACTIVE(PRESYNC2):
-                store_relaxed(&worker->control.state, ACTIVE(SYNC2));
+                store_relaxed(pCTRL_STATE(worker->control), ACTIVE(SYNC2));
                 user_sync2_check(worker->user, frame_pointer);
                 worker_sync2(worker);
                 break;
         }
 }
+
+void cooperate_with_gc(uword_t stackptr_at_interrupt) {
+    TPRINTF(1, "co-operate with GC");
+    sml_check_internal((void*)stackptr_at_interrupt);
+}
+
 #endif /* !WITHOUT_CONCURRENCY */
 
 void sml_call_with_cleanup(void(*)(void), void(*)(void*,void*,void*), void*);
@@ -620,6 +780,7 @@ struct signal_cleanup_arg {
         void (*signal_handler)(void);
 };
 
+#ifndef LISP_FEATURE_SBCL
 static void
 signal_cleanup(void *arg, void *u, void *e)
 {
@@ -628,7 +789,9 @@ signal_cleanup(void *arg, void *u, void *e)
         sml_enter_internal(a->frame_pointer);
         sml_unsave_exn(e);
 }
+#endif
 
+#ifndef LISP_FEATURE_SBCL
 SML_PRIMITIVE void
 sml_check(unsigned int flag)
 {
@@ -649,6 +812,7 @@ sml_check(unsigned int flag)
 
         sml_check_internal(frame_pointer);
 }
+#endif
 
 #ifdef WITHOUT_MULTITHREAD
 enum sml_sync_phase
@@ -669,8 +833,12 @@ sml_current_phase()
          * If worker->control.state is SYNC1, then the thread is in SYNC1
          * at this instant.
          */
-        return PHASE(load_relaxed(&worker->control.state));
+        return PHASE(load_relaxed(pCTRL_STATE(worker->control)));
 }
+/*void* sml_current_phase_pointer() {
+        struct sml_worker *worker = worker_tlv_get(current_worker);
+        return &worker->control.state;
+}*/
 #endif /* !WITHOUT_MULTITHREAD */
 
 SML_PRIMITIVE void
@@ -678,7 +846,7 @@ sml_save()
 {
         struct sml_worker *worker = worker_tlv_get(current_worker);
         struct sml_user *user = worker->user;
-        assert(IS_ACTIVE(load_relaxed(&worker->control.state)));
+        assert(IS_ACTIVE(load_relaxed(pCTRL_STATE(worker->control))));
         assert(user->frame_stack->top == NULL);
         user->frame_stack->top = CALLER_FRAME_END_ADDRESS();
 }
@@ -688,7 +856,7 @@ sml_unsave()
 {
         struct sml_worker *worker = worker_tlv_get(current_worker);
         struct sml_user *user = worker->user;
-        assert(IS_ACTIVE(load_relaxed(&worker->control.state)));
+        assert(IS_ACTIVE(load_relaxed(pCTRL_STATE(worker->control))));
         assert(user->frame_stack->top == CALLER_FRAME_END_ADDRESS());
         user->frame_stack->top = NULL;
 }
@@ -734,6 +902,7 @@ sml_saved()
 }
 #endif /* NDEBUG */
 
+static struct timespec wallclock;
 void
 sml_control_init()
 {
@@ -741,6 +910,14 @@ sml_control_init()
 #ifndef WITHOUT_MASSIVETHREADS
         user_tlv_init(current_user);
 #endif /* !WITHOUT_MASSIVETHREADS */
+#ifdef USE_SYNC_SEM
+        os_sem_init(&gc_sync_semaphore, 0);
+#elif defined USE_SYNC_PIPE
+        pipe(sync_pipe);
+        assert(sync_pipe[0] != 0 || sync_pipe[1] != 0);
+#endif
+        atomic_init(&sml_check_flag, 0);
+        clock_gettime(CLOCK_MONOTONIC, &wallclock);
 }
 
 SML_PRIMITIVE void
@@ -752,6 +929,7 @@ sml_start(void *arg)
         range->bottom = CALLER_FRAME_END_ADDRESS();
         range->top = NULL;
 
+        fprintf(stderr, "sml_start arg=%p range=%p:%p\n", arg, range->bottom, range->top);
 #ifndef WITHOUT_MASSIVETHREADS
         worker = worker_tlv_get(current_worker);
         if (worker) {
@@ -792,8 +970,15 @@ sml_end()
         struct sml_worker *worker = worker_tlv_get(current_worker);
         struct sml_user *user = worker->user;
 
-        assert(IS_ACTIVE(load_relaxed(&worker->control.state)));
+        fprintf(stderr, "sml_end: vmthread = %p\n", worker->control.vm_thread);
-        assert(user->frame_stack->bottom == CALLER_FRAME_END_ADDRESS());
+        assert(IS_ACTIVE(load_relaxed(pCTRL_STATE(worker->control))));
+        if (user->frame_stack->bottom == CALLER_FRAME_END_ADDRESS()) {
+        } else {
+          // shouldn't matter, because user_leave does nothing with the stack
+          // if no massivethreads.
+          fprintf(stderr, "sml_end: frame stack bottom not right? oh well (%p vs %p)\n",
+                  user->frame_stack->bottom, CALLER_FRAME_END_ADDRESS());
+        }
 
         user->frame_stack = user->frame_stack->next;
         user_leave(worker->user);
@@ -838,7 +1023,7 @@ static void
 control_gc()
 {
         struct control *first_worker, **p;
-        struct control **new_users;
+        struct control ATTR_UNUSED **new_users;
         struct sml_worker *w;
 
 #ifndef WITHOUT_MASSIVETHREADS
@@ -846,6 +1031,7 @@ control_gc()
 #endif /* !WITHOUT_MASSIVETHREADS */
 
         first_worker = load_acquire(&workers);
+        TPRINTF(0, "control_gc: first_worker=%p", first_worker);
         if (!first_worker)
                 return;
 
@@ -900,6 +1086,8 @@ sml_detach()
 void
 sml_detach()
 {
+    TPRINTF(1, "sml_detach");
+    // why would a thread with no 'struct sml_worker' ever get detached?
         struct sml_worker *worker = worker_tlv_get_or_init(current_worker);
         struct sml_user *user = worker ? worker->user : NULL;
 
@@ -921,43 +1109,118 @@ sml_detach()
 #endif /* !WITHOUT_MULTITHREAD */
 
 #ifndef WITHOUT_CONCURRENCY
+long this_gc_phase_time[4], cumulative_phase_time[4];
 static void
 change_phase(struct control *list,
              enum sml_sync_phase old, enum sml_sync_phase new)
 {
+  {
+  struct timespec now;
+  clock_gettime(CLOCK_MONOTONIC, &now);
+  int index;
+  switch (old) {
+  case ASYNC: index = 0; break;
+  case SYNC1: index = 1; break;
+  case SYNC2: index = 2; break;
+  case MARK:  index = 3; break;
+  default: lose("bad phase change");
+  }
+  long delta = (now.tv_sec - wallclock.tv_sec)*1000000
+               + (now.tv_nsec - wallclock.tv_nsec)/1000;
+  this_gc_phase_time[index] = delta;
+  wallclock = now;
+  if (smlgc_verbose) printf("change phase %s -> %s\n", phase_name(old), phase_name(new));
+  if (old==MARK) {
+    cumulative_phase_time[0] += this_gc_phase_time[0];
+    cumulative_phase_time[1] += this_gc_phase_time[1];
+    cumulative_phase_time[2] += this_gc_phase_time[2];
+    cumulative_phase_time[3] += this_gc_phase_time[3];
+    long this_sum = this_gc_phase_time[0] + this_gc_phase_time[1] +
+                    this_gc_phase_time[2] + this_gc_phase_time[3];
+    long tot_sum = cumulative_phase_time[0] + cumulative_phase_time[1] +
+                   cumulative_phase_time[2] + cumulative_phase_time[3];
+    int this_pct_async = 100 * this_gc_phase_time[0] / this_sum;
+    int this_pct_sync2 = 100 * this_gc_phase_time[2] / this_sum;
+    int this_pct_mark  = 100 * this_gc_phase_time[3] / this_sum;
+    // The percent time in sync1 is negligible. Just absorb whatever
+    // amount makes the sum of percents 100
+    int this_pct_sync1 = 100 - (this_pct_async + this_pct_sync2 + this_pct_mark);
+    int tot_pct_async = 100 * cumulative_phase_time[0] / tot_sum;
+    int tot_pct_sync2 = 100 * cumulative_phase_time[2] / tot_sum;
+    int tot_pct_mark  = 100 * cumulative_phase_time[3] / tot_sum;
+    int tot_pct_sync1 = 100 - (tot_pct_async + tot_pct_sync2 + tot_pct_mark);
+    printf("Phase time(asy/syn1/syn2/mrk): cur=%ld+%ld+%ld+%ld (%d/%d/%d/%d) tot=(%d/%d/%d/%d)\n",
+           this_gc_phase_time[0], this_gc_phase_time[1],
+           this_gc_phase_time[2], this_gc_phase_time[3],
+           this_pct_async, this_pct_sync1, this_pct_sync2, this_pct_mark,
+           tot_pct_async, tot_pct_sync1, tot_pct_sync2, tot_pct_mark);
+  }
+  }
+  TPRINTF(2, "change-phase %s -> %s", phase_name(old), phase_name(new));
         struct control *control;
         unsigned int state ATTR_UNUSED;
 
         for (control = list; control; control = control->next) {
-                state = fetch_xor(relaxed, &control->state, old ^ new);
+                state = fetch_xor(relaxed, pCTRL_STATE(*control), old ^ new);
                 assert(PHASE(state) == old);
         }
 }
 #endif /* !WITHOUT_CONCURRENCY */
 
 #ifndef WITHOUT_CONCURRENCY
+#if USE_SYNC_SEM
+static void wait_for_sync(int count) {
+    TPRINTF(1, "waiting on sync semaphore (count=%d)", count);
+    do os_sem_wait(&gc_sync_semaphore); while (--count);
+}
+#endif
+
+static void raise_gcsignal(struct control* control, ATTR_UNUSED char *reason) {
+        if (!use_gcsignal) return;
+        struct thread* vmthread = control->vm_thread;
+        if (vmthread->os_kernel_tid == 0) {
+            lose("vmthread %p exists but has no OS thread", vmthread);
+        }
+        TPRINTF(1, "signaling ACTIVE thread %p for %s", vmthread, reason);
+        pthread_kill(vmthread->os_thread, SIG_STOP_FOR_GC);
+}
+
 static void
 sync1(struct control *workers)
 {
         struct control *control;
         unsigned int old, new, count = 0;
 
+        assert(load_acquire(&sync_counter) == 0);
         fetch_or(relaxed, &sml_check_flag, FLAG_GC);
 
         for (control = workers; control; control = control->next) {
+                pthread_mutex_lock(&control->state_lock);
+                assert(control->vm_thread);
+                //if (!vmthread) lose("can't phase change control %p - no vm_thread", control);
                 old = INACTIVE(PRESYNC1);
                 new = INACTIVE(SYNC1);
-                if (cmpswap_relaxed(&control->state, &old, new))
+                if (cmpswap_relaxed(pCTRL_STATE(*control), &old, new)) {
+                        TPRINTF(1, "SYNC1 on behalf of INACTIVE %p", control);
                         worker_sync1((struct sml_worker *)control);
+                } else {
+                        raise_gcsignal(control, "sync1");
+                }
+                pthread_mutex_unlock(&control->state_lock);
                 count++;
         }
 
+#if USE_SYNC_SEM
+        fetch_add(relaxed, &sync_counter, count);
+        wait_for_sync(count);
+#else
         if (fetch_add(relaxed, &sync_counter, count) + count != 0) {
                 mutex_lock(&sync_wait_lock);
                 while (!(load_relaxed(&sync_counter) == 0))
                         cond_wait(&sync_wait_cond, &sync_wait_lock);
                 mutex_unlock(&sync_wait_lock);
         }
+#endif
 
         fetch_and(relaxed, &sml_check_flag, ~FLAG_GC);
 
@@ -1005,33 +1268,46 @@ sync2(struct control *workers)
         struct control *control;
         unsigned int old, new, count = 0;
 
+        assert(load_acquire(&sync_counter) == 0);
         sml_heap_collector_sync2();
 
         fetch_or(relaxed, &sml_check_flag, FLAG_GC);
 
         for (control = workers; control; control = control->next) {
+                pthread_mutex_lock(&control->state_lock);
+                assert(control->vm_thread);
+                // if (!vmthread) lose("can't phase change control %p - no vm_thread", control);
                 old = INACTIVE(PRESYNC2);
                 new = ACTIVE(SYNC2);
                 /* all updates so far must happen before here */
-                if (cmpswap_acquire(&control->state, &old, new)) {
+                if (cmpswap_acquire(pCTRL_STATE(*control), &old, new)) {
+                        TPRINTF(1, "SYNC2 on behalf of INACTIVE %p", control);
                         struct sml_worker *w = (struct sml_worker *)control;
 #ifdef WITHOUT_MASSIVETHREADS
                         user_sync2(w->user);
 #endif /* WITHOUT_MASSIVETHREADS */
                         worker_sync2(w);
                         /* all updates by this thread must happen before here */
-                        store_release(&control->state, INACTIVE(SYNC2));
+                        store_release(pCTRL_STATE(*control), INACTIVE(SYNC2));
+                } else {
+                        raise_gcsignal(control, "sync2");
                 }
+                pthread_mutex_unlock(&control->state_lock);
                 count++;
         }
 
         /* all updates so far must happen before here */
+#if USE_SYNC_SEM
+        fetch_add(relaxed, &sync_counter, count);
+        wait_for_sync(count);
+#else
         if (fetch_add(acquire, &sync_counter, count) + count != 0) {
                 mutex_lock(&sync_wait_lock);
                 while (!(load_acquire(&sync_counter) == 0))
                         cond_wait(&sync_wait_cond, &sync_wait_lock);
                 mutex_unlock(&sync_wait_lock);
         }
+#endif
 
         fetch_and(relaxed, &sml_check_flag, ~FLAG_GC);
 }
@@ -1096,9 +1372,18 @@ sml_gc()
 #endif /* !defined WITHOUT_MULTITHREAD && defined WITHOUT_CONCURRENCY */
 
 #ifndef WITHOUT_CONCURRENCY
+extern pthread_rwlock_t valid_obj_lock;
 void
 sml_gc()
 {
+  struct timespec now;
+  extern struct timespec lisp_init_time;
+  clock_gettime(CLOCK_MONOTONIC, &now);
+  int sec = now.tv_sec - lisp_init_time.tv_sec;
+  long millisec = (now.tv_nsec - lisp_init_time.tv_nsec) / 1000000;
+  float fsec = (float)sec + (float)millisec/1000.0;
+  fprintf(stderr, "[%f] GC cycle %d\n", fsec, get_gc_cycle_number());
+  TPRINTF(1, "start of cycle %d", get_gc_cycle_number());
         struct control *current_workers;
         control_gc();
 
@@ -1112,6 +1397,11 @@ sml_gc()
         current_workers = load_relaxed(&workers);
         spin_unlock(&worker_creation_lock);
 
+        /* Setting the refState to REPEAT now, before tracing, is the right thing
+         * because it causes mutators to record loads through weak objects
+         * without checking the referent color. */
+        if (smlgc_verbose) printf("Setting refState_REPEAT\n");
+        atomic_store(&weakRefState, weakRefState_REPEAT);
         change_phase(current_workers, ASYNC, PRESYNC1);
 
         sync1(current_workers);
@@ -1144,22 +1434,43 @@ sml_gc()
 
         change_phase(current_workers, SYNC2, MARK);
 
+        if (smlgc_verbose) fprintf(stderr, "START MARK\n");
         sml_heap_collector_mark();
 
+        /* Mutators can operate with the store barrier off, but can not freely reference
+         * weak objects yet. We need to clear the dead ones first. The marking bitmap
+         * is intact, so mutators can and must utilize the bitmap to decide which weak
+         * refs are live.
+         * Weak objects newly allocated after the marking cycle can only point to black
+         * objects because there is no way to hold a white or gray reference.
+         * Unfortunately, if we were to change phase to ASYNC now, it would cause confusion
+         * as to whether large objects are allocated black, which would make
+         * heap_check_alive potentially return no when it meant yes. */
+
         /* ASYNC: turn off snapshot barrier */
         spin_lock(&worker_creation_lock);
         new_worker_phase = ASYNC;
         current_workers = load_relaxed(&workers);
         spin_unlock(&worker_creation_lock);
 
+        pthread_rwlock_wrlock(&valid_obj_lock);
         change_phase(current_workers, MARK, ASYNC);
 
+        sml_heap_collector_after_mark();
+#ifdef LISP_FEATURE_SBCL
+        extern void finalizer_thread_wake();
+        SYMBOL(GC_EPOCH)->value = make_fixnum(get_gc_cycle_number());
+        finalizer_thread_wake();
+#else
         sml_run_finalizer();
+#endif
         sml_heap_collector_async();
+        pthread_rwlock_unlock(&valid_obj_lock);
 }
 
 #endif /* !WITHOUT_MULTITHREAD && !WITHOUT_CONCURRENCY */
 
+#ifndef LISP_FEATURE_SBCL
 static void *
 frame_enum_ptr(void *frame_end, void (*trace)(void **, void *), void *data)
 {
@@ -1205,6 +1516,7 @@ sml_stack_enum_ptr(struct sml_user *user,
                 }
         }
 }
+#endif
 
 #ifdef WITHOUT_MULTITHREAD
 void
@@ -1253,3 +1565,61 @@ sml_exit(int status)
 }
 
 #endif /* !WITHOUT_MULTITHREAD */
+
+int worker_is_inactive() {
+  struct sml_worker*w = (void*)workers;
+  unsigned int state = load_relaxed(pCTRL_STATE(w->control));
+  return state & INACTIVE_FLAG;
+}
+void* get_user_stack_hot_end() {
+  return ((struct sml_worker*)workers)->user->frame_stack->top;
+}
+
+void smlgc_unregister_lisp_thread(struct thread* thread)
+{
+    struct sml_worker *worker = worker_tlv_get(current_worker);
+    // stop-for-GC *must* be blocked. Consider: we just acquired the lock,
+    // if GC wants to ask us to cooperate via the signal, GC needs to acquire
+    // the lock in order to decide if we're alive. -> Deadlock.
+    pthread_mutex_lock(&worker->control.state_lock);
+    // This says to treat the pthread _as_ _if_ it no longer exists
+    // (technically pthread_t is opaque and can't be tested for 0 or
+    // other "known invalid" bit pattern)
+    worker->control.vm_thread->os_kernel_tid = 0;
+    //worker->control.vm_thread = NULL;
+    pthread_mutex_unlock(&worker->control.state_lock);
+    struct alloc_ptr* control_ap = (void*)worker->thread_local_heap;
+    assert(control_ap[4].blocksize_bytes == 1<<4);
+    int nbytes = 9*sizeof (struct alloc_ptr);
+    memcpy(&control_ap[4], &thread->ap4, nbytes);
+    memset(&thread->ap4, 0, nbytes);
+}
+
+#include "segment.inc"
+void* find_owning_control(struct segment* seg, int blocksize_log2)
+{
+    struct control* c = workers;
+    for ( ; c ; c = c->next ) {
+      struct thread* th = c->vm_thread;
+      if (th && blocksize_log2 >= 4) {
+        struct alloc_ptr* ap = &th->ap4;
+        ap += (blocksize_log2 - 4);
+        if (segment_addr(ap->freebit.ptr) == seg) return c;
+      } else {
+        struct alloc_ptr* ap = (void*)((struct sml_worker*)c)->thread_local_heap;
+        ap += blocksize_log2;
+        if (segment_addr(ap->freebit.ptr) == seg) return c;
+      }
+    }
+    return 0;
+}
+char* vm_thread_name(struct thread* th);
+char* owning_thread_name(struct segment* seg, int blocksize_log2)
+{
+    struct control* c = find_owning_control(seg, blocksize_log2);
+    if (!c) return 0;
+    if (c->vm_thread)
+      return vm_thread_name(c->vm_thread);
+    else
+      return "GC";
+}

smlsharpgc/heap.h

@@ -68,6 +68,9 @@ void sml_heap_collector_sync2(void);
  * At this time, all all mutators has switched to SYNC2.
  */
 void sml_heap_collector_mark(void);
+/* Called after switching from MARK to ASYNC but before runing
+ * finalizers or performing asynchronous sweeping */
+void sml_heap_collector_after_mark(void);
 
 /*
  * Called when the collector has finished MARK and switched to ASYNC.
@@ -92,12 +95,20 @@ SML_PRIMITIVE void sml_write(void *obj, void **writeaddr, void *new_value);
 
 /*
  * Check the liveness of the given object.
- * slot : pointer to a pointer to be checked
+ * If obj has been marked as live in sml_heap_collector_mark,
- * If *slot has been marked as live in sml_heap_collector_mark,
+ * this returns true.
- * this returns true and update obj with its forwarded pointer.
  * This is called after sml_heap_collector_mark and before
  * sml_heap_collector_async.
  */
-int sml_heap_check_alive(void **slot);
+int sml_heap_check_alive(void *obj);
+
+extern _Atomic(int) n_remset_insertions_skipped_large,
+                    n_remset_insertions_skipped_small;
+
+extern _Atomic(int) weakRefState;
+#define weakRefState_NORMAL   0
+#define weakRefState_TRACING  1
+#define weakRefState_REPEAT   2
+#define weakRefState_SPLAT    3
 
 #endif /* SMLSHARP__HEAP_H__ */

smlsharpgc/object.h

@@ -8,6 +8,26 @@
 
 #include <limits.h>
 
+#ifdef LISP_FEATURE_SBCL
+
+#define OBJ_BEGIN(obj) obj
+#define OBJ_HEADER(obj) (*(long*)(obj))
+#define OBJ_FLAG_SKIP 0
+#define OBJ_HEADER_SIZE  0
+
+#include "genesis/constants.h"
+#include "genesis/closure.h"
+
+static inline void* untagged_baseptr(lispobj taggedptr) {
+    // no need to read a word at native_pointer(thing) if it isn't fun-pointer tagged
+    lispobj* base = (lispobj*)(taggedptr & ~LOWTAG_MASK);
+    if ((taggedptr & LOWTAG_MASK) != FUN_POINTER_LOWTAG) return base;
+    return widetag_of(base) != SIMPLE_FUN_WIDETAG ? (void*)base :
+        (void*)fun_code_header((struct simple_fun*)base);
+}
+
+#else
+
 /*
  * size of a bitmap word in heap objects and stack frames.
  */
@@ -118,5 +138,6 @@
  * sentinel.  OBJ_STR_SIZE returns the length of the string except for
  * the sentinel. */
 #define OBJ_STR_SIZE(obj)  ((size_t)(OBJ_SIZE(obj) - 1))
+#endif
 
 #endif /* SMLSHARP__OBJECT_H__ */

smlsharpgc/segment.inc

@@ -0,0 +1,56 @@
+#ifndef SEGMENT_SIZE_LOG2
+#define SEGMENT_SIZE_LOG2  15   /* 32k */
+#endif /* SEGMENT_SIZE_LOG2 */
+#define SEGMENT_SIZE (1U << SEGMENT_SIZE_LOG2)
+#ifndef SEG_RANK
+#define SEG_RANK  3
+#endif /* SEG_RANK */
+
+struct segment_layout {
+        unsigned int blocksize_bytes;
+        unsigned int bitmap_base[SEG_RANK + 1];
+        sml_bmword_t bitmap_sentinel[SEG_RANK];
+        unsigned int stack_offset;
+        unsigned int stack_limit;
+        unsigned int block_offset;
+        unsigned int num_blocks;
+        unsigned int block_limit;
+};
+
+struct segment {
+        struct list_item as_list;
+        struct stack_slot {
+                _Atomic(void *) next;
+        } *stack;  /* == seg + layout->stack_offset */
+        char *block_base;  /* == seg + layout->block_offset */
+        /* If block_base is null, this segment is in free list */
+#if !defined WITHOUT_MULTITHREAD && !defined WITHOUT_CONCURRENCY
+        /* do not modify snapshot_free during the collector traces objects. */
+        char *snapshot_free;
+#endif /* !WITHOUT_MULTITHREAD && !WITHOUT_CONCURRENCY */
+        const struct segment_layout *layout;
+        unsigned int blocksize_log2;
+        int free_count;
+        /* The free_count field not only holds the count (as its name) but
+         * indicates which set the segment is in.
+         * If free_count is negative, the segment is in the collect set
+         * and its absolute value is the count of unmarked blocks.
+         * If free_count is zero, the segment is in the filled set.
+         * If free_count is positive, the segment is in the partial set.
+         */
+};
+
+/* assume that segment address is a multiple of SEGMENT_SIZE */
+static inline struct segment *
+segment_addr(const void *p)
+{
+        return (void*)((uintptr_t)p & ~((uintptr_t)(SEGMENT_SIZE - 1)));
+}
+
+/* thread-local use only */
+struct object_list {
+        struct stack_slot begin;
+        struct stack_slot *last;
+        int count;
+};
+void object_list_append(struct object_list *l, void *obj);

smlsharpgc/smlsharp.h

@@ -7,6 +7,30 @@
 #ifndef SMLSHARP__SMLSHARP_H__
 #define SMLSHARP__SMLSHARP_H__
 
+extern int use_smlgc;
+extern int enable_async_gc;
+#define DEADBEEF 0xFFFFFFFFDEADBEEF
+#define VERBOSE_LOGGING 0
+extern int n_smlgcs;
+extern void tprintf_(char *fmt, ...);
+#define TPRINTF(msgclass, fmt, ...) if(0 /* msgclass & 2 */) tprintf_(fmt, ##__VA_ARGS__)
+extern void suspend_mutator(char* reason);
+extern void unsuspend_mutator();
+#include <stdio.h>
+extern FILE* get_gc_thread_log();
+void show_map(char*,void*);
+void show_fractional_usage();
+extern void get_segment_pool_bounds(char* bounds[2]);
+extern char *phase_names[8];
+extern char *phase_names_inactive[8];
+//extern FILE* get_large_object_logfile();
+extern int get_gc_cycle_number();
+
+static inline char* phase_name(int phase) {
+  if (phase & 0x10U) return phase_names_inactive[phase-0x10];
+  return phase_names[phase];
+}
+
 /*
  * One of the following macros may be defined by the command line:
  * - WITHOUT_MULTITHREAD: Remove multithread support at all.
@@ -26,6 +50,8 @@
 #define WITHOUT_MASSIVETHREADS
 #endif /* WITHOUT_CONCURRENCY */
 
+#define DPRINTF(x) {}
+
 #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
 # error C99 is required
 #endif
@@ -33,6 +59,12 @@
 #error GCC version 4.0 or later is required
 #endif
 
+/*#ifdef FOO_LISP_FEATURE_SBCL
+ #include "smlsharp-config.h"
+ #infdef WITHOUT_MASSIVETHREADS
+ #define WITHOUT_MASSIVETHREADS
+ #endif */
+
 #ifdef HAVE_CONFIG_H
 # include "config.h"
 #endif
@@ -155,16 +187,20 @@
 #define cond_signal(c) ((void)0)
 #endif /* !WITHOUT_MULTITHREAD */
 
+#undef ATOMIC_VAR_INIT
+#define ATOMIC_VAR_INIT(x) x
+
 /* spin lock */
 #ifndef WITHOUT_MULTITHREAD
 typedef struct { _Atomic(int) lock; } sml_spinlock_t;
 #define SPIN_LOCK_INIT {ATOMIC_VAR_INIT(0)}
+extern void bump_spinlock_busyct();
 static inline void spin_lock(sml_spinlock_t *l) {
         int old, i = 8192;
         for (;;) {
                 old = 0;
                 if (cmpswap_weak_acquire(&l->lock, &old, 1)) break;
-                if (--i == 0) { sched_yield(); i = 8192; }
+                if (--i == 0) { sched_yield(); i = 8192; bump_spinlock_busyct(); }
         }
 }
 static inline void spin_unlock(sml_spinlock_t *l) {
@@ -397,9 +433,10 @@ void sml_msg_init(void);
  * If allocation failed, program exits immediately.
  */
 void *sml_xmalloc(size_t size) ATTR_MALLOC;
-void *sml_xrealloc(void *p, size_t size) ATTR_MALLOC;
+//void *sml_xrealloc(void *p, size_t size) ATTR_MALLOC;
-#define xmalloc sml_xmalloc
+#define xmalloc(addr,reason) sml_xmalloc(addr)
-#define xrealloc sml_xrealloc
+//#define xrealloc sml_xrealloc
+#define xfree(addr,reason) free(addr)
 
 /*
  * GC root set management including stack frame layouts
@@ -415,7 +452,8 @@ void sml_gcroot(void *, void (*)(void), void *, void *);
 struct sml_gcroot *sml_gcroot_load(void (* const *)(void *), unsigned int);
 void sml_gcroot_unload(struct sml_gcroot *);
 const struct sml_frame_layout *sml_lookup_frametable(void *retaddr);
-void sml_global_enum_ptr(void (*trace)(void **, void *), void *data);
+void sml_global_enum_ptr(void (*trace)(void *, void *), void *data);
+void lisp_global_enum_ptr(void (*trace)(uintptr_t, void *), void *data);
 
 /* remove all thread-local data for SML# */
 void sml_deatch(void);
@@ -458,6 +496,7 @@ void sml_gc(void);
 
 struct sml_user;
 void sml_stack_enum_ptr(struct sml_user *, void (*)(void **, void *), void *);
+void lisp_stack_enum_ptr(struct sml_user *, void (*)(uintptr_t, void *), void *);
 
 int sml_set_signal_handler(void(*)(void));
 int sml_send_signal(void);
@@ -501,6 +540,9 @@ SML_PRIMITIVE void *sml_unsave_exn(void *);
 /*
  * SML# heap object management
  */
+struct list_item {
+        struct list_item *next;
+};
 SML_PRIMITIVE void *sml_alloc(unsigned int objsize);
 SML_PRIMITIVE void *sml_load_intinf(const char *hexsrc);
 SML_PRIMITIVE void **sml_find_callback(void *codeaddr, void *env);
@@ -515,6 +557,7 @@ struct sml_intinf;
 typedef struct sml_intinf sml_intinf_t;
 
 void sml_obj_enum_ptr(void *obj, void (*callback)(void **, void *), void *);
+int lispobj_enum_ptr(void *obj, void (*callback)(uintptr_t, void *), void *);
 void *sml_obj_alloc(unsigned int objtype, size_t payload_size);
 NOINLINE char *sml_str_new(const char *str);
 char *sml_str_new2(const char *str, unsigned int len);
@@ -561,11 +604,7 @@ ATTR_NORETURN void sml_exit(int status);
 /*
  * bit pointer
  */
-typedef uint32_t sml_bmword_t;
+#include "alloc_ptr.h"
-struct sml_bitptr { const sml_bmword_t *ptr; sml_bmword_t mask; };
-struct sml_bitptrw { sml_bmword_t *wptr; sml_bmword_t mask; };
-typedef struct sml_bitptr sml_bitptr_t;
-typedef struct sml_bitptrw sml_bitptrw_t;
 #define BITPTR_WORDBITS  32U
 #define BITPTR(p,n) \
         ((sml_bitptr_t){.ptr = (p) + (n) / 32U, .mask = 1 << ((n) % 32U)})
@@ -579,9 +618,9 @@ typedef struct sml_bitptrw sml_bitptrw_t;
 #define BITPTRW_EQUAL(b1,b2)  ((b1).wptr == (b2).wptr && (b1).mask == (b2).mask)
 #define BITPTR_TEST(b)  (*(b).ptr & (b).mask)
 #define BITPTR_WORD(b)  (*(b).ptr)
-#define BITPTR_EQUAL(b1,b2)  ((b1).ptr == (b2).ptr && (b1).mask == (b2).mask)
+//#define BITPTR_EQUAL(b1,b2)  ((b1).ptr == (b2).ptr && (b1).mask == (b2).mask)
 #define BITPTR_WORDINDEX(b,begin)  ((b).ptr - (begin))
-#define BITPTR_NEXTWORD(b)  ((b).ptr++, (b).mask = 1U)
+//#define BITPTR_NEXTWORD(b)  ((b).ptr++, (b).mask = 1U)
 
 /* BITPTR_NEXT0: move to next 0 bit in the current word.
  * mask becomes zero if failed. */
@@ -633,20 +672,37 @@ typedef struct sml_bitptrw sml_bitptrw_t;
 #define UncommitPage(addr, size) \
         VirtualFree(addr, size, MEM_DECOMMIT)
 #else
-/* inclue <sys/mman.h> */
+#include <sys/mman.h>
 /* inclue <unistd.h> */
-#define GetPageSize() sysconf(_SC_PAGESIZE)
+void *wrapped_mmap(void *addr, size_t length, int prot, int flags, int fd, long offset);
+int wrapped_munmap(void *addr, size_t length);
+int wrapped_mprotect(void *addr, size_t len, int prot);
+#define GetPageSize() getpagesize()
 #define AllocPageError MAP_FAILED
 #define AllocPage(addr, size) \
-        mmap(addr, size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0)
+        mmap(addr, size, PROT_EXEC | PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0)
 #define ReservePage(addr, size) \
         mmap(addr, size, PROT_NONE, MAP_ANON | MAP_PRIVATE, -1, 0)
 #define ReleasePage(addr, size) \
         munmap(addr, size)
 #define CommitPage(addr, size) \
-        mprotect(addr, size, PROT_READ | PROT_WRITE)
+        mprotect(addr, size, PROT_EXEC | PROT_READ | PROT_WRITE)
 #define UncommitPage(addr, size) \
         mmap(addr, size, PROT_NONE, MAP_ANON | MAP_PRIVATE | MAP_FIXED, -1, 0)
 #endif /* MINGW32 */
 
+void trace_enter(char*);
+void trace_leave(char*);
+void trace_leaf(char*);
+extern int gc_verbose;
+extern void hexdump_sml_heap_to_file(char*);
+
+extern int ignorable_space_p(uintptr_t);
+extern int large_code_subspace_p(char*);
+//extern void* untagged_baseptr(uintptr_t);
+extern void* otherptr_mseg(uintptr_t);
+
+extern int smlgc_verbose;
+extern void ldb_monitor();
+
 #endif /* SMLSHARP__SMLSHARP_H__ */

src/assembly/master.lisp

@@ -5,3 +5,8 @@
         "src/assembly/{arch}/array"
         "src/assembly/{arch}/arith"
         "src/assembly/{arch}/alloc"))
+
+(format t "~&Asm routine hit counters:~%")
+(let ((v sb-vm::*asm-routine-hit-counter-map*))
+  (dotimes (i (length v))
+    (format t " ~3d = ~a~%" i (aref v i))))

src/assembly/x86-64/alloc.lisp

@@ -11,6 +11,209 @@
 
 (in-package "SB-VM")
 
+#+sb-assembling
+(symbol-macrolet ((this-cons rax-tn)
+                  (ap rdi-tn)
+                  (num-conses rcx-tn)
+                  (curbit rdx-tn)
+                  (bmwordptr rsi-tn)
+                  (allocated rbx-tn) ; value loaded from *bmwordptr
+                  (element r8-tn)
+                  (last r9-tn)
+                  (context r10-tn))
+(with-bitmap-ap (ap)
+
+;;; Take CONTEXT in RAX and count (number of cons cells) in ECX,
+;;; returning a list in RAX. No other registers are affected.
+;;;      return-address    <-- RSP on entry
+;;;      [saved registers]  7 words
+;;;      dummy cons car
+;;;      dummy cons cdr    <-- RSP during execution
+(defun generate-list-allocator ()
+  (assemble ()
+   (inst mov context rax-tn)
+   ;;;(inst mov ap (thread-slot-ea thread-allocptr16-slot))
+   (inst lea ap (thread-slot-ea thread-ap4-slot))
+   (inst sub rsp-tn 16) ; rsp := dummy (struct cons)
+   (inst lea last (ea list-pointer-lowtag rsp-tn))
+   OUTER
+   (inst mov bmwordptr (freebit.ptr))
+   (inst mov :dword curbit (freebit.mask))
+   (inst mov :dword allocated (ea bmwordptr))
+   ;; if (!(allocated & curbit))
+   (inst test :dword allocated curbit)
+   (inst jmp :nz SLOW-PATH)
+   ;; quick path: allocate at least 1 cons
+   (inst mov this-cons (freeptr))
+   (inst or :byte this-cons list-pointer-lowtag) ; compute tagged ptr
+   INNER
+   (assert-word-unused (ea (- list-pointer-lowtag) this-cons))
+   (storew this-cons last cons-cdr-slot list-pointer-lowtag)
+   (inst mov element (ea context))
+   (inst sub context 8)
+   (storew element this-cons cons-car-slot list-pointer-lowtag)
+   (inst mov last this-cons)
+   (inst add this-cons 16)
+   (inst rol :dword curbit 1)
+   (inst jmp :nc NO-CARRY)
+   (inst add bmwordptr 4)
+   (inst mov :dword allocated (ea bmwordptr))
+   NO-CARRY
+   (inst dec :dword num-conses)
+   (inst jmp :z WRITEBACK) ; done
+   (inst test :dword allocated curbit)
+   (inst jmp :z INNER)
+   WRITEBACK ; exit from fast loop, flushing cached fields of 'struct alloc_ptr'
+   (inst mov (freebit.ptr) bmwordptr)
+   (inst mov (freebit.mask) curbit)
+   (inst sub :byte this-cons list-pointer-lowtag)
+   (inst mov (freeptr) this-cons)
+   (inst jrcxz TERMINATE)
+   SLOW-PATH
+   ;; Although this is a constructor, the optimization to elide snooping barriers
+   ;; is inadmissible. The _previously_ _allocated_ cell has a store to it,
+   ;; therefore this cell, being the new value, has to be remembered.
+   (inst call (make-fixup 'bitmap-cons-fallback :assembly-routine))
+   (assert-word-unused (ea this-cons))
+   (inst mov element (ea context))
+   (inst sub context 8)
+   (storew element this-cons cons-car-slot 0)
+   (inst or :byte this-cons list-pointer-lowtag) ; compute tagged ptr
+   (storew this-cons last cons-cdr-slot list-pointer-lowtag)
+   (inst mov last this-cons)
+   (inst dec :dword num-conses)
+   (inst jmp :nz OUTER)
+   TERMINATE))
+
+(define-assembly-routine (bitmap-listify) ()
+  (regs-pushlist rbx rdx rsi rdi r8 r9 r10)
+  (generate-list-allocator)
+  (storew nil-value last cons-cdr-slot list-pointer-lowtag)
+  (loadw rax-tn rsp-tn cons-cdr-slot 0) ; (CDR dummy)
+  (inst add rsp-tn 16)
+  (regs-poplist rbx rdx rsi rdi r8 r9 r10))
+
+(define-assembly-routine (bitmap-listify*) ()
+  (regs-pushlist rbx rdx rsi rdi r8 r9 r10)
+  (generate-list-allocator)
+  (inst mov element (ea context))
+  (storew element last cons-cdr-slot list-pointer-lowtag)
+  (loadw rax-tn rsp-tn cons-cdr-slot 0) ; (CDR dummy)
+  (inst add rsp-tn 16)
+  (regs-poplist rbx rdx rsi rdi r8 r9 r10))
+
+;;; Take RAX = element, RCX = count and return (MAKE-LIST ELEMENT COUNT)
+;;; in RAX, affecting no other registers.
+;;;      return-address    <-- RSP on entry
+;;;      [saved registers]  7 words
+;;;      dummy cons car
+;;;      dummy cons cdr    <-- RSP during execution
+#+nil (define-assembly-routine (make-list-helper) ()
+  (count-hit make-list-helper)
+  (regs-pushlist rbx rdx rsi rdi r8 r9)
+  (inst mov element rax-tn)
+  (inst lea ap (thread-slot-ea thread-ap4-slot))
+  (inst sub rsp-tn 16) ; rsp := dummy (struct cons)
+  (inst lea last (ea list-pointer-lowtag rsp-tn))
+  ;; top of outer do { } loop
+  OUTER
+  (inst mov bmwordptr (freebit.ptr))
+  (inst mov :dword curbit (freebit.mask))
+  (inst mov :dword allocated (ea bmwordptr))
+  ;; if (!(allocated & curbit))
+  (inst test :dword allocated curbit)
+  (inst jmp :nz SLOW-PATH)
+  ;; quick path: allocate at least 1 cons
+  (inst mov this-cons (freeptr))
+  (inst or :byte this-cons list-pointer-lowtag) ; compute tagged ptr
+  ;; top of inner do {} loop
+  INNER
+  (assert-word-unused (ea (- list-pointer-lowtag) this-cons))
+  (storew this-cons last cons-cdr-slot list-pointer-lowtag)
+  (storew element this-cons cons-car-slot list-pointer-lowtag)
+  (inst mov last this-cons)
+  (inst add this-cons 16)
+  (inst rol :dword curbit 1)
+  (inst jmp :nc NO-CARRY)
+  (inst add bmwordptr 4)
+  (inst mov :dword allocated (ea bmwordptr))
+  NO-CARRY
+  (inst dec :dword num-conses)
+  (inst jmp :z WRITEBACK) ; done
+  (inst test :dword allocated curbit)
+  (inst jmp :z INNER)
+  WRITEBACK ; exit from fast loop, flushing cached fields of 'struct alloc_ptr'
+  (inst mov (freebit.ptr) bmwordptr)
+  (inst mov (freebit.mask) curbit)
+  (inst sub :byte this-cons list-pointer-lowtag)
+  (inst mov (freeptr) this-cons)
+  (inst jrcxz TERMINATE)
+  SLOW-PATH
+  (inst call (make-fixup 'bitmap-alloc-fallback :assembly-routine))
+  (assert-word-unused (ea this-cons))
+  (storew element this-cons cons-car-slot 0)
+  (inst or :byte this-cons list-pointer-lowtag) ; compute tagged ptr
+  (storew this-cons last cons-cdr-slot list-pointer-lowtag)
+  (inst mov last this-cons)
+  (inst dec :dword num-conses)
+  (inst jmp :nz OUTER)
+  TERMINATE
+  (storew nil-value last cons-cdr-slot list-pointer-lowtag)
+  (loadw rax-tn rsp-tn cons-cdr-slot 0) ; (CDR dummy)
+  (inst add rsp-tn 16)
+  (regs-poplist rbx rdx rsi rdi r8 r9))
+)) ; end SYMBOL-MACROLET
+
+;;; Fallback routine are called after the inline code has tested 'freebit'
+;;; and found it to be unavailable.
+;;; All registers are preserved except for the destination.
+;;; The general routine takes alloc-ptr in the destination reg.
+#+sb-assembling
+(macrolet
+    ((gen-fallbacks ()
+       `(progn
+          ,@(loop
+              for reg in '(rax rbx rcx rdx rsi rdi r8 r9 r10 r11 r12 r14 r15)
+              collect
+              `(define-assembly-routine
+                   (,(symbolicate reg "-ALLOC-FALLBACK")
+                    (:return-style :none)
+                    (:export ,(symbolicate reg "-ALLOC16-FALLBACK")
+                             ,(symbolicate reg "-ALLOC32-FALLBACK")
+                             ,(symbolicate reg "-ALLOC64-FALLBACK")))
+                   ((:temp arg/res unsigned-reg ,(symbolicate reg "-OFFSET")))
+                 ENTRY
+                 (count-hit ,(symbolicate reg "-ALLOC-FALLBACK"))
+                 ;; Save RDI unless it is the arg/result register
+                 ,@(unless (eq reg 'rdi)
+                     '((inst push rdi-tn)
+                       (inst mov rdi-tn arg/res)))
+                 ;; Save RAX unless it is the destination register
+                 ,@(unless (eq reg 'rax)
+                     '((inst push rax-tn)))
+                 (inst call (make-fixup 'bitmap-alloc-fallback :assembly-routine))
+                 ,@(unless (eq reg 'rax) ; move the result if needed
+                     `((inst mov arg/res rax-tn)
+                       (inst pop rax-tn)))
+                 ;; Restore RDI
+                 ,@(unless (eq reg 'rdi)
+                     '((inst pop rdi-tn)))
+                 (inst ret)
+                 ,(symbolicate reg "-ALLOC16-FALLBACK")
+                 (count-hit ,(symbolicate reg "-ALLOC16-FALLBACK"))
+                 (inst lea arg/res (thread-slot-ea thread-ap4-slot))
+                 (inst jmp entry)
+                 ,(symbolicate reg "-ALLOC32-FALLBACK")
+                 (count-hit ,(symbolicate reg "-ALLOC32-FALLBACK"))
+                 (inst lea arg/res (thread-slot-ea thread-ap5-slot))
+                 (inst jmp entry)
+                 ,(symbolicate reg "-ALLOC64-FALLBACK")
+                 (count-hit ,(symbolicate reg "-ALLOC64-FALLBACK"))
+                 (inst lea arg/res (thread-slot-ea thread-ap6-slot))
+                 (inst jmp entry)
+                 )))))
+  (gen-fallbacks))
+
 ;;;; Signed and unsigned bignums from word-sized integers. Argument
 ;;;; and return in the same register. No VOPs, as these are only used
 ;;;; when called from a vop.
@@ -32,6 +235,7 @@
        `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg))
             ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
           (inst push number)
+          (count-hit ,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil)
           (popw number bignum-digits-offset other-pointer-lowtag)))
      (unsigned (reg)
@@ -42,10 +246,12 @@
           (inst push number)
           (inst jmp :ns one-word-bignum)
           ;; Two word bignum
+          (count-hit ,(symbolicate "ALLOC-UNSIGNED-BIGNUM2-IN-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 2) number nil nil nil)
           (popw number bignum-digits-offset other-pointer-lowtag)
           (inst ret)
           ONE-WORD-BIGNUM
+          (count-hit ,(symbolicate "ALLOC-UNSIGNED-BIGNUM1-IN-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil)
           (popw number bignum-digits-offset other-pointer-lowtag)))
      (from-digits (reg)
@@ -57,11 +263,13 @@
             ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
           (inst test :byte result result) ; is-two-digit flag
           (inst jmp :z one-word-bignum)
+          (count-hit ,(symbolicate "BIGNUM2-TO-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 2) result nil nil nil)
           (inst movdqu float0-tn (ea 8 rsp-tn))
           (inst movdqu (ea (- (ash 1 word-shift) other-pointer-lowtag) result) float0-tn)
           (inst ret 16) ; pop args
           ONE-WORD-BIGNUM
+          (count-hit ,(symbolicate "BIGNUM1-TO-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 1) result nil nil nil)
           (inst movq float0-tn (ea 8 rsp-tn))
           (inst movq (ea (- (ash 1 word-shift) other-pointer-lowtag) result) float0-tn)
@@ -75,6 +283,7 @@
        ;; rsp : return-pc
        `(define-assembly-routine (,(symbolicate "+BIGNUM-TO-" reg) (:return-style :none))
             ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
+          (count-hit ,(symbolicate "+BIGNUM-TO-" reg))
           (inst test :byte result result) ; is-two-or-three-digit flag
           (inst jmp :z one-word-bignum)
           ;; Since 2 digits and 3 digits consume the same number of bytes
@@ -105,6 +314,7 @@
           (inst set :c number)
           (inst movzx '(:byte :dword) number number)
           (inst push number)
+          (count-hit ,(symbolicate "TWO-WORD-BIGNUM-TO-" reg))
           (alloc-other bignum-widetag (+ bignum-digits-offset 2) number nil nil nil)
           (inst pop (ea (- (ash 2 word-shift) other-pointer-lowtag) number))
           (inst pop (ea (- (ash 1 word-shift) other-pointer-lowtag) number))

src/assembly/x86-64/arith.lisp

@@ -11,6 +11,20 @@
 
 (in-package "SB-VM")
 
+(defparameter *asm-routine-hit-counter-map*
+  (make-array 200 :fill-pointer 0))
+(eval-when (:compile-toplevel)
+(defmacro count-hit (name)
+  (declare (ignorable name))
+  #+nil
+  (let ((vector-data
+          (+ (static-data-collection-vector)
+             (ash vector-data-offset word-shift)
+             (- other-pointer-lowtag)))
+        (index (or (position name *asm-routine-hit-counter-map*)
+                   (vector-push-extend name *asm-routine-hit-counter-map*))))
+    `(inst inc :qword (ea ,(+ vector-data (ash index word-shift)))))))
+
 #-sb-assembling ; avoid redefinition warning
 (progn
 (defun both-fixnum-p (temp x y)
@@ -55,7 +69,7 @@
     (instrument-alloc bignum-widetag nbytes nil alloc-tn)
     (pseudo-atomic ()
       (allocation bignum-widetag nbytes 0 alloc-tn nil nil nil)
-      (storew* header alloc-tn 0 0 t)
+      (storew header alloc-tn 0 0)
       (storew source alloc-tn bignum-digits-offset 0)
       (if (eq dest alloc-tn)
           (inst or :byte dest other-pointer-lowtag)
@@ -100,6 +114,7 @@
     (inst rcr res 1)
     (when (> n-fixnum-tag-bits 1)   ; don't shift by 0
       (inst sar res (1- n-fixnum-tag-bits)))
+    (count-hit generic+)
     (return-single-word-bignum res rcx res))
 
   (define-generic-arith-routine (- 10)
@@ -114,6 +129,7 @@
     (inst rcr res 1)
     (when (> n-fixnum-tag-bits 1)   ; don't shift by 0
       (inst sar res (1- n-fixnum-tag-bits)))
+    (count-hit generic-)
     (return-single-word-bignum res rcx res))
 
   (define-generic-arith-routine (* 30)
@@ -133,12 +149,14 @@
     (inst cmp x rcx)
     (inst jmp :e SINGLE-WORD-BIGNUM)
 
+    (count-hit generic-mul=>2word)
     (alloc-other bignum-widetag (+ bignum-digits-offset 2) res nil nil nil)
     (storew rax res bignum-digits-offset other-pointer-lowtag)
     (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag)
     (inst clc) (inst ret)
 
     SINGLE-WORD-BIGNUM
+    (count-hit generic-mul=>1word)
     (return-single-word-bignum res res rax)))
 
 ;;;; negation

src/assembly/x86-64/support.lisp

@@ -97,27 +97,30 @@
   ;;   Lisp = save GPRs that lisp call can change
   (aver (member convention '(lisp c)))
   (aver (eql card-table-reg 12)) ; change detector
-  (let ((fpr-align 64)
+  (let* ((except (ensure-list except))
-        (except (ensure-list except))
+         (save-fprs (not (member :fprs except)))
-        (clobberables
+         (stack-align (if save-fprs 64 16))
-         (remove frame-reg
+         (c-nonvolatile '(rbx r12 r13 r14 r15))
-                 `(rax rbx rcx rdx rsi rdi r8 r9 r10 r11
+         (clobberables
-           ;; 13 is usable only if not permanently wired to the thread base
+          (remove frame-reg
-                       #+gs-seg r13
+                  `(rax rbx rcx rdx rsi rdi r8 r9 r10 r11
-                       r14 r15)))
+                        ;; 13 is usable only if not permanently wired to the thread base
-        (frame-tn (when frame-reg (symbolicate frame-reg "-TN"))))
+                        #+gs-seg r13
+                        r14 r15)))
+         (frame-tn (when frame-reg (symbolicate frame-reg "-TN"))))
+    (when (eq convention 'c)
+      (binding* ((check (intersection c-nonvolatile except) :exit-if-null))
+        ;; specifying registers not to be preseerved that would not be clobbered
+        ;; by C call is indicative of programmer error
+        (warn "Don't specify nonvolatile regs ~S in registers not to preserve"
+              check)))
+    (setq except (delete :fprs except))
     (aver (subsetp except clobberables)) ; Catch spelling mistakes
     ;; Since FPR-SAVE / -RESTORE utilize RAX, returning RAX from an assembly
-    ;; routine (by *not* preserving it) will be meaningless.
+    ;; routine (by *not* preserving it) does not work,
-    ;; You'd have to modify -SAVE / -RESTORE to avoid clobbering RAX.
+    ;; but you can still ask for it to explicitly not be preserved.
-    ;; This is a bit limiting: if you ask not to preserve RAX, what you mean is exactly that:
+    ;; You'd have to modify -SAVE / -RESTORE to avoid clobbering RAX
-    ;; it does not matter what value is gets. But EXCEPT has a dual purpose of also
+    ;; if that were needed.
-    ;; propagating the value out from BODY. We _should_ allow RAX in the list of things
-    ;; not to save, in case the caller wants to be maximally efficient and specify that RAX
-    ;; can be trashed with impunity. But it helps with incorrect usage for now
-    ;; to raise this error.
-    (when (member 'rax except)
-      (error "Excluding RAX from preserved GPRs probably will not do what you want."))
     (let* ((gprs ; take SET-DIFFERENCE with EXCEPT but in a predictable order
             (remove-if (lambda (x) (member x except))
                        (ecase convention
@@ -126,19 +129,26 @@
                          ;; all GPRs are potentially destroyed across lisp call
                          (lisp clobberables))))
            ;; each 8 registers pushed preserves 64-byte alignment
-           (alignment-bytes
+           (gpr-pad-bytes
-            (-  (nth-value 1 (ceiling (* n-word-bytes (length gprs)) fpr-align)))))
+            (-  (nth-value 1 (ceiling (* n-word-bytes (length gprs))
+                                      stack-align)))))
       `(progn
          ,@(when frame-tn
              `((inst push ,frame-tn)
                (inst mov ,frame-tn rsp-tn)))
-         (inst and rsp-tn ,(- fpr-align))
+         (inst and rsp-tn ,(- stack-align))
          (regs-pushlist ,@gprs)
-         (inst sub rsp-tn ,(+ alignment-bytes xsave-area-size))
+         ,@(cond (save-fprs
-         (call-fpr-save/restore-routine :save)
+                  `((inst sub rsp-tn ,(+ gpr-pad-bytes xsave-area-size))
+                    (call-fpr-save/restore-routine :save)))
+                 ((plusp gpr-pad-bytes)
+                  `((inst sub rsp-tn ,gpr-pad-bytes))))
          (assemble () ,@body)
-         (call-fpr-save/restore-routine :restore)
+         ,@(cond (save-fprs
-         (inst add rsp-tn ,(+ alignment-bytes xsave-area-size))
+                  `((call-fpr-save/restore-routine :restore)
+                    (inst add rsp-tn ,(+ gpr-pad-bytes xsave-area-size))))
+                 ((plusp gpr-pad-bytes)
+                  `((inst add rsp-tn ,gpr-pad-bytes))))
          (regs-poplist ,@gprs)
         ,@(cond ((eq frame-tn 'rbp)
                   '((inst leave)))

src/assembly/x86-64/tramps.lisp

@@ -14,7 +14,7 @@
   (inst pushf)
   (inst push rbp-tn)
   (inst mov rbp-tn rsp-tn)
-  (inst and rsp-tn (- 16))
+  (inst and rsp-tn -16)
   (inst sub rsp-tn 8) ; PUSHing an odd number of GPRs
   ;; Arrange in the utterly confusing order that a linux signal context has them
   ;; so that we can memcpy() into a context. Push RBX twice to maintain alignment.
@@ -31,6 +31,171 @@
   (inst leave)
   (inst popf))
 
+;; If reg holds a pointer and does not point to static or readonly space,
+;; then invoke the barrier. Should also check not pointing to a stack
+;; or arena etc. But this is adequate for now, and avoids the most common
+;; effectless barrier of setting a slot to NIL or T.
+;; This should use the pointer tag for something
+;; (because lists can't be large objects, etc)
+;;
+(defun test-pointer-interesting (reg &key yep nope)
+  (aver (not (location= reg rax-tn)))
+  (assemble ()
+    ;; Either the true or false branch but not both can be :DROPTHRU
+    (when (eq nope :dropthru) (setq nope DONE))
+    (when (eq yep :dropthru) (setq yep DONE))
+    ;; First check that reg holds a pointer.
+    (inst lea rax-tn (ea -3 reg))
+    ;; low 2 bits are 0 if it was a pointer. cf. is_lisp_pointer() in runtime.h
+    (inst test :byte rax-tn 3)
+    (inst jmp :nz NOPE) ; if nonzero then it's not a tagged pointer
+    ;; This is super easy if the object is in a small object subheap.
+    (inst sub rax-tn (static-symbol-value-ea 'bitmap-heap-base))
+    (inst cmp rax-tn (static-symbol-value-ea 'bitmap-heap-size))
+    (inst jmp :b YEP)
+    ;; Rule out readonly space
+    (inst mov rax-tn (ea (make-fixup "read_only_space_free_pointer" :foreign-dataref)))
+    (inst cmp reg (ea rax-tn))
+    (inst jmp :ae TEST-STATIC) ; above read-only space, so not in that space
+    (inst mov rax-tn (ea (make-fixup "READ_ONLY_SPACE_START" :foreign-dataref)))
+    (inst cmp reg (ea rax-tn))
+    ;; >= space start implies it is in the R/O space, therefore NOT a relevant pointer
+    (inst jmp :ae NOPE)
+    TEST-STATIC
+    ;; Rule out static addresses
+    (inst lea rax-tn (ea (- static-space-start) reg))
+    ;; If "below" after this comparison, that's a "nope", because
+    ;; the pointer sees static space and hence is uninteresting.
+    (inst cmp rax-tn (- static-space-end static-space-start))
+    ;; Figure out which way is the dropthru, and branch in the opposite case
+    (if (eq yep done) (inst jmp :b NOPE) (inst jmp :ae YEP))
+    DONE))
+
+;; TODOs:
+;; * remember() could be rewritten into Lisp or Lisp assembly so that we don't
+;;    have to save/restore all floating-point registers.
+;; * Probably want to add routines for:
+;;   - gc-barrier-store-car and gc-barrier-store-cdr which need no index
+;;   - gc-barrier-svset which takes the 2nd arg as a vector index
+;;   - gc-barrier-store-wordindexed which will take a constant 2nd arg
+
+(symbol-macrolet ((c-arg1 rdi-tn) (c-arg2 rsi-tn) (c-arg3 rdx-tn) (c-arg4 rcx-tn))
+(macrolet
+    ((define (name c-name)
+       `(define-assembly-routine (,name (:return-style :none)) ()
+          #+smlgc-telemetry (inst inc :qword (thread-slot-ea thread-ct-store-barriers-slot))
+          ;(inst ud1 rax-tn (ea rax-tn)) ; capture mcontext for debugging
+          (inst push rbp-tn) (inst mov rbp-tn rsp-tn) (regs-pushlist rax rcx)
+          ;; Stack:
+          ;;    saved-RCX  saved-RAX  saved-RBP  return-pc  Object   EA       val
+          ;; @  -16(rbp)   -8(rbp)    0(rbp)     8(rbp)     16(rbp)  24(rbp)  32(rbp)
+          (inst mov rax-tn (ea 24 rbp-tn)) ; EA
+          ;; Skip the barrier if storing into a dynamic-extent object by testing whether
+          ;; EA is within the control stack.
+          ;; untagged pointer case doesn't need to try to rule out stores to stack
+          ;; since there is no case where we create a dynamic-extent object containing
+          ;; a precise pointer that lacks tag bits.
+          ;; TODO: skip also if storing to static or pseudostatic space
+          ;; (basically the corefile-mapped ranges)
+          ,@(when (eq name 'gc-barrier-store)
+              '((inst cmp rax-tn rsp-tn) ; can't be a stack address if below RSP
+                (inst jmp :b continue)
+                (inst cmp rax-tn (thread-slot-ea thread-control-stack-end-slot))
+                (inst jmp :ae continue)
+                ;; Storing to a dynamic-extent object. No barrier needed
+                (inst mov rcx-tn (ea 32 rbp-tn)) ; newval into RCX
+                (inst mov (ea rax-tn) rcx-tn) ; newval to memory
+                (regs-poplist rbp rax rcx)
+                (inst ret 24))) ; remove 3 args
+          CONTINUE
+          ;; The barrier routines must be pseudo-atomic because testing the GC phase
+          ;; commits us to performing 0, 1, or 2 "remember" operations.
+          ;; Any pending phase change must not be acknowledged by the mutator
+          ;; until after the operations are done.
+          (pseudo-atomic ()
+            (inst mov rcx-tn (ea rax-tn)) ; get oldval into RCX
+            (inst mov rax-tn (ea 32 rbp-tn)) ; load newval
+            ;; Return quickly when (EQ OLD NEW) - consider that sml_cmpswap performs
+            ;; no barrier if its comparison failed.
+            (inst cmp rcx-tn rax-tn) ; old and new respectively
+            (inst jmp :e ELIDE)
+            ;; For untagged pointers, assume that the barrier is always needed.
+            ,@(unless (search "-UNTAGGED" (string name))
+               ;; Consider whether 'oldval' needs the deletion barrier
+               '((test-pointer-interesting rcx-tn :yep BARRIER :nope :dropthru)
+                 ;; Comment from C:
+                 ;; /* In either SYNC1, PRESYNC2, or SYNC2 phase, snooping
+                 ;;  * write barrier is required. */
+                 (inst cmp :byte (thread-slot-ea thread-gc-phase-slot) GC-PHASE-MARK)
+                 (inst jmp :e ELIDE)
+                 ;; reload newval. It's OK to use RCX because if 'oldval' needed
+                 ;; a deletion barrier, then we'd have already jumped to BARRIER.
+                 (inst mov rcx-tn (ea 32 rbp-tn))
+                 (test-pointer-interesting rcx-tn :yep :dropthru :nope ELIDE)
+                 ;; pass oldval as 0 when dropping through from here
+                 (zeroize rcx-tn)))
+            BARRIER
+            (with-registers-preserved (c :frame-reg nil :except (rax rcx #|:fprs|#))
+              (inst mov c-arg1 rcx-tn)         ; oldval
+              (inst mov c-arg2 (ea 32 rbp-tn)) ; newval
+              (inst mov c-arg3 (ea 16 rbp-tn)) ; object
+              (inst mov c-arg4 (ea 24 rbp-tn)) ; EA - for debugging only
+              (inst call (make-fixup ,c-name :foreign)))
+            (inst lea rsp-tn (ea -16 rbp-tn))
+            ELIDE
+            (inst mov rax-tn (ea 24 rbp-tn)) ; EA
+            (inst mov rcx-tn (ea 32 rbp-tn)) ; newval into RCX
+            (inst mov (ea rax-tn) rcx-tn))
+          (regs-poplist rbp rax rcx)
+          (inst ret 24)))) ; remove 3 args
+  (define gc-barrier-store "lisp_gcbar")
+  (define gc-barrier-store-untagged "lisp_gcbar_untagged"))
+
+;; compare-and-swap to a stack address is rare, don't try to optimize for it.
+;; Object, EA, newval are passed on stack; oldval in RAX.
+
+;; Performing the barrier _before_ doing the compare-exchange is bad for performance
+;; as it causes thousands of instructions to execute in between the user code's reading
+;; of 'oldval' and using it as the operand.
+;; it is necessary for correctness unless we can acquire the collector's spinlock
+;; that guards the objects_from_mutators.
+;; On the other hand, all threads suffer equally.
+(macrolet
+    ((define (name c-name)
+       `(define-assembly-routine (,name (:return-style :none)) ()
+          ;; Stack:
+          ;;    saved-RAX  saved-RCX  saved-RDX  saved-RBP  return-pc  Object   EA       val
+          ;; @  -24(rbp)   -16(rbp)   -8(rbp)    0(rbp)     8(rbp)     16(rbp)  24(rbp)  32(rbp)
+          (inst push rbp-tn) (inst mov rbp-tn rsp-tn) (regs-pushlist rdx rcx rax)
+          (inst mov rcx-tn rax-tn) ; RCX gets oldval
+          (inst mov rdx-tn (ea 32 rbp-tn)) ; RDX gets newval
+          (pseudo-atomic ()
+            ,@(unless (search "-UNTAGGED" (string name))
+                ;; Consider whether 'oldval' needs the deletion barrier
+                '((test-pointer-interesting rcx-tn :yep BARRIER :nope :dropthru)
+                  ;; If strictly after SYNC2 phase then the insertion barrier is disabled
+                  (inst cmp :byte (thread-slot-ea thread-gc-phase-slot) GC-PHASE-SYNC2)
+                  (inst jmp :a ELIDE)
+                  ;; Consider whether 'newval' needs the insertion barrier
+                  (test-pointer-interesting rdx-tn :yep :dropthru :nope ELIDE)))
+            BARRIER
+            (with-registers-preserved (c :frame-reg nil :except (rax rcx rdx #|:fprs|#))
+              (move c-arg1 rcx-tn) ; oldval
+              (move c-arg2 rdx-tn) ; newval
+              (inst mov c-arg3 (ea 16 rbp-tn)) ; object
+              (inst mov c-arg4 (ea 24 rbp-tn)) ; EA
+              (inst call (make-fixup ,c-name :foreign)))
+            (inst lea rsp-tn (ea -24 rbp-tn))
+            ELIDE
+            (inst pop rax-tn) ; oldval
+            (inst mov rcx-tn (ea 24 rbp-tn)) ; EA
+            (inst mov rdx-tn (ea 32 rbp-tn)) ; newval
+            (inst cmpxchg :lock (ea rcx-tn) rdx-tn)) ; actual oldval goes to RAX
+          (regs-poplist rbp rdx rcx)
+          (inst ret 24)))) ; remove 3 args
+  (define gc-barrier-cmpxchg "lisp_gcbar")
+  (define gc-barrier-cmpxchg-untagged "lisp_gcbar_untagged"))
+
 (macrolet ((do-fprs (operation regset &aux (displacement 0))
              ;; The YMM case could be removed now I suppose, since we use XSAVE + XRSTOR
              (multiple-value-bind (mnemonic fpr-align)
@@ -83,11 +248,286 @@
     (inst xrstor (ea 16 rsp-tn))
     (inst pop rdx-tn)))
 
-(define-assembly-routine (switch-to-arena (:return-style :raw)) ()
+(macrolet
+    ((choose-allocptr ()
+       '(progn
+          (inst cmp size smlgc-blocksize-max)
+          (inst jmp :a LARGE)
+          (inst lea :dword ap (ea -1 size)) ; size 16 becomes 15 etc
+          (inst bsr :dword ap ap) ; size 16 -> 3, 32 -> 4, etc
+          (inst shl :dword ap 5) ; ap *= sizeof (struct alloc_ptr)
+          (inst lea ap (ea (+ (ash thread-ap4-slot word-shift) (* -3 32))
+                           thread-tn ap))))
+      (allocate ()
+       '(let ((ok (gen-label)) (skip (gen-label)) (continue (gen-label)))
+          (inst mov bmwordptr-reg (freebit.ptr))
+          (inst mov :dword mask (freebit.mask)) ; MASK has the bit we want next
+          (inst test :dword (ea bmwordptr-reg) mask) ; can we have it?
+          (inst jmp :z OK)
+          ;; RDI holds the allocation pointer
+          (inst call (make-fixup 'bitmap-alloc-fallback :assembly-routine))
+          (inst jmp continue)
+          (emit-label OK)
+          ;; advance the bit, w/wraparound
+          (inst rol :dword mask 1)
+          (inst mov :dword (freebit.mask) mask) ; writeback
+          ;; possibly increment bitmap word ptr
+          (inst jmp :nc SKIP)
+          (inst add bmwordptr-reg 4)
+          (inst mov (freebit.ptr) bmwordptr-reg)
+          (emit-label SKIP)
+          (inst mov rax-tn (segment.blocksize))
+          (inst xadd (freeptr) rax-tn)
+          (emit-label CONTINUE)
+          (assert-word-unused (ea rax-tn)))))
+(symbol-macrolet ((size rax-tn)
+                  (bmwordptr-reg rax-tn) ; same physical reg as SIZE
+                  (ap rdi-tn)
+                  (mask rcx-tn)
+                  (xmm-temp float7-tn)) ; declared as a vop temp
+;;; For both of these routes: RAX recives SIZE and returns the result
+(with-bitmap-ap (ap)
+(define-assembly-routine (bitmap-vect-alloc (:return-style :none)) ()
+  (inst push rbp-tn) (inst mov rbp-tn rsp-tn) (regs-pushlist rcx rdi)
+  ;; Stack:
+  ;;     saved-RDI  saved-RCX  saved-RBP  return-pc  WIDETAG  LENGTH
+  ;;; @  -16(rbp)   -8(rbp)    0(rbp)     8(rbp)     16(rbp)  24(rbp)
+  (choose-allocptr)
+  (pseudo-atomic ()
+    (allocate)
+    ;; Store the first 2 words, and OR in the lowtag
+    (inst movdqu xmm-temp (ea 16 rbp-tn)) ; load 2 lispwords
+    (inst movdqa (ea rax-tn) xmm-temp)
+    (inst or :byte rax-tn other-pointer-lowtag))
+  DONE
+  (regs-poplist rbp rcx rdi)
+  (inst ret 16) ; Clean args
+  LARGE
+  ;; Pretty much just like VAR-ALLOC now
+  (move rdi-tn rax-tn)
+  (with-registers-preserved (lisp :except (rax rcx rdi) :frame-reg nil)
+    (inst lea rsi-tn (ea 16 rbp-tn)) ; 2nd C arg = pointer to header words
+    (pseudo-atomic ()
+      (inst call (make-fixup "vect_alloc_large" :foreign)))
+    (inst mov rcx-tn rax-tn)) ; protect from FPR-restore which clobbers RAX
+  (inst mov rax-tn rcx-tn) ; Restore the result
+  (inst lea rsp-tn (ea -16 rbp-tn)) ; Restore RSP to a known value
+  (inst jmp DONE))
+
+(define-assembly-routine (bitmap-var-alloc (:return-style :none)) ()
+  (inst push rbp-tn) (inst mov rbp-tn rsp-tn) (regs-pushlist rcx rdi)
+  ;; Stack:
+  ;;     saved-RDI  saved-RCX  saved-RBP  return-pc  HEADER   LOWTAG
+  ;;; @  -16(rbp)   -8(rbp)    0(rbp)     8(rbp)     16(rbp)  24(rbp)
+  (choose-allocptr)
+  (pseudo-atomic ()
+    (allocate)
+    (inst mov rcx-tn (ea 16 rbp-tn)) ; load the header
+    (inst mov (ea rax-tn) rcx-tn) ; write the header into the new object
+    (inst or :byte rax-tn (ea 24 rbp-tn))) ; tag the pointer
+  DONE
+  (regs-poplist rbp rcx rdi)
+  (inst ret 16) ; Clean args
+  LARGE
+  ;; This routine calls C and Lisp, so in theory we need only save C registers
+  ;; because C's funcall would save the ones that Lisp may clobber, in order to
+  ;; preserve C convention. But we in fact need to see all GPRs on the stack
+  ;; in case GC requests a sync2.
+  ;; So save all registers except RAX and the two already saved,
+  ;; but first put RAX (the size) in the 1st C arg register
+  (move rdi-tn rax-tn)
+  (with-registers-preserved (lisp :except (rax rcx rdi) :frame-reg nil)
+    (inst mov rsi-tn (ea 16 rbp-tn)) ; 2nd C arg = header
+    (pseudo-atomic ()
+      (inst call (make-fixup "var_alloc_large" :foreign))
+      ;; C call returned an untagged pointer to the large object in RAX.
+      (inst mov rcx-tn rax-tn) ; protect from FPR-restore which clobbers RAX
+      (inst or :byte rcx-tn (ea 24 rbp-tn)))) ; tag the pointer
+  (inst mov rax-tn rcx-tn) ; Restore the result
+  (inst lea rsp-tn (ea -16 rbp-tn)) ; Restore RSP to a known value
+  (inst jmp DONE)))))
+
+;;; Take alloc-ptr in RDI, return a free block in RAX. Preserve all other registers.
+(macrolet
+    ((alignment-padding ()
+       ;; after pushing the nonvolatile GPRs, subtract this much more from RSP
+       ;; to preserve alignment as needed for FPR save/restore
+       (* 5 n-word-bytes))
+     (define-fallback (name c-fallback2)
+       `(define-assembly-routine (,name) ()
+          (inst push rbp-tn)
+          (inst mov rbp-tn rsp-tn)
+          ;; align stack to required boundary in case we're going to save/restore FPRs later
+          (inst and rsp-tn -64)
+           ;; save the volatile registers, preserving 64-byte stack alignment
+          (regs-pushlist rcx rdx rsi r8 r9 r10 r11 rdi)
+          ;; 8 registers were pushed, so the stack is correctly aligned for C call
+          (inst call (make-fixup "smlgc_search_freebit" :foreign))
+          (inst test rax-tn rax-tn)
+          (inst jmp :nz success)
+          (inst mov rdi-tn (ea rsp-tn)) ; reload the allocation-ptr
+          ;; Now even though the callee-saved ("nonvolatile") regs won't be clobbered by
+          ;; the C call, they must be spilled to the stack so that a root scan sees them
+          ;; above the stack pointer.
+          ;; There is no interrupt context to scan if GC decides to run, and in fact
+          ;; if this thread suspends itself waiting for GC, then GC may perform the sync2
+          ;; action (graying of roots) on behalf of the lisp thread, in which case it has
+          ;; no way to obtain the register contents. (And it would need libunwind to
+          ;; get the register context of each frame. Way too complicated)
+          (regs-pushlist rbx r14 r15) ; 12 and 13 won't point to lisp objects
+          ;; Inform the collector where the roots start.
+          (inst mov rsi-tn rsp-tn)
+          ;; Create the FPR save area
+          (inst sub rsp-tn (+ xsave-area-size (alignment-padding)))
+          (call-fpr-save/restore-routine :save)
+          (inst call (make-fixup ,c-fallback2 :foreign))
+          (inst mov rcx-tn rax-tn) ; save a backup of RAX since FPR-restore clobbers it
+          (call-fpr-save/restore-routine :restore)
+          (inst add rsp-tn (+ xsave-area-size (alignment-padding))) ; Unallocate FPR save area
+          (inst mov rax-tn rcx-tn) ; restore RAX
+          (regs-poplist rbx r14 r15) ; 12 and 13 won't point to lisp objects
+          SUCCESS
+          (regs-poplist rcx rdx rsi r8 r9 r10 r11 rdi)
+          (assert-word-unused (ea rax-tn))
+          (inst leave))))
+  (define-fallback bitmap-alloc-fallback "sml_alloc_fallback2")
+  (define-fallback bitmap-cons-fallback "sml_cons_fallback2"))
+
+;;; This attempts to claim N consecutive cons cells at the current index
+;;; based on the number of bytes desired, supplied in RCX.
+;;; On success, RAX is the result and ZF is clear.
+;;; On failure, RAX is 0 and ZF is set.
+(symbol-macrolet ((rax rax-tn) (rcx rcx-tn))
+(with-bitmap-ap (:thread thread-ap4-slot)
+(define-assembly-routine (bitmap-reserve-&rest) ()
+  ;; Convert RCX back to a count of conses, not a byte count.
+  (inst shr :dword rcx (1+ word-shift))
+  ;; Always take the slow path if the request exceeds 15 conses. The rationale is
+  ;; that half the time, the next bit to be examined in the current mask is in the
+  ;; upper 16 (assuming uniform distribution), which means that consecutive bits
+  ;; would wrap to the next bitmap word, leaving aside the question of whether
+  ;; those cells are actually available.
+  (inst cmp :dword rcx 16)
+  ;; If NOT profiling &REST list sizes:
+  (inst jmp :ae FAIL)
+  ;; If profiling &REST list sizes:
+  ;(inst jmp :b SMALL)
+  ;(inst inc :lock :dword (ea (cons-stats-v))) ; too big
+  ;(inst jmp FAIL)
+  ;SMALL
+  ;(inst inc :lock :dword (ea (cons-stats-v) nil rcx 8))
+  (inst mov :dword rax (freebit.mask))
+  (let ((temp rdx-tn))
+    (inst push temp)
+    ;; Calculate the full mask of bits that we'd like to see available
+    ;; as (LOGXOR (1- (ASH MASK NBITS)) (1- MASK)). This sets all bits below
+    ;; and including the highest desired, and clears below the current mask.
+    (inst lea :dword temp (ea -1 rax)) ; temp := (1- MASK)
+    (inst shl rax :cl)   ; = (ASH MASK NBITS), won't overflow a :QWORD
+    (inst dec rax)       ; = (1- (ASH MASK NBITS))
+    (inst xor rax temp)
+    ;; See if all the bits in RAX are clear in the allocator bitmap
+    (inst mov temp (freebit.ptr))
+    (inst test :dword (ea temp) rax)
+    (inst pop temp)) ; done using TEMP
+  (inst jmp :nz FAIL)
+  ;; Verify that none of the upper 32 bits of RAX are 1. If any are,
+  ;; then the :DWORD-sized TEST just performed was not valid.
+  (inst shr rax 32)
+  (inst jmp :nz FAIL) ; oops, RAX had some upper bit on
+  ;; success
+  (inst rol :dword (freebit.mask) :cl) ; update the mask
+  (inst sbb :dword rax rax)
+  (inst and :dword rax 4) ; = 0 or 4 depending on CF prior to SBB
+  (inst add :qword (freebit.ptr) rax)
+  (inst shl :dword rcx (1+ word-shift)) ; convert to byte count once again
+  (inst mov :dword rax rcx)
+  ;; RAX gets the free pointer, and free pointer is bumped by N bytes
+  (inst xadd (freeptr) rax) ; ZF will be cleared
+  (inst ret)
+  FAIL
+  ;; When exiting with failure, RCX is a count of elements, not bytes.
+  ;; That's exactly what the fallback handler wants.
+  (zeroize rax)))) ; sets ZF
+
+;;; These are the fallback routines for a single cons at a time.
+;;; Registers are unaffected except for the destination.
+(macrolet ((define-cons-fallbacks (&rest regs)
+             `(progn
+                ,@(mapcar
+                   (lambda (reg)
+                     `(define-assembly-routine (,(symbolicate "BITMAP-CONS-TO-" reg "-FALLBACK")) ()
+                        (count-alloc :cons1-slow)
+                        ,@(unless (eq reg 'rdi) '((inst push rdi-tn)))
+                        ,@(unless (eq reg 'rax) '((inst push rax-tn)))
+                        (inst lea rdi-tn (thread-slot-ea thread-ap4-slot))
+                        (inst call (make-fixup 'bitmap-alloc-fallback :assembly-routine))
+                        ,@(unless (eq reg 'rax)
+                            `((inst mov ,(symbolicate reg "-TN") rax-tn)
+                              (inst pop rax-tn)))
+                        ,@(unless (eq reg 'rdi) '((inst pop rdi-tn)))))
+                   regs))))
+  (define-cons-fallbacks rax rcx rdx rbx rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
+
+;;; For all these, the args were pushed left-to-right.
+;;; Compute the address of the highest arg, load the byte count,
+;;; call BITMAP-LISTIFY, then clean the stack.
+(macrolet ((call (n routine)
+             `(progn
+                (inst push rcx-tn)
+                (inst mov rcx-tn ,n) ; how many conses to make (NOT how many args)
+                (inst call (make-fixup ',routine :assembly-routine))
+                (inst pop rcx-tn))))
+(define-assembly-routine (bitmap-list2-fallback (:return-style :none)) () ; 2 conses
+  (count-alloc :cons2-slow)
+  (inst lea rax-tn (ea 16 rsp-tn))
+  (call 2 bitmap-listify)
+  (inst ret (* 2 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list3-fallback (:return-style :none)) () ; 3 conses
+  (count-alloc :cons3-slow)
+  (inst lea rax-tn (ea 24 rsp-tn))
+  (call 3 bitmap-listify)
+  (inst ret (* 3 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list4-fallback (:return-style :none)) () ; 4 conses
+  (count-alloc :cons4-slow)
+  (inst lea rax-tn (ea 32 rsp-tn))
+  (call 4 bitmap-listify)
+  (inst ret (* 4 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list5-fallback (:return-style :none)) () ; 5 conses
+  (count-alloc :cons5-slow)
+  (inst lea rax-tn (ea 40 rsp-tn))
+  (call 5 bitmap-listify)
+  (inst ret (* 5 n-word-bytes)))
+
+(define-assembly-routine (bitmap-list*3-fallback (:return-style :none)) () ; 2 conses
+  (count-alloc :cons2-slow)
+  (inst lea rax-tn (ea 24 rsp-tn))
+  (call 2 bitmap-listify*)
+  (inst ret (* 3 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list*4-fallback (:return-style :none)) () ; 3 conses
+  (count-alloc :cons3-slow)
+  (inst lea rax-tn (ea 32 rsp-tn))
+  (call 3 bitmap-listify*)
+  (inst ret (* 4 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list*5-fallback (:return-style :none)) () ; 4 conses
+  (count-alloc :cons4-slow)
+  (inst lea rax-tn (ea 40 rsp-tn))
+  (call 4 bitmap-listify*)
+  (inst ret (* 5 n-word-bytes))) ; pop args
+(define-assembly-routine (bitmap-list*6-fallback (:return-style :none)) () ; 5 conses
+  (count-alloc :cons5-slow)
+  (inst lea rax-tn (ea 48 rsp-tn))
+  (call 5 bitmap-listify*)
+  (inst ret (* 6 n-word-bytes))) ; pop args
+) ; end MACROLET
+
+;;;; End of bitmap allocator trampolines
+
+(define-assembly-routine (switch-to-arena) ()
   (inst mov rsi-tn (ea rsp-tn)) ; explicitly  pass the return PC
   ;; RSI and RDI are vop temps, so don't bother preserving them
   (with-registers-preserved (c :except (rsi rdi))
-    (pseudo-atomic ()
+    (pseudo-atomic (:sml-check nil)
       #-system-tlabs (inst break halt-trap)
       #+system-tlabs (call-c (make-fixup "switch_to_arena" :foreign) #+win32 rdi-tn #+win32 rsi-tn))))
 
@@ -141,6 +581,11 @@
     (call-c (make-fixup "alloc_funinstance" :foreign)
             (ea 16 rbp-tn))
     (inst mov (ea 16 rbp-tn) rax-tn)))
+(define-assembly-routine (set-funinstance-ref) ()
+  (with-registers-preserved (c)
+    (pseudo-atomic ()
+      (call-c (make-fixup "set_funinstance_slot" :foreign)
+              (ea 16 rbp-tn) (ea 24 rbp-tn) (ea 32 rbp-tn)))))
 
 ;;; These routines are for the deterministic consing profiler.
 ;;; The C support routine's argument is the return PC.
@@ -236,7 +681,7 @@
   (loadw rax-tn rax-tn funcallable-instance-function-slot fun-pointer-lowtag)
   (inst jmp (object-slot-ea rax-tn closure-fun-slot fun-pointer-lowtag)))
 
-(define-assembly-routine (ensure-symbol-hash (:return-style :raw)) ()
+(define-assembly-routine (ensure-symbol-hash) ()
   (with-registers-preserved (lisp)
     (inst mov rdx-tn (ea 16 rbp-tn)) ; arg
     (call-static-fun 'ensure-symbol-hash 1)
@@ -254,16 +699,27 @@
 ;;;    This is especially important for immobile space where
 ;;;    it is likely that new code will be co-located on a page
 ;;;    with old code due to the non-moving allocator.
+
+;; stack: ret-pc, object, index, value-to-store
+(symbol-macrolet ((object (ea 8 rsp-tn))
+                  (word-index (ea 16 rsp-tn))
+                  (newval (ea 24 rsp-tn))
+                  ;; these are declared as vop temporaries
+                  (rax rax-tn)
+                  (rdx rdx-tn)
+                  (rdi rdi-tn))
 (define-assembly-routine (code-header-set (:return-style :none)) ()
-  ;; stack: ret-pc, object, index, value-to-store
+  (inst cmp :dword (thread-slot-ea (1+ thread-ap4-slot)) -1)
-  (symbol-macrolet ((object (ea 8 rsp-tn))
+  (inst jmp :e GENCGC-ALLOC)
-                    (word-index (ea 16 rsp-tn))
+  ;; Just tail-call GC-BARRIER-STORE after changing the 2nd arg to an EA.
-                    (newval (ea 24 rsp-tn))
+  ;; (Don't bother trying to optimize out the call)
-                    ;; these are declared as vop temporaries
+  (inst mov rdi object)
-                    (rax rax-tn)
+  (inst mov rdx word-index)
-                    (rdx rdx-tn)
+  (inst lea rdx (ea (- other-pointer-lowtag) rdi rdx n-word-bytes))
-                    (rdi rdi-tn))
+  (inst mov word-index rdx)
-    (pseudo-atomic ()
+  (inst jmp (make-fixup 'gc-barrier-store :assembly-routine))
+  GENCGC-ALLOC
+  (pseudo-atomic (:sml-check nil)
       #+immobile-space
       (progn
         #-sb-thread
@@ -292,5 +748,56 @@
       ;; set 'written' flag in the code header
       (inst or :byte :lock (ea (- 3 other-pointer-lowtag) rdi) #x40)
       ;; store newval into object
-      (inst mov (ea (- other-pointer-lowtag) rdi rdx n-word-bytes) rax)))
+      (inst mov (ea (- other-pointer-lowtag) rdi rdx n-word-bytes) rax))
-  (inst ret 24)) ; remove 3 stack args
+  (inst ret 24))) ; remove 3 stack args
+
+(define-assembly-routine (set-fdefn-fun (:return-style :none)) ()
+  ;; Stack:
+  ;;    saved-RBP  return-pc  Fdefn    Fun      RawFun
+  ;;; @ 0(rbp)     8(rbp)     16(rbp)  24(rbp)  32(rbp)
+  (with-registers-preserved (c)
+    (inst mov c-arg1 (ea 16 rbp-tn))
+    (inst mov c-arg2 (ea 24 rbp-tn))
+    (inst mov c-arg3 (ea 32 rbp-tn))
+    (pseudo-atomic (:sml-check nil)
+     (inst call (make-fixup "set_fdefn_fun" :foreign))))
+  (inst ret 24))
+
+(define-assembly-routine (weak-pointer-ref (:return-style :none)) ()
+  ;; weak pointer is on the stack
+  (with-registers-preserved (c)
+    (inst mov rax-tn (ea 16 rbp-tn))
+    (inst lea c-arg1 (object-slot-ea rax-tn weak-pointer-value-slot other-pointer-lowtag))
+    (inst call (make-fixup "weak_pointer_ref" :foreign)))
+  (inst ret 8))
+
+(define-assembly-routine (weak-vector-ref (:return-style :none)) ()
+  ;; weak vector was pushed first, then the index
+  (with-registers-preserved (c)
+    (inst mov rax-tn (ea 24 rbp-tn))
+    (inst mov rcx-tn (ea 16 rbp-tn))
+    (inst lea c-arg1 (ea (- (ash vector-data-offset word-shift) other-pointer-lowtag)
+                         rax-tn rcx-tn (ash 1 (- word-shift n-fixnum-tag-bits))))
+    (inst call (make-fixup "weak_vector_ref" :foreign)))
+  (inst ret 16))
+
+(define-assembly-routine (weak-vector-set (:return-style :none)) ()
+  ;; stack: RA Obj EA Val
+  (with-registers-preserved (c)
+    (inst mov c-arg1 (ea 24 rbp-tn))
+    (inst mov c-arg2 (ea 32 rbp-tn))
+    ;; For the non-weak store barrier we don't use the PSEUDO-ATOMIC macro,
+    ;; but instead the instruction is "implicitly pseudo-atomic".
+    ;; The weak barrier is not implicitly pseudo-atomic.
+    (pseudo-atomic () (inst call (make-fixup "weak_vector_set" :foreign))))
+  (inst ret 24))
+
+(define-assembly-routine (gc-check) ()
+  (with-registers-preserved (lisp)
+    (inst mov c-arg1 rsp-tn)
+    (inst call (make-fixup "lisp_gc_check" :foreign))))
+) ; end PROGN
+
+(define-assembly-routine (release-malloc-segments) ()
+  (with-registers-preserved (lisp)
+    (call-static-fun 'release-malloc-segments 0)))

src/code/alloc.lisp

@@ -166,14 +166,14 @@
                            (values code-component (integer 0)))
                 allocate-code-object))
 
-(defun update-dynamic-space-code-tree (obj)
+(defun update-dynamic-space-code-tree (obj &optional generation-test)
   (with-pinned-objects (obj)
     (let ((addr (logandc2 (get-lisp-obj-address obj) other-pointer-lowtag))
           (tree *dynspace-codeblob-tree*))
       (loop (let ((newtree (sb-brothertree:insert addr tree)))
               ;; check that it hasn't been promoted from gen0 -> gen1 already
               ;; (very unlikely, but certainly possible).
-              (unless (eq (generation-of obj) 0) (return))
+              (when (and generation-test (not (eql (generation-of obj) 0))) (return))
               (let ((oldval (cas *dynspace-codeblob-tree* tree newtree)))
                 (if (eq oldval tree) (return) (setq tree oldval))))))))
 
@@ -225,6 +225,16 @@
                 (alien-funcall (extern-alien "alloc_code_object"
                                              (function unsigned (unsigned 32) (unsigned 32)))
                                total-words boxed)))))
+      ;; Small objects are always findable given an interior pointer,
+      ;; but large objects require the tree.
+      (when (and (neq (heap-allocated-p code) :dynamic)
+                 (> total-words (/ smlgc-blocksize-max n-word-bytes)))
+        (let ((tree *immobile-codeblob-tree*)
+              (addr (logandc2 (get-lisp-obj-address code) lowtag-mask)))
+          (loop (let ((newtree (sb-brothertree:insert addr tree)))
+                  (when (eq tree (setf tree (cas *immobile-codeblob-tree* tree newtree)))
+                    (return)))))
+        (return-from allocate-code-object (values code total-words)))
       (update-dynamic-space-code-tree code)
     ;; FIXME: there may be random values in the unboxed payload and it's not obvious
     ;; that all callers of ALLOCATE-CODE-OBJECT always write all raw bytes.
@@ -265,7 +275,7 @@
       ;; memory block at that address. Consider if we removed from the pool
       ;; without removing from the tree, the block could be coalesced on either side
       ;; and there would not necessarily be a block where the tree says it is.
-      (let ((tree sb-vm::*immobile-codeblob-tree*))
+      (let ((tree *immobile-codeblob-tree*))
         (loop (when (eq tree (setq tree (cas *immobile-codeblob-tree* tree
                                              (sb-brothertree:delete addr tree))))
                 (return))))
@@ -278,3 +288,197 @@
           (alien-funcall tlsf-unalloc-codeblob tlsf-control addr)
           (setf (car scratchpad) (pop-1)))))
     t))
+
+(define-alien-variable msegs-pending-free unsigned)
+
+#|
+(defglobal *large-object-hashset* nil)
+(defun largeobj-hs-insert (node object)
+  ;; NODE is an instance, OBJECT is anything.
+  (let ((addr (%make-lisp-obj (logandc2 (get-lisp-obj-address object) lowtag-mask))))
+    (sb-lockless:%so-eq-set-phase1-insert *large-object-hashset* node addr)))
+
+(defun largeobj-hs-maybe-rehash (node)
+  (sb-lockless:%so-eq-set-phase2-insert *large-object-hashset* node))
+|#
+
+;; GC-freed malloc-segments are chained through word 0 which happens to correspond
+;; to the 'as_list' slot in the C structure definition. The actual deallocation
+;; is deferred to Lisp so that we can remove from the lookup tables.
+(defun release-malloc-segments (&aux (count 0))
+  (flet ((segment-pop ()
+           (named-let retry ((mseg msegs-pending-free))
+             (if (zerop mseg)
+                 0
+                 (let* ((next (sap-ref-word (int-sap mseg) 0))
+                        (actual (cas msegs-pending-free mseg next)))
+                   (if (= actual mseg)
+                       (%make-lisp-obj mseg)
+                       (retry actual)))))))
+    (loop
+      (let ((mseg (truly-the fixnum (segment-pop))))
+        (when (zerop mseg)
+          #+nil
+          (let ((s "Released %d large code blocks"))
+            (alien-funcall (extern-alien "tprintf" (function void int system-area-pointer int))
+                           1 (vector-sap s) count))
+          (return))
+        (let* ((mseg-sap (descriptor-sap mseg))
+               (object-sap (sap+ mseg-sap smlgc-mseg-overhead-bytes))
+               (addr (truly-the (unsigned-byte 56) (sap-int object-sap))))
+          ;; the header was copied to wordindex 1 and then zeroized
+          (aver (= (widetag@baseptr (sap+ object-sap n-word-bytes))
+                   code-header-widetag))
+          (let ((tree *immobile-codeblob-tree*))
+            (loop (when (eq tree (setq tree (cas *immobile-codeblob-tree* tree
+                                                 (sb-brothertree:delete addr tree))))
+                    (return))))
+          (sb-thread:barrier (:write))
+          (with-alien ((delete-code-mseg (function void system-area-pointer) :extern))
+            (alien-funcall delete-code-mseg mseg-sap))
+          (incf count))))))
+
+;; Display but do not pop them off the list
+(defun show-releasable-malloc-segments ()
+  (let ((seg msegs-pending-free))
+    (loop (when (zerop seg) (return))
+          ;; show 4 words of the metadata, then the lispobj header word (which should be 0)
+          ;; and the word after that (which gets the header word before clobbering)
+          (let ((sap (int-sap seg)))
+            (format t "@ ~X:~{ ~16X~}~%"
+                    seg (loop for i below 6 collect (sap-ref-word sap (ash i word-shift))))
+            (setq seg (sap-ref-word sap 0))))))
+
+#+nil
+(defun call-with-sml#gc (which thunk)
+  (if (listp which) (apply #'use-smlgc which) (use-smlgc which))
+  (prog1 (funcall thunk)
+    (setq *use-smlgc* 0)))
+
+#+nil
+(defmacro with-sml#-allocator (&body body)
+  `(progn (setq *use-smlgc* -1)
+          (alien-funcall (extern-alien "enable_cms_cons" (function void)))
+          (multiple-value-prog1 (progn ,@body)
+            (alien-funcall (extern-alien "disable_cms_cons" (function void)))
+            (setq *use-smlgc* 0))))
+
+#+nil(defun sml#-cons (a b) (with-sml#-allocator (cons a b)))
+
+#+nil
+(defun force-barrier-on ()
+  (let ((phaseptr (find-dynamic-foreign-symbol-address "fake_phaseptr")))
+    (let* ((vmthread (current-thread-offset-sap thread-this-slot)))
+      (setf (sap-ref-word vmthread (ash thread-gc-phaseptr-slot word-shift))
+            phaseptr))))
+
+#+nil
+(defun call-with-barrier-forced-on (thunk)
+  (let ((phaseptr (find-dynamic-foreign-symbol-address "fake_phaseptr")))
+    (let* ((vmthread (current-thread-offset-sap thread-this-slot))
+           (actual-phaseptr (sap-ref-word vmthread (ash thread-gc-phaseptr-slot word-shift))))
+      (setf (sap-ref-word vmthread (ash thread-gc-phaseptr-slot word-shift))
+            phaseptr)
+      (multiple-value-prog1
+          (funcall thunk)
+        (setf (sap-ref-word vmthread (ash thread-gc-phaseptr-slot word-shift))
+              actual-phaseptr)))))
+
+(defun showlarge ()
+;  (sb-lockless::show-address-based-list sb-vm::*large-object-hashset*)
+  )
+
+#+nil
+(defun careful-obj-to-malloc-segment (addr)
+  (alien-funcall (extern-alien "careful_obj_to_malloc_segment"
+                               (function system-area-pointer unsigned))
+                 addr))
+
+#+nil
+(defun assert-all-large-simple-funs-findable ()
+  (let ((list (sb-brothertree::codeblob-tree-to-list sb-vm::*immobile-codeblob-tree*)))
+    (dolist (c list)
+      (let* ((code-base-addr (logandc2 (get-lisp-obj-address c) lowtag-mask))
+             (mseg (int-sap (- code-base-addr smlgc-mseg-overhead-bytes))))
+        (flet ((test (obj &aux (addr (logandc2 (get-lisp-obj-address obj)
+                                               lowtag-mask)))
+                 ;; every lowtag wouldn't be needed but it's an OK thing to test
+                 (dotimes (lowtag 16)
+                   (assert (sap= (careful-obj-to-malloc-segment (logior addr lowtag))
+                                 mseg)))))
+          (test c)
+          (dotimes (index (code-n-entries c))
+            (test (%code-entry-point c index))))))))
+
+(defun show-bitmap-aps ()
+  (loop for log2size from 4 to 12
+        for slot from thread-ap4-slot by 4
+        do
+     (format t "~2d ~16x ~8x ~16x ~4x~%"
+             log2size
+             (sap-int (current-thread-offset-sap slot))
+             (sap-int (current-thread-offset-sap (+ 1 slot)))
+             (sap-int (current-thread-offset-sap (+ 2 slot)))
+             (sap-int (current-thread-offset-sap (+ 3 slot))))))
+
+(defvar *stats*)
+
+(defun get-consing-stats ()
+  (setq *stats* (sb-kernel:make-lisp-obj (sb-vm::static-data-collection-vector)))
+  ;; element 0  : number of &REST lists of length 16 or more
+  ;; elt 1..15  : packed integer
+  ;;              hi = number of &REST lists of length N using slow path
+  ;;              lo = number of &REST lists of length N
+  ;; elt 16..25 : number of lists composed of N cons cells
+  (values (loop for i from 16 by 2 repeat 6
+                collect (let* ((total (aref *stats* i))
+                               (slow (aref *stats* (1+ i)))
+                               (fast (- total slow)))
+                          (cons total fast)))
+          (append (loop for i from 1 to 15
+                        collect
+                        (let* ((element (aref *stats* i))
+                               (slow (ldb (byte 32 32) element))
+                               (total (ldb (byte 32 0) element))
+                               (fast (- total slow)))
+                          (cons total fast)))
+                  (list (cons (aref *stats* 0) 0)))))
+
+(defun print-consing-stats ()
+  (multiple-value-bind (lists rest-lists) (get-consing-stats)
+    (format t "~&List consing:~%")
+    (let ((sum (reduce #'+ (mapcar 'car lists))))
+      (loop for (count . n-fast) in lists
+            for label across #("1" "2" "3" "4" "5" ">")
+            do (format t " ~A | ~12d ~6,2,2f% ~6,2,2f%~%"
+                       label
+                       count
+                       (/ count sum) ; percentage of total
+                       (cond ((string= label ">") 0)
+                             ((plusp count) (/ n-fast count))))))
+    (format t "~&&REST consing:~%")
+    (let ((sum (reduce #'+ (mapcar 'car rest-lists))))
+      (loop for (count . n-fast) in rest-lists
+            for label across #(" 1" " 2" " 3" " 4" " 5" " 6" " 7" " 8" " 9"
+                               "10" "11" "12" "13" "14" "15" " >")
+            when (plusp count)
+            do (format t "~A | ~12d ~6,2,2f% ~6,2,2f%~%"
+                       label
+                       count
+                       (/ count sum) ; percentage of total
+                       (cond ((string= label " >") 0)
+                             ((plusp count) (/ n-fast count))))))))
+
+(defun sayhello ()
+  (let ((s #.(format nil "Hey there~%")))
+    (sb-sys:with-pinned-objects (s)
+      (alien-funcall (extern-alien "printf" (function void system-area-pointer))
+                     (sb-sys:vector-sap s)))))
+(defun hellothread ()
+  (sb-thread:make-thread #'sayhello))
+
+#|
+(defun allocate-smlgc-cons ()
+  (let ((sap (int-sap (SB-THREAD::THREAD-PRIMITIVE-THREAD sb-thread:*current-thread*))))
+    (setf (sap-ref-32 sap (ash (1+ thread-ap4-slot) word-shift))
+|#

src/code/brothertree.lisp

@@ -347,4 +347,45 @@
               (t node))))
       (unary-node (recurse (child node) best))
       (t best))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(tree-count codeblob-tree-to-list)))
+(defun codeblob-tree-to-list (tree)
+  (let (result)
+    (named-let visit ((node tree))
+      (typecase node
+        (unary-node
+         (visit (child node)))
+        (binary-node
+         (multiple-value-bind (left key right) (binary-node-parts node)
+           (visit right)
+           (push (sb-kernel:%make-lisp-obj (logior key sb-vm:other-pointer-lowtag))
+                 result)
+           (visit left)))))
+    result))
+
+(defun print-codeblob-tree (tree &aux (*print-pretty* nil))
+  (named-let visit ((node tree))
+    (typecase node
+      (unary-node
+       (visit (child node)))
+      (binary-node
+       (multiple-value-bind (left key right) (binary-node-parts node)
+         (visit left)
+         (if (= (sb-sys:sap-ref-8 (sb-sys:int-sap key) 0) sb-vm:code-header-widetag)
+             (let ((obj (sb-kernel:%make-lisp-obj (logior key sb-vm:other-pointer-lowtag))))
+               (format t "~10x ~6x ~a~%" key (primitive-object-size obj) obj))
+             (format t "~10x dead~%" key))
+         (visit right))))))
+
+(defun tree-count (tree)
+  (named-let recurse ((node tree))
+    (typecase node
+      (binary-node
+       (multiple-value-bind (left key right) (binary-node-parts node)
+         (declare (ignore key))
+         (+ 1 (recurse left) (recurse right))))
+      (unary-node (recurse (child node)))
+      (t 0))))
+
 ) ; end PROGN

src/code/cold-init.lisp

@@ -221,6 +221,7 @@
   (setq sb-pcl::*!docstrings* nil) ; needed before any documentation is set
   (setq sb-c::*queued-proclaims* nil) ; needed before any proclaims are run
 
+  (alien-funcall (extern-alien "enable_collector_thread" (function void)))
   (/show0 "calling cold toplevel forms and fixups")
   (let ((*package* *package*)) ; rebind to self, as if by LOAD
     (dolist (toplevel-thing *!cold-toplevels*)
@@ -401,6 +402,7 @@ process to continue normally."
 
 ;;;; initialization functions
 
+(defconstant malloc-object-offset 32)
 (defun reinit (total)
   ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
   (without-gcing
@@ -409,10 +411,26 @@ process to continue normally."
     (when total ; newly started process, and not a failed save attempt
       (sb-thread::init-main-thread)
       #+x86-64 (sb-vm::validate-asm-routine-vector)
+      (do ((mseg (alien-funcall (extern-alien "get_allocated_msegs"
+                                              (function system-area-pointer)))
+                 (sap-ref-sap mseg 0)))
+          ((= (sap-int mseg) 0))
+        (let* ((addr (sap+ mseg malloc-object-offset))
+               (widetag (logand (sap-ref-word addr 0) sb-vm:widetag-mask)))
+          (when (= widetag sb-vm:code-header-widetag)
+            (setf sb-vm::*immobile-codeblob-tree*
+                  (sb-brothertree:insert (sap-int addr) sb-vm::*immobile-codeblob-tree*))
+            #+nil
+            (alien-funcall (extern-alien "printf" (function void system-area-pointer unsigned unsigned unsigned))
+                           (vector-sap #.(format nil "initial mseg @ %p: %lx %lx~%"))
+                           (sap-int addr)
+                           (sap-ref-word addr 0)
+                           (sap-ref-word addr 8)))))
       (rebuild-package-vector))
     ;; Initialize streams next, so that any errors can be printed
     (stream-reinit t)
-    (rebuild-pathname-cache)
+    (alien-funcall (extern-alien "enable_collector_thread" (function void)))
+    ; (rebuild-pathname-cache)
     (os-cold-init-or-reinit)
     #-(and win32 (not sb-thread))
     (signal-cold-init-or-reinit)
@@ -428,7 +446,8 @@ process to continue normally."
     (sb-debug::disable-debugger))
   (call-hooks "initialization" *init-hooks*)
   #+sb-thread (finalizer-thread-start)
-  (sb-vm::!setup-cpu-specific-routines))
+  ;(sb-vm::!setup-cpu-specific-routines)
+  )
 
 ;;;; some support for any hapless wretches who end up debugging cold
 ;;;; init code
@@ -484,3 +503,9 @@ process to continue normally."
     #+sb-show ()
     #-sb-show (/noshow /noshow0 /show /show0))
   *!removable-symbols*)
+
+(defun test-cons-mkay () (cons 1 2))
+(defun test-list-mkay () (list 1 2))
+(defun test-2-vector-mkay () (vector 1 2))
+(defun test-var-vector-mkay (n)
+  (make-array (the integer n)))

src/code/debug-info.lisp

@@ -214,6 +214,7 @@
                         #+unwind-to-frame-and-call-vop bsp-save
                         #-fp-and-pc-standard-save lra-saved-pc
                         #-fp-and-pc-standard-save cfp-saved-pc)
+  (declare (fixnum offset elsewhere-pc form-number))
   (dx-let ((bytes (make-array (* 8 4) :fill-pointer 0
                                       :element-type '(unsigned-byte 8))))
     ;; OFFSET and ELSEWHERE are encoded first so that the C backtrace logic
@@ -480,7 +481,7 @@
                                   (s stream :type t :identity t))))
              (:copier nil))
   ;; the IRT that compilation started at
-  (start-real-time (get-internal-real-time) :type unsigned-byte :read-only t)
+  (start-real-time 42 #|(get-internal-real-time)|# :type unsigned-byte :read-only t)
   ;; the FILE-INFO structure for this compilation
   (file-info nil :type (or file-info null) :read-only t)
   ;; the stream that we are using to read the FILE-INFO, or NIL if

src/code/debug.lisp

@@ -174,7 +174,7 @@ Other commands:
   "Default number of frames to backtrace. Defaults to 1000.")
 
 (declaim (boolean *backtrace-print-pc*))
-(defvar *backtrace-print-pc* nil)
+(defvar *backtrace-print-pc* t)
 (declaim (unsigned-byte *default-argument-limit*))
 (defvar *default-argument-limit* call-arguments-limit)
 

src/code/final.lisp

@@ -237,7 +237,7 @@ Examples:
     ;; Rule out immediate, stack, arena, readonly, and static objects.
     ;; (Is it really an error for a readonly? Maybe a warning? I'll leave it this way unless
     ;; users complain. Surely DX and arena are errors, and NIL was always an error.)
-    (unless (member space '(:dynamic :immobile))
+    (unless (member space '(:dynamic :immobile :bitmapped :large-object))
       (if (eq space :static)
           (error "Cannot finalize ~S." object)
           ;; silently discard finalizers on file streams in arenas I guess
@@ -457,6 +457,7 @@ Examples:
               (setf *finalizer-thread* sb-thread:*current-thread*)
               (loop (run-pending-finalizers)
                     (alien-funcall (extern-alien "finalizer_thread_wait" (function void)))
+                    (sb-vm::release-malloc-segments)
                     (when (zerop finalizer-thread-runflag) (return)))
               (setq *finalizer-thread* nil))
             nil nil)))
@@ -467,6 +468,10 @@ Examples:
 ;;; You should almost always invoke this with *MAKE-THREAD-LOCK* held.
 ;;; Some tests violate that, but they know what they're doing.
 (defun finalizer-thread-stop ()
+  (let ((phase (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-gc-phase-slot))))
+    (when (> phase 1)
+      ;; TODO: figure this out
+      (error "Can not stop finalizer with GC in progress")))
   #+(and unix sb-safepoint)
   (let ((thread sb-unix::*sighandler-thread*))
     (aver (sb-thread::thread-p thread))

src/code/gc.lisp

@@ -299,6 +299,8 @@ trigger a collection of one or more older generations as well. If FULL
 is true, all generations are collected. If GEN is provided, it can be
 used to specify the oldest generation guaranteed to be collected."
   (let ((gen (if full sb-vm:+pseudo-static-generation+ gen)))
+    (when (/= (extern-alien "use_smlgc" int) 0)
+      (return-from gc))
     (when (eq t (sub-gc gen))
       (post-gc))))
 
@@ -527,7 +529,16 @@ Experimental: interface subject to change."
                      :read-only)
                     ((< sb-vm:static-space-start addr
                         (sap-int sb-vm:*static-space-free-pointer*))
-                     :static))))
+                     :static)
+                    ((/= 0 (alien-funcall (extern-alien "in_bitmapped_subheap"
+                                                        (function int unsigned))
+                                          addr))
+                     :bitmapped)
+                    ((/= 0 (alien-funcall (extern-alien "careful_lispobj_stack_slot"
+                                                        (function int unsigned))
+                                          addr))
+                     :large-object))))
+
 ;;; Return true if X is in any non-stack GC-managed space.
 ;;; (Non-stack implies not TLS nor binding stack)
 ;;; There's a microscopic window of time in which next_free_page for dynamic space

src/code/hash-table.lisp

@@ -197,7 +197,8 @@
   (smashed-cells nil)
   ;; This slot is used to link weak hash tables during GC. When the GC
   ;; isn't running it is always NIL.
-  (next-weak-hash-table nil :type null))
+  (next-weak-hash-table nil :type null)
+  (implied-edges-done nil :type null))
 
 (defconstant hash-table-weak-flag         8)
 ;;; USERFUN-FLAG implies a nonstandard hash function. Such tables may also have

src/code/hashset.lisp

@@ -111,6 +111,9 @@
 (defconstant +hashset-unused-cell+ 0)
 (defmacro hs-chain-terminator-p (val) `(eq ,val 0))
 
+#+sb-xc-host
+(defmacro add-weak-object (x) `(progn ,x))
+
 (defun allocate-hashset-storage (capacity weakp)
   (declare (type (unsigned-byte 28) capacity)) ; 256M cells maximum
   (declare (ignorable weakp))
@@ -126,6 +129,8 @@
          (psl-vector (make-array capacity :element-type '(unsigned-byte 8)
                                           :initial-element 0))
          (hash-vector (make-array capacity :element-type '(unsigned-byte 16))))
+    (when weakp
+      (add-weak-object cells))
     (setf (hs-cells-gc-epoch cells) sb-kernel::*gc-epoch*)
     (setf (hs-cells-max-psl cells) 0)
     (setf (hs-cells-n-avail cells) capacity)
@@ -354,6 +359,7 @@
                    (n-live))
                ;; First decide if the table occupancy needs to be recomputed after GC
                (unless (eq (hs-cells-gc-epoch cells) current-epoch)
+                 ;(format t "~&hashset GC epoch changed~%")
                  (setf n-live (hs-cells-occupancy cells capacity)
                        (hs-cells-n-avail cells) (- capacity n-live)
                        (hs-cells-gc-epoch cells) current-epoch))
@@ -568,3 +574,41 @@
   (dotimes (i (weak-vector-len vector))
     (when (eq (weak-vector-ref vector i) key)
       (return key)))))
+
+(defun hashset-probing-sequence (hashset key)
+  (let* ((storage (hashset-storage hashset))
+         (cells (hss-cells storage))
+         (mask (hs-cells-mask cells))
+         (index (logand (funcall (hashset-hash-function hashset) key) mask))
+         (interval 1)
+         (sequence))
+    (loop
+     (push index sequence)
+     (let ((probed-key (hs-cell-ref cells index)))
+       (assert (not (hs-chain-terminator-p probed-key)))
+       (when (and probed-key (funcall (hashset-test-function hashset) probed-key key))
+         (return (nreverse sequence)))
+       (setq index (logand (+ index interval) mask))
+       (incf interval)))))
+#-sb-xc-host
+(defun dump-hashset (hashset)
+  (let* ((storage (hashset-storage hashset))
+         (cells (hss-cells storage))
+         (mutex (hashset-mutex hashset))
+         (held (and mutex (sb-thread:holding-mutex-p mutex)))
+         (maxpsl 0)
+         (n 0))
+    (declare (notinline sb-thread:holding-mutex-p))
+    ;; to avoid recursive lock error. This is for debugging so it doesn't matter
+    (when held (sb-thread:release-mutex mutex))
+    (dotimes (i (hs-cells-capacity cells))
+      (let ((x (hs-cell-ref cells i)))
+        (when (and x (not (hs-chain-terminator-p x)))
+          (let ((seq (hashset-probing-sequence hashset x)))
+            (setq maxpsl (max (length seq) maxpsl))
+            (incf n)
+            (let ((*print-pretty* nil))
+              (format t "[~4d] = ~s ~s~%" i seq x))))))
+    (when held (sb-thread:grab-mutex mutex))
+    (format t ";~&Total entries: ~D, max-psl = ~D (stored=~D)~%"
+            n maxpsl (hs-cells-max-psl cells))))

src/code/macros.lisp

@@ -2334,3 +2334,7 @@ Works on all CASable places."
        (loop (let ((,new (cdr ,old)))
                (when (eq ,old (setf ,old ,cas-form))
                  (return (car (truly-the list ,old)))))))))
+
+(sb-xc:defmacro printf (x)
+  `(alien-funcall (extern-alien "printf" (function void system-area-pointer))
+                  (vector-sap ,(format nil "~A~%" x))))

src/code/room.lisp

@@ -273,6 +273,88 @@
     (multiple-value-bind (start end) (%space-bounds subspace)
       (map-objects-in-range function start end)))))
 
+(define-alien-type nil
+  (struct segment-layout
+          (blocksize-bytes unsigned-int)
+          (bitmap-base (array unsigned-int 4))
+          (bitmap-sentinel (array unsigned-int 3))
+          (stack-offset unsigned-int)
+          (stack-limit unsigned-int)
+          (block-offset unsigned-int)
+          (num-blocks unsigned-int)
+          (block-limit unsigned-int)))
+
+(define-alien-type nil
+  (struct segment
+          (as-list system-area-pointer)
+          (stack system-area-pointer)
+          (block-base system-area-pointer)
+          (snapshot-free system-area-pointer)
+          (layout (* (struct segment-layout)))
+          (blocksize-log2 unsigned-int)
+          (free-count int)))
+
+(defun map-sml#gc-objects (function)
+  (break "don't use this yet")
+  (dx-let ((bounds (make-array 2 :element-type 'word)))
+    (alien-funcall (extern-alien "get_segment_pool_bounds" (function void system-area-pointer))
+                   (vector-sap bounds))
+    (format t "~&Heap range ~x ~x~%" (aref bounds 0) (aref bounds 1))
+    (loop for addr from (aref bounds 0) below (aref bounds 1) by 32768
+          do
+       (let* ((segment (sap-alien (int-sap addr) (* (struct segment))))
+              (obj-addr (slot segment 'block-base))
+              (layout (slot segment 'layout))
+              (blocksize (slot layout 'blocksize-bytes))
+              (num-blocks (slot layout 'num-blocks)))
+         (unless (= (sap-int obj-addr) 0)
+           (do ((i 0 (1+ i))
+                (obj-addr obj-addr (sap+ obj-addr blocksize)))
+               ((= i num-blocks))
+             (let* ((word (sap-ref-word obj-addr 0))
+                    (widetag (logand word widetag-mask)))
+               (unless (= word #xffffffffdeadbeef)
+                 (funcall function
+                          (lispobj@baseptr obj-addr widetag)
+                          segment)))))))))
+
+#+nil
+(defun collect-weak-objects ()
+  (nconc (collect ((result))
+           (map-sml#gc-objects
+            (lambda (x segment)
+              (declare (ignore segment))
+              (when (weak-pointer-p x)
+                (result x))))
+           (result))
+         (sb-vm:list-allocated-objects
+          :dynamic
+          :type sb-vm:weak-pointer-widetag)))
+
+(defun check-oversized ()
+  (map-sml#gc-objects
+   (lambda (object segment)
+     (let* ((log2size (slot segment 'blocksize-log2))
+            (blocksize (ash 1 log2size))
+            (actual-size (primitive-object-size object))
+            (smaller-size (ash blocksize -1)))
+       (when (<= actual-size smaller-size)
+         (format t "~&object @ ~x ~s could have fit in smaller block~%"
+                 (get-lisp-obj-address object)
+                 (type-of object)))))))
+
+(defun show-sml#gc-heap-objects (&aux prev-seg)
+  (map-sml#gc-objects
+   (lambda (x segment)
+     (unless (eq segment prev-seg)
+       (format t "-- segment @ ~x blocksize ~d --~%"
+               (sap-int (alien-sap segment))
+               (slot (slot segment 'layout) 'blocksize-bytes))
+       (setq prev-seg segment))
+     (format t " ~x: ~A~%"
+             (get-lisp-obj-address x)
+             (type-of x)))))
+
 #|
 MAP-ALLOCATED-OBJECTS is fundamentally unsafe to use if the user-supplied
 function allocates anything. Consider what can happens when NEXT-FREE-PAGE

src/code/share-vm.lisp

@@ -231,7 +231,7 @@
                      (min 16 (ash (primitive-object-size thing) (- word-shift))))))))
       ;; For all objects except lists, there is 1 iteration showing NWORDS.
       ;; Lists iterate up to COUNT times showing 2 words each time.
-      (dotimes (iteration (if (and (consp thing) countp) count 1))
+      (dotimes (n-iterations (if (and (consp thing) countp) count 1))
         (dotimes (i nwords)
           (let ((word (sap-ref-word (int-sap addr) (ash i word-shift))))
             (multiple-value-bind (lispobj ok fmt)

src/code/simple-fun.lisp

@@ -420,6 +420,21 @@
   (declare (type code-component code-obj))
   (ash (code-fun-table-count code-obj) -5))
 
+(defun code-pseudo-atomic-locations (code-obj)
+  (declare (type code-component code-obj))
+  (let ((n-simple-funs (code-n-entries code-obj)))
+    (when (plusp n-simple-funs)
+      (let* ((trailer-index (truly-the fixnum (- (ash (+ n-simple-funs 2) 2))))
+             (count (code-trailer-ref code-obj trailer-index)))
+        (when (plusp count)
+          (let ((v (make-array count :element-type '(unsigned-byte 32))))
+            (dotimes (i count)
+              (setf (aref v (decf count))
+                    (code-trailer-ref code-obj
+                                      (truly-the fixnum (decf trailer-index 4)))))
+            (return-from code-pseudo-atomic-locations v))))))
+  #.(sb-xc:make-array 0 :element-type '(unsigned-byte 32)))
+
 ;;; Start and count of fdefns used in #'F synax or normal named call
 ;;; (i.e. at the head of an expression)
 (defun code-header-fdefn-range (code-obj)

src/code/solist.lisp

@@ -232,6 +232,12 @@
              ;; and pick an appropriate way to atomically update the node.
              (aver (typep node 'so-key-node)))
             ((> (atomic-incf (so-count table)) (so-threshold table))
+             #+nil
+             (sb-alien:alien-funcall
+              (sb-alien:extern-alien "printf" (function sb-alien:void system-area-pointer sb-alien:int sb-alien:int))
+              (vector-sap #.(format nil "so-insert: Threshold reached %d %d~%"))
+              (so-count table)
+              (so-threshold table))
              (so-expand-bins table bins)))
       (values node foundp))))
 
@@ -370,6 +376,7 @@
   (defun make-so-set/string () (make nil))
   (defun make-so-map/string () (make t)))
 
+(declaim (ftype (sfunction () t) make-so-set/addr))
 (flet ((make (valuesp)
          (%make-so-list (lambda (x) (multiplicative-hash (get-lisp-obj-address x)))
                         #'%so-put/addr #'%so-delete/addr #'so-find/addr
@@ -377,39 +384,55 @@
   (defun make-so-set/addr () (make nil))
   (defun make-so-map/addr () (make t)))
 
+(macrolet ((with-start-node ((node) &body body)
+             `(let* ((hash (masked-hash (multiplicative-hash (get-lisp-obj-address key))))
+                     (bins (so-bins (truly-the split-ordered-list table)))
+                     (shift (bin-shift bins))
+                     (bin-vector (car bins))
+                     (index (ash hash (- shift)))
+                     (,node (svref bin-vector index)))
+                (when (unbound-marker-p ,node)
+                  ;; Pick any nonempty bin to the left of the intended bin.
+                  ;; It's always OK to pick a suboptimal start bin, because there is no requirement
+                  ;; to observe the BINS vector in the most up-to-date state anyway.
+                  (setf ,node (find-if-not #'unbound-marker-p bin-vector
+                                           :end index :from-end t)))
+                #+sb-devel (aver (dummy-node-p ,node))
+                ,@body)))
+;;; Like SO-FIND/ADDR but never initializing a bin
+(defun %so-eq-set-find (table key)
+  (with-start-node (start-node)
+    (let ((node (%so-search/addr start-node hash key)))
+      (unless (or (endp node) (dummy-node-p node) (neq (so-key node) key))
+        node))))
+;;; Like SO-DELETE but never initializing a bin
+(defun %so-eq-set-delete (table key)
+  (with-start-node (start-node)
+    (let ((deleted (%so-delete/addr start-node hash key)))
+      (when deleted (atomic-decf (so-count table)))
+      deleted)))
+
 ;;; This special case can be used during allocation of new objects (and usually only then).
 ;;; The address can not have previously existed in the table since it is fresh.
 ;;; Additionally, this takes a pre-allocated NODE, does not perform INITIALIZE-BIN,
 ;;; and does not increment the occupancy count. The latter two steps can be performed later.
 ;;; This can be run within a pseudo-atomic section, and the next step outside of it.
 (defun %so-eq-set-phase1-insert (table node key)
-  (let* ((hash (masked-hash (multiplicative-hash (get-lisp-obj-address key))))
+  (let ((node (truly-the so-key-node node)))
-         (bins (so-bins (truly-the split-ordered-list table)))
+    (with-start-node (start-node)
-         (shift (bin-shift bins))
+      (aver (and (eq (%instance-layout node) #.(find-layout 'so-key-node))
-         (bin-vector (car bins))
+                 (eq key (%instance-ref node (get-dsd-index so-key-node so-key)))
-         (index (ash hash (- shift)))
+                 (eq hash (%instance-ref node (get-dsd-index so-node node-hash)))))
-         (start-node (svref bin-vector index)))
+      (loop
-    ;; HASH and KEY of a node are not accessible as read/write slots to clients
+        (multiple-value-bind (right left) (%so-search/addr start-node hash key)
-    ;; of the table, but _can_ be written by this insert function only in as much as
+          #+sb-devel
-    ;; the caller has to preallocate the node, and we have to fill it in here.
+          (when (and (not (endp right)) (not (dummy-node-p right)))
-    (setf (%instance-ref (truly-the instance node) (get-dsd-index so-node node-hash)) hash
+            ;; The successor had better not be the droid you're looking for.
-          (%instance-ref node (get-dsd-index so-key-node so-key)) key)
+            (aver (neq key (so-key right))))
-    (when (unbound-marker-p start-node)
+          (setf (%node-next node) right)
-      ;; Pick any nonempty bin to the left of the intended bin.
+          (when (eq (cas (%node-next left) right node) right)
-      ;; It's always OK to pick a suboptimal start bin, because there is no requirement
+            (return node)))))))
-      ;; to observe the BINS vector in the most up-to-date state anyway.
+) ; end MACROLET
-      (setf start-node (find-if-not #'unbound-marker-p bin-vector
-                                    :end index :from-end t)))
-    #+sb-devel (aver (dummy-node-p start-node))
-    (loop
-     (multiple-value-bind (right left) (%so-search/addr start-node hash key)
-       #+sb-devel
-       (when (and (not (endp right)) (not (dummy-node-p right)))
-         ;; The successor had better not be the droid you're looking for.
-         (aver (neq key (so-key right))))
-       (setf (%node-next node) right)
-       (when (eq (cas (%node-next left) right node) right)
-         (return t))))))
 
 ;;; Complete the insertion of a previously-known-not-to-exist key.
 (defun %so-eq-set-phase2-insert (table node)
@@ -417,6 +440,13 @@
     (declare (ignore hash start-node))
     (when (> (atomic-incf (so-count table)) (so-threshold table))
       (so-expand-bins table bins)))
+  #+nil
+  (let* ((addr (ash (sb-lockless:so-key node) 1))
+         (obj (sb-kernel:%make-lisp-obj (logior addr sb-vm:other-pointer-lowtag)))
+         (nbytes (sb-ext:primitive-object-size obj))
+         (msg (format nil "new large obj @ ~x .. ~x~%" addr (+ addr nbytes))))
+    (sb-sys:with-pinned-objects (msg)
+      (sb-unix:unix-write 2 msg 0 (length msg))))
   node)
 
 (defun c-so-find/addr (solist key)
@@ -438,3 +468,30 @@
           ;; Would it better for tests to close the region? Maybe,
           ;; but we can't count on everybody doing that.
           (%make-lisp-obj (logior result sb-vm:instance-pointer-lowtag)))))))
+
+(defun show-address-based-list (hashset &optional (sort :hash))
+  (declare (type (member :address :hash) sort))
+  (without-gcing
+   (collect ((items))
+     (let ((node (so-head hashset)))
+       (loop (when (endp node) (return))
+             (when (so-key-node-p node)
+               (let* ((sap (descriptor-sap (so-key node)))
+                      (widetag #+little-endian (sap-ref-8 sap 0))
+                      (lowtag
+                       (case widetag
+                         (#.sb-vm:instance-widetag sb-vm:instance-pointer-lowtag)
+                         ((#.sb-vm:funcallable-instance-widetag
+                           #.sb-vm:closure-widetag) sb-vm:fun-pointer-lowtag)
+                         (t sb-vm:other-pointer-lowtag)))
+                      (key (%make-lisp-obj (logior (sap-int sap) lowtag))))
+                 (items
+                  (list (get-lisp-obj-address node) (node-hash node)
+                        (sap-int sap)
+                        (sb-ext:primitive-object-size key) (type-of key)))))
+             (setq node (get-next node))))
+     (let ((list (if (eq sort :hash)
+                     (items)
+                     (sort (items) #'< :key #'third))))
+       (let ((*print-pretty* nil))
+         (format t "~:{~x  ~16,'0x ~16x ~6x ~s~%~}" list))))))

src/code/target-hash-table.lisp

@@ -629,6 +629,7 @@ Examples:
                                                   sb-vm:vector-weak-flag)))))
       (when (logtest flags hash-table-synchronized-flag)
         (install-hash-table-lock table))
+      (when weakp (add-weak-object table))
       table))
 
 ;;; a "plain" hash-table has nothing fancy: default size, default growth rate,
@@ -1503,6 +1504,18 @@ nnnn 1_    any       linear scan (don't try to read when rehash already in progr
            ;; are no concurrent readers to potentially mess up the chains.
            (hash-search)))))))
 
+(defmacro with-global-rwlock (&body body)
+  `(with-alien ((rwlock  (array unsigned 1) :extern "weakTableLock"))
+     (unwind-protect
+          (progn
+            ;; This lock makes GC's mark phase termination simpler.
+            ;; It seems feasible to eliminate the lock if reading, perhaps.
+            (alien-funcall (extern-alien "pthread_rwlock_rdlock" (function int system-area-pointer))
+                           (alien-sap rwlock))
+            ,@body)
+       (alien-funcall (extern-alien "pthread_rwlock_unlock" (function int system-area-pointer))
+                      (alien-sap rwlock)))))
+
 (defmacro with-weak-hash-table-entry (&body body)
   `(with-pinned-objects (key)
      (binding* (((hash0 address-sensitive-p)
@@ -1517,16 +1530,17 @@ nnnn 1_    any       linear scan (don't try to read when rehash already in progr
                               (kv-vector (hash-table-pairs hash-table)))
                      (declare (index physical-index))
                      ,@body)))
-       ;; It would be ideal if we were consistent about all tables NOT having
+         (with-global-rwlock
-       ;; synchronization unless created with ":SYNCHRONIZED T"
+              ;; It would be ideal if we were consistent about all tables NOT having
-       ;; but it looks tricky to support concurrent gethash on weak tables,
+              ;; synchronization unless created with ":SYNCHRONIZED T"
-       ;; so we mostly default to locking, except where there is an outer scope
+              ;; but it looks tricky to support concurrent gethash on weak tables,
-       ;; providing mutual exclusion such as WITH-FINALIZER-STORE.
+              ;; so we mostly default to locking, except where there is an outer scope
-       (if (hash-table-synchronized-p hash-table)
+              ;; providing mutual exclusion such as WITH-FINALIZER-STORE.
-           ;; Use the private slot accessor for the lock because it's known
+              (if (hash-table-synchronized-p hash-table)
-           ;; to have a mutex.
+                  ;; Use the private slot accessor for the lock because it's known
-           (sb-thread::call-with-recursive-system-lock #'body (hash-table-%lock hash-table))
+                  ;; to have a mutex.
-           (body))))))
+                  (sb-thread::call-with-recursive-system-lock #'body (hash-table-%lock hash-table))
+                  (body)))))))
 
 (defun gethash/weak (key hash-table default)
   (declare (type hash-table hash-table) (optimize speed))
@@ -2018,9 +2032,15 @@ table itself."
                     (setf (hash-table-smashed-cells hash-table) nil))
                   (setf (hash-table-next-free-kv hash-table) 1
                         (kv-vector-high-water-mark kv-vector) 0))))
-      (if (hash-table-synchronized-p hash-table)
+      ;; Silly me, this should be the CLRHASH-IMPL function for weak tables, no?
-          (sb-thread::call-with-recursive-system-lock #'clear (hash-table-%lock hash-table))
+      (cond ((and (hash-table-weak-p hash-table) (/= (extern-alien "use_smlgc" int) 0))
-          (clear))))
+             ;; FIXME: this could be done without the deletion barrier or weakTableLock
+             ;; by just allocating a new pair vector instead of reusing the current one.
+             (with-global-rwlock
+                 (sb-thread::call-with-recursive-system-lock #'clear (hash-table-%lock hash-table))))
+            ((hash-table-synchronized-p hash-table)
+             (sb-thread::call-with-recursive-system-lock #'clear (hash-table-%lock hash-table)))
+            (t (clear)))))
   hash-table)
 
 

src/code/target-package.lisp

@@ -2190,6 +2190,7 @@ PACKAGE."
                   (let* ((string (car cell))
                          (pkg (,sub-finder string))
                          (new (sb-c::allocate-weak-vector 3)))
+                    (add-weak-object new)
                     (setf (weak-vector-ref new 0) *package-names-cookie*
                           (weak-vector-ref new 1) (info-gethash string (car *package-nickname-ids*))
                           (weak-vector-ref new 2) pkg)

src/code/target-random.lisp

@@ -275,6 +275,7 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
                   (ash y -1) (aref state (logand y 1)))))
   (values))
 
+#+nil
 (declaim (start-block random %random-single-float %random-double-float
                       random-chunk big-random-chunk))
 

src/code/weak.lisp

@@ -48,6 +48,12 @@
   (and (simple-vector-p x)
        (test-header-data-bit x (ash sb-vm:vector-weak-flag sb-vm:array-flags-data-position))))
 
+
+(defun add-weak-object (x)
+  (alien-funcall (extern-alien "record_weak_object" (function void unsigned))
+                 (get-lisp-obj-address x))
+  x)
+
 (defun make-weak-vector (length &key (initial-contents nil contents-p)
                                      (initial-element nil element-p))
   (declare (index length))
@@ -62,6 +68,7 @@
         (error "~S has ~D elements, vector length is ~D."
                :initial-contents contents-length length))))
   (let ((v (sb-c::allocate-weak-vector length)))
+    (add-weak-object v)
     (if initial-contents
         (dotimes (i length)
           (setf (weak-vector-ref v i) (elt initial-contents i)))
@@ -71,7 +78,10 @@
     v))
 (defun make-weak-pointer (object)
   "Allocate and return a weak pointer which points to OBJECT."
-  (make-weak-pointer object))
+  (let ((wp (sb-vm::%make-weak-pointer object)))
+    (when (sb-vm:is-lisp-pointer (get-lisp-obj-address object))
+      (add-weak-object wp))
+    wp))
 
 (declaim (inline weak-pointer-value))
 (defun weak-pointer-value (weak-pointer)
@@ -79,7 +89,7 @@
 If the referent of WEAK-POINTER has been garbage collected,
 returns the values NIL and NIL."
   (declare (type weak-pointer weak-pointer))
-  (let ((value (sb-vm::%weak-pointer-value weak-pointer)))
+  (let ((value (%primitive sb-vm::%weak-pointer-value weak-pointer)))
     (if (sb-vm::unbound-marker-p value)
         (values nil nil)
         (values value t))))

src/cold/build-order.lisp-expr

@@ -328,6 +328,7 @@
  ("src/code/float"           :not-host)
  ("src/code/irrat"           :not-host)
 
+ ("src/code/share-vm" :not-host)
  ("src/code/alloc"           :not-host) ; for ALLOCATE-SYSTEM-MEMORY in make-buffer
  ("src/code/fd-stream"       :not-host)
  ("src/code/target-char"     :not-host)
@@ -492,8 +493,6 @@
  #+haiku ("src/code/haiku-os" :not-host)
  #+win32 ("src/code/win32-os" :not-host)
 
- ("src/code/share-vm" :not-host)
-
  #+sparc ("src/code/sparc-vm" :not-host)
  #+x86   ("src/code/x86-vm"   :not-host)
  #+x86-64("src/code/x86-64-vm"   :not-host)

src/cold/exports.lisp

@@ -2936,7 +2936,8 @@ the stuff in here originated in CMU CL's EXTENSIONS package and is retained,
 possibly temporarily, because it might be used internally.")
   (:use "CL" "SB-ALIEN" "SB-GRAY" "SB-FASL" "SB-SYS")
   (:export ;; lambda list keyword extensions
-           "&MORE"
+   "&MORE"
+   "PRINTF"
 
             ;; utilities for floating point zero handling
 
@@ -3608,6 +3609,7 @@ package is deprecated in favour of SB-MOP.")
            "MAKE-SO-MAP/STRING" "MAKE-SO-MAP/FIXNUM" "MAKE-SO-MAP/ADDR"
            "MULTIPLICATIVE-HASH"
            "%SO-EQ-SET-PHASE1-INSERT" "%SO-EQ-SET-PHASE2-INSERT"
+           "%SO-EQ-SET-FIND" "%SO-EQ-SET-DELETE"
            "SO-INSERT" "SO-DELETE" "SO-FIND"
            "C-SO-FIND/ADDR"
            "SO-KEY" "SO-DATA" "SO-MAPLIST")

src/compiler/assem.lisp

@@ -319,6 +319,11 @@
   ;; into the data section
   (constant-table (make-hash-table :test #'equal) :read-only t)
   (constant-vector (make-array 16 :adjustable t :fill-pointer 0) :read-only t)
+  ;; for collecting barrier locations to be stored within the code trailer.
+  ;; This facilitates a program-counter-based pseudo-atomic wherein the signal
+  ;; handler see that it wants to stop within an uninterruptible sequence,
+  ;; and can choose to rollback or roll forward.
+  (pseudo-atomic-locs)
   ;; for deterministic allocation profiler (or possibly other tooling)
   ;; that wants to monkey patch the instructions at runtime.
   (alloc-points)
@@ -1448,6 +1453,7 @@
     (setf (section-tail first) last-stmt))
   first)
 
+;(defvar *cur-stmt* nil)
 ;;; Combine INPUTS into one assembly stream and assemble into SEGMENT
 (defun %assemble (segment section)
   (let ((*current-vop* nil)
@@ -1475,6 +1481,7 @@
       (dump-symbolic-asm section sb-c::*compiler-trace-output*))
     (do ((statement (stmt-next (section-start section)) (stmt-next statement)))
         ((null statement))
+;      (setq *cur-stmt* statement)
       (awhen (stmt-vop statement) (setq *current-vop* it))
       (dolist (label (ensure-list (stmt-labels statement)))
         (%emit-label segment *current-vop* label))
@@ -1510,7 +1517,11 @@
 ;;; The interface to %ASSEMBLE
 (defun assemble-sections (asmstream simple-fun-labels segment)
   (let* ((n-entries (length simple-fun-labels))
-         (trailer-len (* (+ n-entries 1) 4))
+         (fun-offsets-len (* (1+ n-entries) 4))
+         ;; Each pseudoatomic location is stored as a 4-byte quantity.
+         (n-pseudo-atomic-locs (length (asmstream-pseudo-atomic-locs asmstream)))
+         (trailer-len (+ (* (1+ n-pseudo-atomic-locs) 4)
+                         fun-offsets-len))
          (end-text (gen-label))
          (combined
            (append-sections
@@ -1544,7 +1555,6 @@
                            0
                            (- index trailer-len (label-position end-text)))))
           (unless (and (typep trailer-len '(unsigned-byte 16))
-                       (typep n-entries '(unsigned-byte 12))
                        ;; Padding must be representable in 4 bits at assembly time,
                        ;; but CODE-HEADER/TRAILER-ADJUST can increase the padding.
                        (typep padding '(unsigned-byte 4)))
@@ -1552,6 +1562,13 @@
           (setf (sap-ref-16 sap (- index 2)) trailer-len)
           (setf (sap-ref-16 sap (- index 4)) (logior (ash n-entries 5) padding)))
         (decf index trailer-len)
+        (dolist (label (sort (asmstream-pseudo-atomic-locs asmstream) #'<
+                             :key #'label-posn))
+          (setf (sap-ref-32 sap index) (label-posn label))
+          (incf index 4))
+        (setf (sap-ref-32 sap index) n-pseudo-atomic-locs)
+        (incf index 4)
+        (aver (= index (- (length octets) fun-offsets-len)))
         ;; Iteration over label positions occurs from numerically highest
         ;; to lowest, which is right because the 0th indexed simple-fun
         ;; has the lowest entry offset, and is the last one written
@@ -1563,8 +1580,8 @@
           (let ((val (label-position label)))
             (push val fun-offsets)
             (setf (sap-ref-32 sap index) val)
-            (incf index 4)))))
+            (incf index 4)))
-    (aver (= index (- (length octets) 4)))
+        (aver (= index (- (length octets) 4)))))
     (values segment
             (label-position end-text)
             (segment-fixup-notes segment)

src/compiler/codegen.lisp

@@ -21,7 +21,7 @@
 ;;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that.
 (defun asm-routines-boxed-header-nwords ()
   (align-up (+ sb-vm:code-constants-offset
-               #+x86-64 1) ; KLUDGE: make room for 1 boxed constant
+               #+x86-64 2) ; KLUDGE: make room for 1 boxed constant
             2))
 ;;; the number of bytes used by the code object header
 (defun component-header-length ()

src/compiler/early-assem.lisp

@@ -41,6 +41,7 @@
 (eval-when (:compile-toplevel #-sb-xc :load-toplevel :execute)
 (#-sb-xc defmacro #+sb-xc sb-xc:defmacro sb-vm::define-assembly-routine
     (name&options vars &body code)
+(let ((expansion
   (multiple-value-bind (name options)
       (if (atom name&options)
           (values name&options nil)
@@ -50,3 +51,8 @@
       (if (member :sb-assembling sb-xc:*features*)
           (sb-c::emit-assemble name options regs code)
           (sb-c::emit-assemble-vop name options regs))))))
+  #+nil
+  (let ((*print-level* nil)(*print-length* nil))
+  (format t "DEFINE-ASM-ROUTINE ~S ~S ->~%~S~%" (car (ensure-list name&options)) (if (member :sb-assembling sb-xc:*features*) "assembling" "compiling")
+          expansion))
+  expansion)))

src/compiler/generic/genesis.lisp

@@ -1924,7 +1924,9 @@ core and return a descriptor to it."
              (desired (sb-vm:static-fun-offset sym)))
         (unless (= offset desired)
           (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
-                 sym nil offset desired))))))
+                 sym nil offset desired)))))
+  (let ((v (word-vector (make-list 200 :initial-element 0) *static*)))
+    (format t "data collection vector @ ~x~%" (descriptor-bits v))))
 
 ;;; Sort *COLD-LAYOUTS* to return them in a deterministic order.
 (defun sort-cold-layouts ()
@@ -1933,6 +1935,7 @@ core and return a descriptor to it."
 
 ;;; Establish initial values for magic symbols.
 ;;;
+(defvar *cold-assembler-obj*) ; a single code component
 (defun finish-symbols ()
   (cold-set 'sb-kernel::*!initial-layouts*
             (vector-in-core

src/compiler/generic/objdef.lisp

@@ -319,8 +319,8 @@ during backtrace.
 (define-primitive-object (weak-pointer :type weak-pointer
                                        :lowtag other-pointer-lowtag
                                        :widetag weak-pointer-widetag
-                                       :alloc-trans make-weak-pointer)
+                                       :alloc-trans %make-weak-pointer)
-  (value :ref-trans %weak-pointer-value :ref-known (flushable)
+  (value #|:ref-trans %weak-pointer-value :ref-known (flushable)|#
          :init :arg)
   ;; 64-bit uses spare header bytes to store the 'next' link
   #-64-bit (next :c-type "struct weak_pointer *"))
@@ -483,7 +483,11 @@ during backtrace.
 (defconstant-eqx +thread-header-slot-names+
     `#(#+x86-64
        ,@'(t-nil-constants
+           stepping
            alien-linkage-table-base
+           ;allocptr16 ; for sml#gc
+           ;allocptr32
+           ;allocptr64
            msan-xor-constant
            ;; The following slot's existence must NOT be conditional on #+msan
            msan-param-tls) ; = &__msan_param_tls
@@ -525,7 +529,8 @@ during backtrace.
   ;; of a symbol is initialized to zero
   (no-tls-value-marker)
 
-  (stepping)
+  #-x86-64 (stepping)
+  (gc-phase :c-type "_Atomic(unsigned int)")
 
   ;; Keep this first bunch of slots from binding-stack-pointer through alloc-region
   ;; near the beginning of the structure so that x86[-64] assembly code
@@ -546,13 +551,36 @@ during backtrace.
                       :c-type "pa_bits_t")
   (alien-stack-pointer :c-type "lispobj *" :pointer t
                        :special *alien-stack-pointer*)
+
+  (ap4  :c-type "struct alloc_ptr" :length 4)
+  (ap5  :c-type "struct alloc_ptr" :length 4)
+  (ap6  :c-type "struct alloc_ptr" :length 4)
+  (ap7  :c-type "struct alloc_ptr" :length 4)
+  (ap8  :c-type "struct alloc_ptr" :length 4)
+  (ap9  :c-type "struct alloc_ptr" :length 4)
+  (ap10 :c-type "struct alloc_ptr" :length 4)
+  (ap11 :c-type "struct alloc_ptr" :length 4)
+  (ap12 :c-type "struct alloc_ptr" :length 4)
+
+  ;; Thread-local allocation buffers
+  ;(boxed-tlab :c-type "struct alloc_region" :length 3)
+  ;(cons-ap :c-type "struct alloc_ptr" :length 4)
+
   ;; Deterministic consing profile recording area.
   (profile-data :c-type "uword_t *" :pointer t)
-  ;; Thread-local allocation buffers
+  ;; END of slots to keep near the beginning.
-  (boxed-tlab :c-type "struct alloc_region" :length 3)
+
+  ;; allocation pointers by block size
+  ;; todo: allocptr48
+;  (allocptr128)
+;  (allocptr256)
+;  (allocptr512)
+;  (allocptr1024)
+;  (allocptr2048)
+;  (allocptr4096)
+
   (cons-tlab :c-type "struct alloc_region" :length 3)
   (mixed-tlab :c-type "struct alloc_region" :length 3)
-  ;; END of slots to keep near the beginning.
 
   ;; This is the original address at which the memory was allocated,
   ;; which may have different alignment then what we prefer to use.
@@ -571,7 +599,9 @@ during backtrace.
   (os-thread :c-type #+(or win32 (not sb-thread)) "lispobj" ; actually is HANDLE
                      #-(or win32 (not sb-thread)) "pthread_t")
   (os-kernel-tid) ; the kernel's thread identifier, 32 bits on linux
-
+  ;; a small integer identifier starting from 1 for the first thread.
+  ;; These are never recycled (but could wraparound in theory)
+  (serialno)
   ;; These aren't accessed (much) from Lisp, so don't really care
   ;; if it takes a 4-byte displacement.
   (alien-stack-start :c-type "lispobj *" :pointer t)
@@ -619,6 +649,13 @@ during backtrace.
   (symbol-tlab :c-type "struct alloc_region" :length 3)
   (sys-mixed-tlab :c-type "struct alloc_region" :length 3)
   (sys-cons-tlab :c-type "struct alloc_region" :length 3)
+  ;; When the allocator fallback routine calls into C, it saves the stack pointer
+  ;; in this slot, so that we don't need to scan everything above the current stack
+  ;; pointer as it exists upon entry to C, if GC decides to run at that time.
+  ;; This avoids scanning the approximately 100 words comprising the floating-point save
+  ;; area.  Because allocation is pseudo-atomic (i.e. nonreentrant), there is no chance
+  ;; that two different allocation requests try to use this slot.
+  (stack-root-scan-start)
   ;; allocation instrumenting
   (tot-bytes-alloc-boxed)
   (tot-bytes-alloc-unboxed)
@@ -632,6 +669,12 @@ during backtrace.
                        :length #.(+ (* 2 n-histogram-bins-large)
                                     n-histogram-bins-small))
 
+  (ct-new-objects)
+  (ct-stack-obj-stores)
+  (ct-heap-obj-stores)
+  (ct-store-barriers)
+  (ct-spinlock-yields)
+
   ;; The *current-thread* MUST be the last slot in the C thread structure.
   ;; It it the only slot that needs to be noticed by the garbage collector.
   (lisp-thread :pointer t :special sb-thread:*current-thread*))
@@ -764,3 +807,38 @@ during backtrace.
   (+ static-space-objects-offset
      (* (length +static-symbols+) (ash (align-up symbol-size 2) word-shift))
      instance-pointer-lowtag))
+
+;(sb-ext:define-load-time-global *use-smlgc* 0)
+;(sb-ext:define-load-time-global *testroot* 0)
+;(declaim (fixnum *use-smlgc*))
+;(defun type-to-bit (type)
+;  (cond ((or (typep type 'sb-kernel:defstruct-description)
+;             (eql type instance-widetag))
+;         0)
+;        ((and (numberp type) (>= type 128)) 1)
+;        (t
+;         (let ((pos
+;                 (position type
+;                           `(,bignum-widetag
+;                             ,list-pointer-lowtag
+;                             ,funcallable-instance-widetag
+;                             ,double-float-widetag ,ratio-widetag
+;                             ,weak-pointer-widetag
+;                             ,complex-single-float-widetag
+;                             ,complex-double-float-widetag
+;                             ,complex-widetag
+;                             ,sap-widetag ,symbol-widetag
+;                             ,closure-widetag
+;                             ,code-header-widetag
+;                             ,simple-vector-widetag
+;                             ,value-cell-widetag
+;                             ,simd-pack-widetag ,simd-pack-256-widetag ,fdefn-widetag
+;                             vector
+;                             :cons1 :cons2 :cons3+ :&rest :make-list :unknown-type :variable
+;                             ))))
+;           (if pos (+ pos 2))))))
+;
+;(defun use-smlgc (&rest types)
+;  (setf sb-vm::*use-smlgc*
+;        (reduce #'+ (mapcar (lambda (x) (ash 1 (type-to-bit x)))
+;                            types))))

src/compiler/generic/parms.lisp

@@ -163,6 +163,9 @@
   '(sub-gc
     sb-kernel::post-gc
     internal-error
+    largeobj-hs-insert
+    largeobj-hs-maybe-rehash
+    release-malloc-segments
     sb-kernel::control-stack-exhausted-error
     sb-kernel::binding-stack-exhausted-error
     sb-kernel::alien-stack-exhausted-error
@@ -213,6 +216,9 @@
     ;; never the symbol-value slot
     #-sb-thread ,@(mapcar (lambda (x) (car (ensure-list x)))
                            per-thread-c-interface-symbols)
+    bitmap-heap-base
+    bitmap-heap-size
+
     ;; NLX variables are thread slots on x86-64 and RISC-V.  A static sym is needed
     ;; for arm64, ppc, and x86 because we haven't implemented TLS index fixups,
     ;; so must lookup the TLS index given the symbol.
@@ -413,5 +419,15 @@
 (defconstant double-float-digits 53)
 )
 
+;;; see smlsharp.h
+(defconstant gc-phase-async 1)
+(defconstant gc-phase-sync1 3)
+(defconstant gc-phase-sync2 5)
+(defconstant gc-phase-mark  7)
+(defconstant smlgc-blocksize-max 4096)
+;; an "mseg" wraps a malloc()'ed memory block. In addition to any malloc
+;; overhead there is some GC overhead on top of that.
+(defconstant smlgc-mseg-overhead-bytes 32)
+
 (push '("SB-VM" +c-callable-fdefns+ +common-static-symbols+)
       *!removable-symbols*)

src/compiler/generic/utils.lisp

@@ -94,6 +94,13 @@
   (+ (static-fdefn-offset name)
      (- other-pointer-lowtag)
      (* fdefn-raw-addr-slot n-word-bytes)))
+
+(export 'static-data-collection-vector)
+(defun static-data-collection-vector ()
+  (+ nil-value
+     (static-fdefn-offset (elt +static-fdefns+
+                               (1- (length +static-fdefns+))))
+     (ash fdefn-size word-shift)))
 
 
 ;;;; interfaces to IR2 conversion
@@ -318,6 +325,25 @@
           (return-from stack-consed-p t)))))
   nil)
 
+(defun slot-type-requires-gcbarrier (obj-ref index)
+  #-compact-instance-header
+  (when (eql index 0) ; layout is index 0 (physical word 1)
+    (return-from slot-type-requires-gcbarrier t))
+  (let ((obj-type (tn-ref-type obj-ref)))
+    (when (structure-classoid-p obj-type)
+      (when (and (csubtypep obj-type (specifier-type 'sb-lockless::list-node))
+                 (eq index instance-data-start))
+        (return-from slot-type-requires-gcbarrier :untagged))
+      (let* ((dd (layout-dd (classoid-layout obj-type)))
+             (slot (find index (dd-slots dd) :key #'dsd-index)))
+        (unless slot ; constant index may access slots beyond the defined slots
+          (return-from slot-type-requires-gcbarrier t))
+        (let ((slot-type (specifier-type (dsd-type slot))))
+          (when (csubtypep slot-type (specifier-type
+                                      '(or boolean fixnum character #+64-bit single-float)))
+            (return-from slot-type-requires-gcbarrier nil))))))
+  t)
+
 ;;; Just gathering some data to see where we can improve
 (define-load-time-global *store-barriers-potentially-emitted* 0)
 (define-load-time-global *store-barriers-emitted* 0)

src/compiler/generic/vm-fndb.lisp

@@ -318,7 +318,7 @@
 
 (defknown make-array-header* (&rest t) array (flushable movable))
 
-(defknown make-weak-pointer (t) weak-pointer
+(defknown (make-weak-pointer sb-vm::%make-weak-pointer) (t) weak-pointer
   (flushable))
 
 ;; This used to have a :derive-type but it can't now. Even though a weak vector
@@ -681,6 +681,9 @@
 ;;; The index should be strictly negative and a multiple of 4.
 (defknown code-trailer-ref (code-component fixnum) (unsigned-byte 32)
   (flushable #-(or sparc ppc64) always-translatable))
+;; knownfun and vop not needed post-build, so name using #\! convention.
+;; Takes header word and malloc-segment pointer
+(defknown sb-vm::!manage-large-codeblob (sb-vm:word system-area-pointer) code-component ())
 
 (defknown %fun-pointer-widetag (function) (member . #.sb-vm::+function-widetags+)
   (flushable))

src/compiler/generic/vm-ir2tran.lisp

@@ -412,7 +412,7 @@
   t)
 
 ;;; MAKE-LIST optimizations
-#+x86-64
+#+nil ; x86-64
 (progn
   (defoptimizer (%make-list stack-allocate-result) ((length element) node)
     t)

src/compiler/ir1tran.lisp

@@ -83,7 +83,9 @@
 (defun proper-list (form)
   (if (proper-list-p form)
       form
-      (compiler-error "~@<~S is not a proper list.~@:>" form)))
+      (progn
+        (write-string "CRAPOLA: ")(write form)(terpri)
+        (compiler-error "~@<~S is not a proper list.~@:>" form))))
 
 ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
 ;;; blocks into as we generate them. This just serves to glue the

src/compiler/ir2opt.lisp

@@ -1510,7 +1510,7 @@
                      (already-done (eq (fourth (vop-codegen-info vop)) :pseudo-atomic)))
                  (unless (or dx already-done)
                    (process-closure-inits vop))))
-              ((fixed-alloc var-alloc)
+              ((fixed-alloc #|var-alloc|#)
                (let ((last (car (last (vop-codegen-info vop)))))
                  (when (vop-p last)
                    (process-general-inits vop last)))))

src/compiler/seqtran.lisp

@@ -858,7 +858,7 @@
               ,@(loop for i below (car (array-type-dimensions type))
                       collect `(setf (aref seq ,i) item))
               seq))
-          #+x86-64
+          #+nil ; x86-64 ; disabled for concurrent GC
           ((and (type= element-ctype *universal-type*)
                 (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*))))
                 ;; FIXME: why can't this work with arbitrary START and END?
@@ -928,7 +928,7 @@
                ;; Force bounds-checks to 0 even if local policy had it >0.
                (declare (optimize (safety 0) (speed 3)
                                   (insert-array-bounds-checks 0)))
-               ,(cond #+x86-64
+               ,(cond #+nil ; #+x86-64
                       ((type= element-ctype *universal-type*)
                        '(vector-fill/t data item start end))
                       (t

src/compiler/target-disassem.lisp

@@ -618,6 +618,12 @@
 
       (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
 
+      (when (and stream
+                 (eql (car (seg-pseudo-atomic-locations segment))
+                      (dstate-next-offs dstate)))
+        (format stream "; GC barrier:")
+        (pop (seg-pseudo-atomic-locations segment)))
+
       (call-offs-hooks t stream dstate)
       (unless (or prefix-p (null stream))
         (print-current-address stream dstate))
@@ -1506,6 +1512,13 @@
            :code code
            :initial-offset initial-offset ; an offset into CODE
            :debug-fun debug-fun)))
+    (when code
+      (let (locs)
+        (dovector (x (sb-impl::code-pseudo-atomic-locations code))
+          (let ((loc (code-insts-offs-to-segment-offs x segment)))
+            (when (plusp loc)
+              (push loc locs))))
+        (setf (seg-pseudo-atomic-locations segment) (nreverse locs))))
     (add-debugging-hooks segment debug-fun source-form-cache)
     (when code
       (add-fun-header-hooks segment))

src/compiler/target-dstate.lisp

@@ -42,6 +42,7 @@
   (code nil :type (or null code-component))
   ;; list of function and fdefn constants extracted from code header
   (code-callables :?)
+  (pseudo-atomic-locations nil)
   ;; the byte offset beyond CODE-INSTRUCTIONS of CODE which
   ;; corresponds to offset 0 in this segment
   (initial-offset 0 :type index)

src/compiler/x86-64/alloc.lisp

@@ -17,6 +17,22 @@
 ;;; from the C alloc() function by way of the alloc-tramp
 ;;; assembly routine.
 
+#+nil
+(defun dontuse-test-should-use-smlgc (type)
+  (let ((bit (type-to-bit type)))
+    (unless bit
+      (error "No bit for ~x~%" type))
+    (inst test :dword (static-symbol-value-ea '*use-smlgc*) (ash 1 (1+ bit)))))
+
+(defmacro jump-if-not-bitmap-alloc (label)
+  `(progn
+     (inst cmp :dword (thread-slot-ea (1+ thread-ap4-slot)) -1)
+     (inst jmp :e ,label)))
+(defmacro jump-if-bitmap-alloc (label)
+  `(progn
+     (inst cmp :dword (thread-slot-ea (1+ thread-ap4-slot)) -1)
+     (inst jmp :ne ,label)))
+
 (defun tagify (result base lowtag)
   (if (eql lowtag 0)
       (inst mov result base)
@@ -74,6 +90,7 @@
   ;; so we may as well take advantage of this fact to load the temp reg
   ;; here, if provided, rather than spewing more #+gs-seg tests around.
   #+gs-seg (when thread-temp (inst rdgsbase thread-temp))
+  #+smlgc-telemetry (inst inc :qword (thread-slot-ea thread-ct-new-objects-slot)) ; TELEMETRY
   (when (member :allocation-size-histogram sb-xc:*features*)
     (let ((use-size-temp (not (typep size '(or (signed-byte 32) tn)))))
       ;; Sum up the sizes of boxed vs unboxed allocations.
@@ -184,6 +201,213 @@
 ;;; with the CONS-TYPE in our type-algebraic sense. Mostly just informs
 ;;; the allocator to use cons_tlab.
 (defconstant +cons-primtype+ list-pointer-lowtag)
+;(defvar *cons-n-histo* #x501009B0)
+
+;;; For async GC based on SML#
+;;; See 'struct alloc_ptr' in heap_concurrent
+;;; and 'struct sml_bitptr' in smlsharp.h
+(defmacro with-bitmap-ap ((allocptr &optional thread-slot) &body body)
+  (cond ((eq allocptr :thread)
+         (aver thread-slot)
+         ;; DISP has to remain as an expression so that the returned form
+         ;; is toplevelish.
+         (let ((disp `(ash ,thread-slot word-shift)))
+           `(macrolet ((freebit.ptr () '(ea ,disp thread-tn))
+                       (freebit.mask () '(ea (+ ,disp 8) thread-tn))
+                       ;; the most-significant byte of the mask for CONS special cases
+                       (freebit.mask-byte3 () '(ea (+ ,disp 11) thread-tn))
+                       (freeptr () '(ea (+ ,disp 16) thread-tn))
+                       (freeptr-fetch-and-add (result nbytes scratch)
+                         `(progn
+                            ;; XADD would do this, but C compilers don't use it
+                            ;; except for an atomic fetch-and-add.
+                            ;; the Agner Fog instruction latency tables seem to support that.
+                            (inst mov ,result (freeptr))
+                            (inst lea ,scratch (ea ,nbytes ,result))
+                            (inst mov (freeptr) ,scratch))))
+              ,@body)))
+        (t
+         (aver (not thread-slot))
+         `(macrolet ((freebit.ptr () '(ea 0 ,allocptr))
+                     (freebit.mask () '(ea 8 ,allocptr))
+                     (freeptr () '(ea 16 ,allocptr))
+                     (segment.blocksize () '(ea 24 ,allocptr)))
+            ,@body))))
+
+(defconstant unused-word-pattern #xffffffffdeadbeef)
+(defun assert-word-unused (ea &aux (ok (gen-label)))
+  (declare (ignore ea ok))
+  #+nil
+  (when t
+    (inst cmp :qword ea unused-word-pattern)
+    (inst jmp :eq OK)
+    (inst break halt-trap)
+    (emit-label OK)))
+(defun check-alivep (obj lowtag &aux (ok (gen-label)))
+  (declare (ignore obj lowtag ok))
+  #+nil
+  (unless (constant-tn-p obj)
+    (inst cmp :qword (ea (- lowtag) obj) unused-word-pattern)
+    (inst jmp :ne OK)
+    (inst break halt-trap)
+    (emit-label OK)))
+
+(defmacro count-alloc (name)
+  (declare (ignorable name))
+  #+nil
+  (let ((index
+         (the (not null)
+              (position name
+                        '(:cons1 :cons1-slow
+                          :cons2 :cons2-slow
+                          :cons3 :cons3-slow
+                          :cons4 :cons4-slow
+                          :cons5 :cons5-slow
+                          :cons6+ :dummy ; always "slow"
+                          :barrier-store :barrier-cmpxchg
+                          )))))
+    ;; The first 16 elements are taken up by a histogram of lengths
+    ;; of &REST args that we see - count and count-slow for each length
+    ;; 1 through 15 and a catch-all bin.
+    ;; But to make things more confusing, this is a vector of SB-VM:WORD
+    ;; though &REST lists treat it as a vector of UNSIGNED-BYTE-32
+    `(inst inc :lock :qword
+           (ea ,(+ (cons-stats-v) (ash 16 word-shift) (* index 8))))))
+
+(with-bitmap-ap (:thread thread-ap4-slot)
+(defun bitmap-inline-alloc-list (num-conses alloc-tn temp done-label fallback)
+  #+nil
+  (inst inc :lock :qword
+        (ea (+ (cons-stats-v) (ash 16 word-shift)
+               ;; Use pairs of elements for consN, consN-slow. See above
+               (* (1- num-conses) 16))))
+  (let ((bmwordptr alloc-tn)
+        (mask temp)
+        (unavailable (gen-label)))
+    ;; >1 cons has a pre-test for UNAVAILABLE in case the current mask + NUM-CONSES
+    ;; would exceed the current bitmap word
+    (ecase num-conses
+      (1
+       (inst mov bmwordptr (freebit.ptr))
+       (inst mov :dword mask (freebit.mask))) ; MASK has the bit we want next
+      (2
+       (inst mov bmwordptr (freebit.ptr))
+       (inst mov :dword mask (freebit.mask))
+       (inst test :dword mask mask)
+       ;; Fail if mask bit 31 is 1. We'd need to test bit 0 of the next bitmap word too,
+       ;; so just use the slow path. Fast path occurs 96% of the time if bitmap word = 0.
+       (inst jmp :s UNAVAILABLE) ; MASK*3 will overflow a :DWORD is sign bit is on
+       (inst lea :dword mask (ea mask mask 2))) ; MASK = MASK * 3 (setting 2 bits)
+      (3
+       (inst mov :dword bmwordptr (freebit.mask))
+       ;; Fail if bit 30 or 31 is 1.  Fast path occurs 93% of the time if bitmap word = 0.
+       (inst test :dword bmwordptr #xC0000000)
+       (inst jmp :nz UNAVAILABLE) ; MASK*7 would overflow :DWORD
+       ;; The highest bit that could be on is bit index 29. The highest affected bit
+       ;; could be index 32 after multiplying by 8. (Thus we need :QWORD operations)
+       (inst lea mask (ea nil bmwordptr 8))
+       (inst sub mask bmwordptr)) ; Set 3 bits by computing mask*7 as (8 x mask) - mask
+      (4
+       (inst mov :dword mask (freebit.mask))
+       ;; Fail if bit 29, 30 or 31 is 1.  Fast path occurs 90% of the time if bitmap word = 0.
+       (inst test :dword mask #xE0000000)
+       (inst jmp :nz UNAVAILABLE) ; MASK*15 would overflow :DWORD
+       ;; The highest bit that could be on is bit index 28
+       (inst mov :dword bmwordptr mask)
+       (inst shl mask 4)
+       (inst sub mask bmwordptr)) ; Set 4 bits by computing mask*15 as (16 x mask) - mask
+      (5
+       (inst mov :dword mask (freebit.mask))
+       (inst test :dword mask #xF0000000)
+       (inst jmp :nz UNAVAILABLE) ; MASK*31 would overflow :DWORD
+       ;; The highest bit that could be on is bit index 27
+       (inst mov :dword bmwordptr mask)
+       (inst shl mask 5)
+       (inst sub mask bmwordptr))) ; Set 5 bits by computing mask*31 as (32 x mask) - mask
+    ;;
+    (when (> num-conses 2) (inst mov bmwordptr (freebit.ptr)))
+    (inst test :dword (ea bmwordptr) mask)
+    (inst jmp :nz UNAVAILABLE)
+    ;; advance the bit
+    (case num-conses
+      (1
+       (inst rol :dword mask 1)
+       (inst mov :dword (freebit.mask) mask)) ; writeback
+      (t ; DO NOT write back from the mask register, as it contains > 1 set bit
+       (inst rol :dword (freebit.mask) num-conses)))
+    ;; I tested whether branchless logic for incrementing freebit.ptr is preferable
+    ;; to jumping over an add if the carry is clear, and it definitely is,
+    ;; because the branch is not very predictable.
+    (inst sbb :dword temp temp) ; broadcast the carry into low 32 bits
+    (inst and :dword temp 4) ; = 0 or 4 depending on CF prior to SBB
+    (inst add :qword (freebit.ptr) temp)
+#|
+    ;; Jmp over add is worse
+    (inst jmp :nc done-label)
+    (inst add :qword (freebit.ptr) 4)
+|#
+    (freeptr-fetch-and-add alloc-tn (* num-conses 16) temp)
+    (dotimes (i num-conses) (assert-word-unused (ea (ash i word-shift) alloc-tn)))
+    (inst jmp DONE-LABEL) ; success
+    (emit-label unavailable)
+    (inst cmp :dword (if (= num-conses 1) mask (freebit.mask)) -1)
+    (inst jmp :ne FALLBACK) ; call into C for help with bitmap allocation
+    ;; falllthrough goes to the gencgc allocator
+    )))
+
+(defun bitmap-call-alloc-list (things alloc-tn node num-conses star)
+  (macrolet ((pop-arg () `(prog1 (tn-ref-tn things) (setf things (tn-ref-across things)))))
+    (loop (list-ctor-push-elt (pop-arg) alloc-tn)
+          (unless things (return))))
+  (cond ((<= num-conses 5)
+         (let ((fallback
+                (aref (if star
+                          #(bitmap-list*4-fallback bitmap-list*5-fallback bitmap-list*6-fallback)
+                          #(bitmap-list3-fallback  bitmap-list4-fallback  bitmap-list5-fallback))
+                      (- num-conses 3))))
+           (invoke-asm-routine 'call fallback node)))
+        (t
+         (inst lea rax-tn (ea (* (+ num-conses (if star 0 -1)) n-word-bytes) rsp-tn))
+         (inst mov rcx-tn num-conses)
+         (invoke-asm-routine 'call (if star 'bitmap-listify* 'bitmap-listify) node)
+         (inst add rsp-tn (* (+ num-conses (if star 1 0)) n-word-bytes))))
+  (move alloc-tn rax-tn))
+
+(defun bitmap-alloc (nbytes result-tn temps node done-label)
+  (aver (<= 1 (length temps) 2))
+  (let* ((log2size (the (integer 4 12) (integer-length (1- nbytes))))
+         ;; each alloc_ptr consumes 4 words consecutively from the AP4 slot
+         (thread-slot (+ thread-ap4-slot (* 4 (- log2size 4))))
+         (fallback (gen-label))
+         (unavailable (gen-label))
+         (temp (car temps)))
+    (with-bitmap-ap (:thread thread-slot)
+      (inst mov temp (freebit.ptr))
+      (inst mov :dword result-tn (freebit.mask))
+      (inst test :dword (ea temp) result-tn) ; result-tn holds the desired bit
+      (inst jmp :nz UNAVAILABLE) ; block is not available
+      (inst rol :dword (freebit.mask) 1)
+      (inst sbb :dword result-tn result-tn) ; broadcast the carry into low 32 bits
+      (inst and :dword result-tn 4) ; = 0 or 4 depending on CF prior to SBB
+      (inst add (freebit.ptr) result-tn)
+      (freeptr-fetch-and-add result-tn (ash 1 log2size) temp)
+      (inst jmp DONE-LABEL)
+      (emit-label UNAVAILABLE)
+      ;; if mask is all 1s then we are NOT using the bitmap allocator
+      ;; if mask is NOT all 1s then we ARE using the bitmap allocator
+      (inst cmp :dword result-tn -1) ; freebit.mask is in RESULT-TN
+      (inst jmp :ne fallback))
+    ;; fallthrough
+    (assemble (:elsewhere)
+      (emit-label fallback)
+      (case log2size
+        (4 (call-reg-specific-asm-routine node "" result-tn "-ALLOC16-FALLBACK"))
+        (5 (call-reg-specific-asm-routine node "" result-tn "-ALLOC32-FALLBACK"))
+        (6 (call-reg-specific-asm-routine node "" result-tn "-ALLOC64-FALLBACK"))
+        ;; other sizes use a generalized fallback
+        (t (inst lea result-tn (thread-slot-ea thread-slot))
+           (call-reg-specific-asm-routine node "" result-tn "-ALLOC-FALLBACK")))
+      (inst jmp DONE-LABEL))))
 
 (define-vop (sb-c::end-pseudo-atomic)
   (:generator 1 (emit-end-pseudo-atomic)))
@@ -198,10 +422,12 @@
 ;;; 1. what to allocate: type, size, lowtag describe the object
 ;;; 2. where to put the result
 ;;; 3. node (for determining immobile-space-p) and a scratch register or two
-(defun allocation (type size lowtag alloc-tn node temp thread-temp
+(defun gengc-alloc (type size lowtag alloc-tn node temp thread-temp
-                   &key overflow
+                    &key overflow
-                   &aux (systemp (system-tlab-p type node)))
+                    &aux (systemp (system-tlab-p type node)))
   (declare (ignorable thread-temp))
+  (when overflow
+    (aver (eql type +cons-primtype+)))
   (flet ((fallback (size)
            ;; Call an allocator trampoline and get the result in the proper register.
            ;; There are 2 choices of trampoline to invoke alloc() or alloc_list()
@@ -295,8 +521,32 @@
                       (when (and (/= lowtag 0) (not temp) (not (tn-p size)))
                         (inst or :byte alloc-tn lowtag))
                       (inst jmp DONE))))))))
+
   t)
 
+(defun allocation (type size lowtag alloc-tn node temps thread-temp
+                   &key (try-bitmap-alloc t)
+                   &aux (saved-reg
+                         (when (and try-bitmap-alloc (not temps))
+                           (if (location= alloc-tn rax-tn) rcx-tn rax-tn)))
+                        (temps (ensure-list temps)))
+  ;; Conses and variable-sized or large allocations are
+  ;; handled outside of this function if using SML# allocator
+  (when saved-reg
+    (inst push saved-reg))
+  (assemble ()
+    (when try-bitmap-alloc
+      (bitmap-alloc size alloc-tn (or temps (list saved-reg)) node DONE))
+    ;; fallthrough
+    (gengc-alloc type size lowtag alloc-tn node (or (first temps) saved-reg)
+                 thread-temp)
+    DONE
+    ;; FIXME: there's redundancy here, because a single OR instruction
+    ;; should be part of both code flows.
+    (unless (= lowtag 0) (inst or :byte alloc-tn lowtag)))
+  (when saved-reg
+    (inst pop saved-reg)))
+
 ;;; Allocate an other-pointer object of fixed NWORDS with a single-word
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.  NWORDS counts the header word.
@@ -307,17 +557,19 @@
   (declare (dynamic-extent init))
   #+bignum-assertions
   (when (= widetag bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
+  (aver (<= bytes smlgc-blocksize-max))
   (instrument-alloc widetag bytes node (cons result-tn (ensure-list alloc-temps)) thread-temp)
-  (let ((header (compute-object-header nwords widetag))
+  (let ((header (compute-object-header nwords widetag)))
-        (alloc-temp (if (listp alloc-temps) (car alloc-temps) alloc-temps)))
+    ;; if the object is cons-sized (2 words) then the page fill byte is 0xff
+    ;; so we have to write the entire header word. If more than 2 words, the fill byte is 0.
     (pseudo-atomic ()
-      (cond (alloc-temp
+      (cond (alloc-temps
-             (allocation widetag bytes 0 result-tn node alloc-temp thread-temp)
+             (allocation widetag bytes 0 result-tn node alloc-temps thread-temp)
-             (storew* header result-tn 0 0 t)
+             (storew* header result-tn 0 0 (> nwords 2))
              (inst or :byte result-tn other-pointer-lowtag))
             (t
              (allocation widetag bytes other-pointer-lowtag result-tn node nil thread-temp)
-             (storew* header result-tn 0 other-pointer-lowtag t)))
+             (storew* header result-tn 0 other-pointer-lowtag (> nwords 2))))
       (when init
         (funcall init)))))
 
@@ -365,6 +617,8 @@
   (:args (car :scs (any-reg descriptor-reg constant immediate control-stack))
          (cdr :scs (any-reg descriptor-reg constant immediate control-stack)))
   (:temporary (:sc unsigned-reg :to (:result 0) :target result) alloc)
+  ;; TEMP does not have to be wired, because the fallback does not destroy
+  ;; any registers
   (:temporary (:sc unsigned-reg :to (:result 0)
                :unused-if (node-stack-allocate-p (sb-c::vop-node vop)))
               temp)
@@ -393,16 +647,25 @@
        (inst lea result (ea list-pointer-lowtag rsp-tn)))
       (t
        (let ((nbytes (* cons-size n-word-bytes))
-             (prev-constant temp)) ;; a non-eq initial value
+             (prev-constant temp) ;; a non-eq initial value
+             (fallback (gen-label)))
          (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
          (pseudo-atomic (:thread-tn thread-tn)
-           (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
+           (bitmap-inline-alloc-list 1 alloc temp CONTINUE FALLBACK)
+           (assemble (:elsewhere)
+             (emit-label fallback)
+             (call-reg-specific-asm-routine node "BITMAP-CONS-TO-" alloc "-FALLBACK")
+             (inst jmp CONTINUE))
+           ;; pointer bump allocation
+           (gengc-alloc +cons-primtype+ nbytes 0 alloc node temp thread-tn)
+           CONTINUE
            (store-slot car alloc cons-car-slot 0)
            (store-slot cdr alloc cons-cdr-slot 0)
            (if (location= alloc result)
                (inst or :byte alloc list-pointer-lowtag)
                (inst lea result (ea list-pointer-lowtag alloc)))))))))
 
+#+nil
 (define-vop (acons)
   (:args (key :scs (any-reg descriptor-reg constant immediate control-stack))
          (val :scs (any-reg descriptor-reg constant immediate control-stack))
@@ -419,7 +682,7 @@
           (prev-constant temp))
       (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
       (pseudo-atomic (:thread-tn thread-tn)
-        (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
+        (gengc-alloc +cons-primtype+ nbytes 0 alloc node temp thread-tn)
         (store-slot tail alloc cons-cdr-slot 0)
         (inst lea temp (ea (+ 16 list-pointer-lowtag) alloc))
         (store-slot temp alloc cons-car-slot 0)
@@ -440,7 +703,9 @@
          (cadr :scs (any-reg descriptor-reg constant immediate control-stack))
          (cddr :scs (any-reg descriptor-reg constant immediate control-stack)))
   (:temporary (:sc unsigned-reg :to (:result 0) :target result) alloc)
-  (:temporary (:sc unsigned-reg :to (:result 0)
+  ;; TEMP has to be wired because the fallback returns a value in RAX
+  ;; (can we return it on the stack instead?)
+  (:temporary (:sc unsigned-reg :to (:result 0) :offset rax-offset
                :unused-if (node-stack-allocate-p (sb-c::vop-node vop)))
               temp)
   (:results (result :scs (descriptor-reg)))
@@ -458,11 +723,26 @@
        (list-ctor-push-elt car alloc)
        (inst lea result (ea list-pointer-lowtag rsp-tn)))
       (t
-       (let ((nbytes (* cons-size 2 n-word-bytes))
+       (let ((nbytes (* 2 cons-size n-word-bytes))
-             (prev-constant temp))
+             (prev-constant temp)
+             (fallback (gen-label)))
          (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
          (pseudo-atomic (:thread-tn thread-tn)
-           (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
+           (bitmap-inline-alloc-list 2 alloc temp CONTINUE FALLBACK)
+           (assemble (:elsewhere)
+             (emit-label fallback)
+             (list-ctor-push-elt car temp)
+             (list-ctor-push-elt cadr temp)
+             (cond ((and (constant-tn-p cddr) (eq (tn-value cddr) nil))
+                    (invoke-asm-routine 'call 'bitmap-list2-fallback node))
+                   (t
+                    (list-ctor-push-elt cddr temp)
+                    (invoke-asm-routine 'call 'bitmap-list*3-fallback node)))
+             (move result temp)
+             (inst jmp done))
+           ;; pointer bump allocation
+           (gengc-alloc +cons-primtype+ nbytes 0 alloc node temp thread-tn)
+           CONTINUE
            (store-slot car alloc cons-car-slot 0)
            (store-slot cadr alloc (+ 2 cons-car-slot) 0)
            (store-slot cddr alloc (+ 2 cons-cdr-slot) 0)
@@ -470,11 +750,13 @@
            (store-slot temp alloc cons-cdr-slot 0)
            (if (location= alloc result)
                (inst or :byte alloc list-pointer-lowtag)
-               (inst lea result (ea list-pointer-lowtag alloc)))))))))
+               (inst lea result (ea list-pointer-lowtag alloc)))
+           DONE))))))
 
 (define-vop (list)
   (:args (things :more t :scs (descriptor-reg any-reg constant immediate)))
-  (:temporary (:sc unsigned-reg) ptr temp)
+  (:temporary (:sc unsigned-reg :offset rcx-offset) ptr)
+  (:temporary (:sc unsigned-reg :offset rax-offset) temp)
   (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:info star cons-cells)
@@ -482,15 +764,35 @@
   (:node-var node)
   (:generator 0
     (aver (>= cons-cells 3)) ; prevent regressions in ir2tran's vop selection
-    (let ((stack-allocate-p (node-stack-allocate-p node))
+    (let* ((stack-allocate-p (node-stack-allocate-p node))
-          (size (* (pad-data-block cons-size) cons-cells))
+           (size (* (pad-data-block cons-size) cons-cells))
-          (prev-constant temp))
+           (prev-constant temp))
       (unless stack-allocate-p
         (instrument-alloc +cons-primtype+ size node (list ptr temp) thread-tn))
       (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
-        (if stack-allocate-p
+        (cond
-            (stack-allocation size list-pointer-lowtag res)
+          (stack-allocate-p
-            (allocation +cons-primtype+ size list-pointer-lowtag res node temp thread-tn))
+           (stack-allocation size list-pointer-lowtag res))
+          (t
+           (let ((linear-alloc (gen-label)) (fallback (gen-label)))
+             (cond
+               ((> cons-cells 5)
+                (jump-if-not-bitmap-alloc LINEAR-ALLOC)
+                ;; Don't bother trying to get contiguous bits- success rate is too low
+                (count-alloc :cons6+)
+                (bitmap-call-alloc-list things res node cons-cells star)
+                (inst jmp DONE))
+               (t
+                ;; emit the fallback first because THINGS gets popped later
+                (assemble (:elsewhere)
+                  (emit-label fallback)
+                  (bitmap-call-alloc-list things res node cons-cells star)
+                  (inst jmp DONE))
+                (bitmap-inline-alloc-list cons-cells res temp CONTINUE FALLBACK)))
+             (emit-label LINEAR-ALLOC)
+             (gengc-alloc +cons-primtype+ size 0 res node temp thread-tn))))
+        CONTINUE
+        (unless stack-allocate-p (inst or :byte res list-pointer-lowtag))
         (move ptr res)
         (dotimes (i (1- cons-cells))
           (store-slot (pop-arg things) ptr)
@@ -499,17 +801,19 @@
         (store-slot (pop-arg things) ptr cons-car-slot list-pointer-lowtag)
         (if star
             (store-slot (pop-arg things) ptr cons-cdr-slot list-pointer-lowtag)
-            (storew nil-value ptr cons-cdr-slot list-pointer-lowtag))))
+            (storew nil-value ptr cons-cdr-slot list-pointer-lowtag))
+        DONE))
     (aver (null things))
     (move result res)))
 )
 
 ;;;; special-purpose inline allocators
 
-;;; Special variant of 'storew' which might have a shorter encoding
+;;; Zeroed storew - possibly use a shorter encoding if storing
-;;; when storing to the heap (which starts out zero-filled).
+;;; to a word that was initialized with 0-fill.
 ;;; This will always write 8 bytes if WORD is a negative number.
 (defun storew* (word object slot lowtag zeroed &optional temp)
+  (setq zeroed nil)
   (cond
     ((or (not zeroed) (not (typep word '(unsigned-byte 31))))
      ;; Will use temp reg if WORD can't be encoded as an imm32
@@ -582,12 +886,13 @@
                      (inst and ,size-tn (lognot lowtag-mask))
                      ,size-tn)))
            (put-header (vector-tn lowtag type len zeroed temp)
+             (declare (ignore zeroed))
              `(let ((len (if (sc-is ,len immediate) (fixnumize (tn-value ,len)) ,len))
                     (type (if (sc-is ,type immediate) (tn-value ,type) ,type)))
-                (storew* type ,vector-tn 0 ,lowtag ,zeroed ,temp)
+                (storew* type ,vector-tn 0 ,lowtag #|,zeroed|# nil ,temp)
                 #+ubsan (inst mov :dword (vector-len-ea ,vector-tn ,lowtag) len)
                 #-ubsan (storew* len ,vector-tn vector-length-slot
-                                       ,lowtag ,zeroed ,temp)))
+                                       ,lowtag #|,zeroed|# nil ,temp)))
            (want-shadow-bits ()
              `(and poisoned
                    (if (sc-is type immediate)
@@ -625,10 +930,14 @@
     (:results (result :scs (descriptor-reg) :from :load))
     (:arg-types #+ubsan (:constant t)
                 positive-fixnum positive-fixnum positive-fixnum)
-    (:temporary (:sc unsigned-reg) temp)
+    ;; Wiring RAX as the temp is for the bitmap allocator call
+    (:temporary (:sc unsigned-reg :offset rax-offset) temp)
+    (:temporary (:sc complex-double-reg :offset 7) header-temp)
     #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
     (:policy :fast-safe)
     (:node-var node)
+    (:arg-refs args-ref)
+    (:ignore header-temp)
     (:generator 100
       #+ubsan
       (when (want-shadow-bits)
@@ -660,10 +969,15 @@
       ;; * If WORDS is not immediate and ALLOC-TEMP is not R12, then compute size
       ;;   into RESULT, use ALLOC-TEMP as the instrumentation temp.
       ;;   ALLOCATION receives: input = RESULT, output = RESULT, temp = ALLOC-TEMP.
-      (multiple-value-bind (size-tn instrumentation-temp alloc-temp)
+      (binding*
-          (cond ((sc-is words immediate)
+          ((fixed-size (if (sc-is words immediate)
+                           (pad-data-block (+ (tn-value words) vector-data-offset))))
+           (maybe-large (or (not fixed-size) (> fixed-size smlgc-blocksize-max)))
+           ((size-tn instrumentation-temp alloc-temp)
+            (cond
+                (fixed-size
                  ;; If WORDS is immediate, then let INSTRUMENT-ALLOC choose its temp
-                 (values (calc-size-in-bytes words nil) (list result temp) temp))
+                 (values fixed-size (list result temp) temp))
                 ((location= temp r12-tn)
                  ;; Compute the size into TEMP, use RESULT for instrumentation.
                  ;; Don't give another temp to ALLOCATION, because its SIZE and temp
@@ -673,17 +987,34 @@
                  ;; Compute the size into RESULT, use TEMP for instrumentation.
                  ;; ALLOCATION needs the temp register in this case,
                  ;; because input and output are in the same register.
-                 (values (calc-size-in-bytes words result) temp temp)))
+                 (values (calc-size-in-bytes words result) temp temp)))))
         (instrument-alloc (if (sc-is type immediate)
                               (case (tn-value type)
                                 (#.simple-vector-widetag 'simple-vector)
                                 (t 'unboxed-array))
                               type)
                           size-tn node instrumentation-temp thread-tn)
+        ;; Same concept as in var-alloc
+        (when maybe-large
+          (assemble ()
+            (jump-if-not-bitmap-alloc LINEAR-ALLOC)
+            ;; MOVDQU can load and store the object header from these 2 words
+            ;; I pity the fool whose uses an immediate so large
+            ;; that's it not encodable as a PUSH operand.
+            (inst push (encode-value-if-immediate length))
+            (inst push (encode-value-if-immediate type nil)) ; untagged
+            (inst mov temp size-tn) ; TEMP = RAX
+            (invoke-asm-routine 'call 'bitmap-vect-alloc node)
+            (move result temp)
+            (inst jmp DONE)
+            LINEAR-ALLOC))
         (pseudo-atomic (:thread-tn thread-tn)
-         (allocation type size-tn 0 result node alloc-temp thread-tn)
+         (allocation (if (sc-is type immediate) (tn-value type) 'vector)
+                     size-tn 0 result node (list alloc-temp) thread-tn
+                     :try-bitmap-alloc (not maybe-large))
          (put-header result 0 type length t alloc-temp)
          (inst or :byte result other-pointer-lowtag)))
+      DONE
       #+ubsan
       (cond ((want-shadow-bits)
              (inst pop temp-reg-tn) ; restore shadow bits
@@ -786,6 +1117,7 @@
         (inst stos :qword)))))
 
 ;;; ALLOCATE-LIST
+#+nil
 (macrolet ((calc-size-in-bytes (length answer)
              `(cond ((sc-is ,length immediate)
                      (aver (/= (tn-value ,length) 0))
@@ -841,6 +1173,7 @@
         (storew nil-value tail cons-cdr-slot list-pointer-lowtag))
       done))
 
+  #+nil ; FIXME
   (define-vop (allocate-list-on-heap)
     (:args (length :scs (any-reg immediate))
            ;; Too bad we don't have an SC that implies actually a CPU immediate
@@ -850,16 +1183,40 @@
     (:arg-types positive-fixnum *)
     (:policy :fast-safe)
     (:node-var node)
+    ;; These are need for the bitmap allocator
+    (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 0)) rcx)
+    (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1) :to :result) rax)
+    ;; Too many temps. Oh well.
     (:temporary (:sc descriptor-reg) tail next limit)
     #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
     (:generator 20
+      (unless (sc-is length immediate)
+        (inst test length length)
+        (inst jmp :nz continue)
+        (inst mov result nil-value)
+        (inst jmp out))
+      continue
+      (unless (sc-is length immediate) (move rcx length))
+      (move rax element)
+      (let ((nbytes (cond ((sc-is length immediate)
+                           (* (tn-value ,length) n-word-bytes 2))
+                          (t
+                           (inst shl rcx (1+ (- word-shift n-fixnum-tag-bits)))
+                           rcx))))
+        (instrument-alloc +cons-primtype+ nbytes node (list next limit) thread-tn))
       (let ((size (calc-size-in-bytes length tail))
             (entry (gen-label))
             (loop (gen-label))
+            (native (gen-label))
             (leave-pa (gen-label)))
         (instrument-alloc +cons-primtype+ size node (list next limit) thread-tn)
         (pseudo-atomic (:thread-tn thread-tn)
-         (allocation +cons-primtype+ size list-pointer-lowtag result node limit thread-tn
+         (test-should-use-smlgc :make-list)
+         (inst jmp :z native)
+         ;; SML# allocator, cons-at-a-time
+         (emit-label native)
+         (gengc-alloc +cons-primtype+ size list-pointer-lowtag result node
+                     limit thread-tn
                      :overflow
                      (lambda ()
                        ;; Push C call args right-to-left
@@ -893,8 +1250,9 @@
   (:results (result :scs (descriptor-reg) :from :argument))
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 37
-    (alloc-other fdefn-widetag fdefn-size result node nil thread-tn
+    (alloc-other fdefn-widetag fdefn-size result node (list temp temp2) thread-tn
       (lambda ()
         (storew name result fdefn-name-slot other-pointer-lowtag)
         (storew nil-value result fdefn-fun-slot other-pointer-lowtag)
@@ -909,6 +1267,7 @@
   (:node-var node)
   (:vop-var vop)
   (:generator 10
+    (aver (>= length 1))
     (let* ((words (+ length closure-info-offset)) ; including header
            (bytes (pad-data-block words))
            (header (logior (ash (1- words) n-widetag-bits) closure-widetag))
@@ -920,7 +1279,7 @@
                       :elide-if stack-allocate-p :thread-tn thread-tn)
         (if stack-allocate-p
             (stack-allocation bytes fun-pointer-lowtag result)
-            (allocation closure-widetag bytes fun-pointer-lowtag result node temp thread-tn))
+            (allocation closure-widetag bytes fun-pointer-lowtag result node (list temp) thread-tn))
         (storew* #-compact-instance-header header ; write the widetag and size
                  #+compact-instance-header        ; ... plus the layout pointer
                  (let ((layout #-sb-thread (static-symbol-value-ea 'function-layout)
@@ -944,6 +1303,7 @@
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:info stack-allocate-p)
   (:node-var node)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 10
     (let ((data (if (sc-is value immediate)
                     (let ((bits (encode-value-if-immediate value)))
@@ -960,8 +1320,11 @@
              (inst push (compute-object-header value-cell-size value-cell-widetag))
              (inst lea result (ea other-pointer-lowtag rsp-tn)))
             (t
-             (alloc-other value-cell-widetag value-cell-size result node nil thread-tn
+             (alloc-other
+              value-cell-widetag value-cell-size result node
+              (list temp temp2) thread-tn
               (lambda ()
+                ;; FIXME: use the temp instead of push/pop
                 (if (sc-case value
                      (immediate
                       (unless (integerp data) (inst push data) t))
@@ -984,15 +1347,16 @@
 
 (flet
   ((alloc (vop name words type lowtag stack-allocate-p result
-                    &optional alloc-temp node
+                    &optional temps node
                     &aux (bytes (pad-data-block words))
                          (remain-pseudo-atomic
                           (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
     #+bignum-assertions
     (when (eq type bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
+    (aver (<= bytes smlgc-blocksize-max))
     (progn name) ; possibly not used
     (unless stack-allocate-p
-      (instrument-alloc type bytes node (list result alloc-temp) thread-tn))
+      (instrument-alloc type bytes node (cons result temps) thread-tn))
     (pseudo-atomic (:default-exit (not remain-pseudo-atomic)
                     :elide-if stack-allocate-p :thread-tn thread-tn)
       ;; If storing a header word, defer ORing in the lowtag until after
@@ -1000,11 +1364,13 @@
       (cond (stack-allocate-p
              (stack-allocation bytes (if type 0 lowtag) result))
             ((eql type funcallable-instance-widetag)
+             (bitmap-alloc bytes result temps node ALLOCATED)
              (inst push bytes)
              (invoke-asm-routine 'call 'alloc-funinstance vop)
              (inst pop result))
             (t
-             (allocation type bytes (if type 0 lowtag) result node alloc-temp thread-tn)))
+             (allocation type bytes (if type 0 lowtag) result node temps thread-tn)))
+      ALLOCATED
       (let ((header (compute-object-header words type)))
         (cond #+compact-instance-header
               ((and (eq name '%make-structure-instance) stack-allocate-p)
@@ -1014,7 +1380,8 @@
               ;; where this instruction must write exactly 4 bytes.
                (inst mov :dword (ea 0 result) header))
               (t
-               (storew* header result 0 0 (not stack-allocate-p)))))
+               (storew* header result 0 0 (and (not stack-allocate-p)
+                                               (> words 2))))))
       ;; GC can make the best choice about placement if it has a layout.
       ;; Of course with conservative GC the object will be pinned anyway,
       ;; but still, always having a layout is a good thing.
@@ -1026,11 +1393,11 @@
   (define-vop (fixed-alloc)
     (:info name words type lowtag dx)
     (:results (result :scs (descriptor-reg)))
-    (:temporary (:sc unsigned-reg) alloc-temp)
+    (:temporary (:sc unsigned-reg) temp1 temp2)
     #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
     (:vop-var vop)
     (:node-var node)
-    (:generator 50 (alloc vop name words type lowtag dx result alloc-temp node)))
+    (:generator 50 (alloc vop name words type lowtag dx result (list temp1 temp2) node)))
   (define-vop (sb-c::fixed-alloc-to-stack)
     (:info name words type lowtag dx)
     (:results (result :scs (descriptor-reg)))
@@ -1052,8 +1419,8 @@
   (:results (result :scs (descriptor-reg) :from (:eval 1)))
   (:temporary (:sc unsigned-reg :from :eval :to (:eval 1)) bytes)
   (:temporary (:sc unsigned-reg :from :eval :to :result) header)
-  ;; KLUDGE: wire to RAX so that it doesn't get R12
+  ;; alloc-temp is a passing register for the ASM routine
-  (:temporary (:sc unsigned-reg :offset 0) alloc-temp)
+  (:temporary (:sc unsigned-reg :offset rax-offset) alloc-temp)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
   (:vop-var vop)
@@ -1063,7 +1430,8 @@
      ;; which it failed to do if the var-alloc translation was invoked.
      ;; But it seems we never need this! (so is it FIXME or isn't it?)
      (error "can't %MAKE-FUNCALLABLE-INSTANCE of unknown length"))
-   (let ((remain-pseudo-atomic (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
+   (progn ; let ((remain-pseudo-atomic (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
+     ; (declare (ignore remain-pseudo-atomic))
    ;; With the exception of bignums, these objects have effectively
    ;; 32-bit headers because the high 4 byes contain a layout pointer.
      (let ((operand-size (if (= type bignum-widetag) :qword :dword)))
@@ -1081,15 +1449,102 @@
              (stack-allocation bytes lowtag result)
              (storew header result 0 lowtag))
            (t
+            (assemble ()
              ;; can't pass RESULT as a possible choice of scratch register
              ;; because it might be in the same physical reg as BYTES.
              ;; Yup, the lifetime specs in this vop are pretty confusing.
              (instrument-alloc type bytes node alloc-temp thread-tn)
-             (pseudo-atomic (:default-exit (not remain-pseudo-atomic)
+             (jump-if-not-bitmap-alloc LINEAR-ALLOC)
-                             :thread-tn thread-tn)
+             (inst push lowtag)
-              (allocation type bytes lowtag result node alloc-temp thread-tn)
+             (inst push header)
-              (storew header result 0 lowtag)))))))
+             (move alloc-temp bytes) ; RAX passes the size
+             (invoke-asm-routine 'call 'bitmap-var-alloc node)
+             (move result alloc-temp)
+             (inst jmp done)
+             LINEAR-ALLOC
+             (pseudo-atomic (:thread-tn thread-tn)
+              (gengc-alloc type bytes lowtag result node alloc-temp thread-tn)
+              (storew header result 0 lowtag))
+             DONE))))))
 
+#+sb-xc-host
+(progn
+(define-vop (alloc-code)
+  (:args (total-words :scs (unsigned-reg))
+         (boxed-words :scs (unsigned-reg)))
+  (:temporary (:sc unsigned-reg :offset rdi-offset :from (:argument 0)) rdi)
+  (:temporary (:sc unsigned-reg :offset rsi-offset) rsi)
+  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
+  (:temporary (:sc unsigned-reg :offset r15-offset) frame)
+  (:results (res :scs (descriptor-reg)))
+  (:node-var node)
+  (:ignore frame)
+  (:generator 1
+    (move rdi total-words) ; C arg 1
+    (move rsi boxed-words) ; C arg 2
+    (jump-if-not-bitmap-alloc LINEAR-ALLOC)
+
+    ;; bitmap allocator
+    (inst lea rax (ea nil rdi n-word-bytes)) ; RAX = nbytes
+    ;(inst cmp rax smlgc-blocksize-max)
+    ;(inst jmp :be OK)
+    ;(inst break halt-trap) ; can't use this vop for large code
+    ;OK
+    (inst shl rdi 32) ; CODE-HEADER-SIZE-SHIFT
+    (inst or :byte rdi code-header-widetag)
+    (inst push other-pointer-lowtag)
+    (inst push rdi) ; header word
+    (invoke-asm-routine 'call 'bitmap-var-alloc node)
+    ;; store the boxed size in bytes. BITMAP-VAR-ALLOC preserves RSI
+    (inst shl rsi word-shift) ; words to bytes
+    (move res rax)
+    (storew rsi res code-boxed-size-slot other-pointer-lowtag)
+    (inst jmp done)
+
+    LINEAR-ALLOC
+    (with-registers-preserved (c :except rsi :frame-reg r15)
+      (pseudo-atomic ()
+        (inst call (ea (make-fixup "alloc_code_object" :foreign 8))))
+      (move rsi rax-tn))
+    (move res rsi)
+
+    DONE))
+
+;;; Place a large codeblob under GC control.
+;;; The header words haven't been filled in yet because we have to deal with a subtle
+;;; timing issue: what happens if, one instruction after exiting pseudo-atomic, this
+;;; thread is asked by GC to publish roots. Do we see a properly tagged pointer to a
+;;; known good object; while prior to calling into C we do NOT see it as being a good
+;;; object? So the header can be filled in only while pseudo-atomic.
+;;; Other threads may observe the object in the balanced binary tree but ignore it
+;;; as if it were filler. (See also alloc_large in "lispobj.c")
+#+nil
+(define-vop (manage-large-codeblob)
+  (:policy :fast-safe)
+  (:arg-types positive-fixnum t)
+  (:args (header :scs (unsigned-reg) :target rbx)
+         (mseg :scs (sap-reg) :target rdi))
+  (:temporary (:sc unsigned-reg :offset rbx-offset :from (:argument 0)) rbx)
+  (:temporary (:sc unsigned-reg :offset rdi-offset :from (:argument 1) :to :result) rdi)
+  (:results (res :scs (descriptor-reg)))
+  (:generator 1
+    (move rbx header)
+    (move rdi mseg) ; C call arg
+    ;; Don't need to save any FPRs because this vop is invoked only by a Lisp function
+    ;; that does not use floating-point. Even if the C side clobbers every FPR
+    ;; (which it doesn't) the Lisp call convention has no callee-saved FPRs.
+    (with-registers-preserved (c :except (rdi :fprs))
+      (pseudo-atomic ()
+        (inst call (ea (make-fixup "manage_large_object" :foreign 8)))
+        ;; Compute the tagged pointer to the code blob given the 'mseg' pointer
+        ;; which was conveniently returned from C.
+        (inst lea rdi (ea (+ other-pointer-lowtag smlgc-mseg-overhead-bytes) rax-tn))
+        ;; Store the header word
+        (storew header rdi 0 other-pointer-lowtag)))
+    (move res rdi)))
+) ; end PROGN
+
+#|
 #+sb-xc-host
 (define-vop (alloc-code)
   (:args (total-words :scs (unsigned-reg) :target c-arg-1)
@@ -1113,6 +1568,7 @@
          #+immobile-code (make-fixup "alloc_code_object" :foreign)))
       (move c-arg-1 rax-tn))
     (move res c-arg-1)))
+|#
 
 #+immobile-space
 (macrolet ((c-fun (name)
@@ -1212,3 +1668,21 @@
        OUT)))
 
 ) ; end MACROLET
+
+(define-vop (new-make-list)
+  (:args (length :scs (signed-reg))
+         (element :scs (any-reg descriptor-reg)))
+  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 0)) rcx)
+  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1) :to :result) rax)
+  (:results (res :scs (descriptor-reg)))
+  (:generator 10
+    (inst test length length)
+    (inst jmp :nz callout)
+    (inst mov res nil-value)
+    (inst jmp done)
+    callout
+    (move rcx length)
+    (move rax element)
+    (inst call (ea (make-fixup 'make-list-helper :assembly-routine*)))
+    (move res rax)
+    done))

src/compiler/x86-64/array.lisp

@@ -69,7 +69,7 @@
   (:arg-types positive-fixnum positive-fixnum)
   (:temporary (:sc any-reg :to :eval) bytes)
   (:temporary (:sc any-reg :to :result) header)
-  (:temporary (:sc unsigned-reg) temp)
+  (:temporary (:sc unsigned-reg :offset rax-offset) temp)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:results (result :scs (descriptor-reg) :from :eval))
   (:node-var node)
@@ -85,10 +85,22 @@
     (inst or  :dword header type)
     (inst shr :dword header n-fixnum-tag-bits)
     (instrument-alloc nil bytes node temp thread-tn)
+    (jump-if-not-bitmap-alloc LINEAR-ALLOC)
+    ;; TODO: inline the code to choose an allocation pointer
+    ;; and then use the fast path for bitmap allocation.
+    ;; (it won't be an oversized object)
+    (inst push 0)
+    (inst push header)
+    (move temp bytes) ; RAX
+    (invoke-asm-routine 'call 'bitmap-vect-alloc node)
+    (move result temp)
+    (inst jmp DONE)
+    LINEAR-ALLOC
     (pseudo-atomic (:thread-tn thread-tn)
-     (allocation type bytes 0 result node temp thread-tn)
+      (gengc-alloc type bytes 0 result node temp thread-tn)
-     (storew header result 0 0)
+      (storew header result 0 0)
-     (inst or :byte result other-pointer-lowtag))))
+      (inst or :byte result other-pointer-lowtag))
+    DONE))
 
 ;;;; additional accessors and setters for the array header
 (define-full-reffer %array-dimension *
@@ -339,7 +351,7 @@
                            object index (index-scale n-word-bytes index))))
            ,@(when (eq type 'simple-vector)
                '((emit-gengc-barrier object ea val-temp (vop-nth-arg 2 vop) value)))
-           (emit-store ea value val-temp))))
+           (emit-store vop ,(eq type 'simple-vector) object ea value val-temp))))
      (define-vop (,(symbolicate name "-C") dvset)
        (:args (object :scs (descriptor-reg))
               (value :scs ,scs))
@@ -359,7 +371,7 @@
          (let ((ea (ea (- (* (+ ,offset index addend) n-word-bytes) ,lowtag) object)))
            ,@(when (eq type 'simple-vector)
                '((emit-gengc-barrier object ea val-temp (vop-nth-arg 1 vop) value)))
-           (emit-store ea value val-temp))))))
+           (emit-store vop ,(eq type 'simple-vector) object ea value val-temp))))))
 (defmacro def-full-data-vector-frobs (type element-type &rest scs)
   `(progn
      (define-full-reffer+addend ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type)
@@ -1067,10 +1079,12 @@
   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 
 ;;; Weak vectors
+#-weak-vector-readbarrier
+(progn
 (define-full-reffer %weakvec-ref * vector-data-offset other-pointer-lowtag
   (any-reg descriptor-reg) * %weakvec-ref)
 (define-full-setter %weakvec-set * vector-data-offset other-pointer-lowtag
-  (any-reg descriptor-reg) * %weakvec-set)
+  (any-reg descriptor-reg) * %weakvec-set))
 
 ;;;; ATOMIC-INCF for arrays
 

src/compiler/x86-64/call.lisp

@@ -162,7 +162,13 @@
     (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes))
     ;; The start of the actual code.
     ;; Save the return-pc.
-    (popw rbp-tn (frame-word-offset return-pc-save-offset))))
+    (popw rbp-tn (frame-word-offset return-pc-save-offset))
+    ;;
+    ;(inst test :byte (static-symbol-value-ea '*sml-check-flag*) 2)
+    ;(inst jmp :z SKIP)
+    ;(inst call (ea (make-fixup 'gc-check :assembly-routine*)))
+
+    SKIP))
 
 (defun emit-lea (target source disp)
   (if (eql disp 0)
@@ -1286,7 +1292,8 @@
   ;; Not much of an advantage, but why not.
   (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
   ;; Note that DST conflicts with RESULT because we use both as temps
-  (:temporary (:sc unsigned-reg) value dst)
+  (:temporary (:sc unsigned-reg :offset rax-offset) dst)
+  (:temporary (:sc unsigned-reg) value)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
@@ -1307,9 +1314,28 @@
       (instrument-alloc +cons-primtype+ rcx node (list value dst) thread-tn))
     (pseudo-atomic (:elide-if (node-stack-allocate-p node) :thread-tn thread-tn)
        ;; Produce an untagged pointer into DST
-       (if (node-stack-allocate-p node)
+      (cond
-           (stack-allocation rcx 0 dst)
+        ((node-stack-allocate-p node)
-           (allocation +cons-primtype+ rcx 0 dst node value thread-tn
+         (stack-allocation rcx 0 dst))
+        (t
+         ;; TODO: There could be no reason not to stuff this entire thing
+         ;; into an assembly routine. "unfolding" it into its constituent
+         ;; steps as done here may not be a win.
+         (let ((fallback (gen-label)) (linear (gen-label)))
+           ;; Try to get space for contiguous conses, the number of bytes being in RCX.
+           (jump-if-not-bitmap-alloc LINEAR)
+           (invoke-asm-routine 'call 'bitmap-reserve-&rest node)
+           ;; Result is in RAX, with ZF set on failure.
+           (inst jmp :nz CONTINUE)
+           (jump-if-bitmap-alloc FALLBACK)
+           (assemble (:elsewhere)
+             (emit-label fallback)
+             (move dst context) ; dst = RAX
+             (invoke-asm-routine 'call 'bitmap-listify node)
+             (move result dst)
+             (inst jmp LEAVE-PA))
+           (emit-label linear)
+           (gengc-alloc +cons-primtype+ rcx 0 dst node value thread-tn
                        :overflow
                        (lambda ()
                          (inst push rcx)
@@ -1318,7 +1344,8 @@
                           'call (if (system-tlab-p 0 node) 'sys-listify-&rest 'listify-&rest)
                           node)
                          (inst pop result)
-                         (inst jmp leave-pa))))
+                         (inst jmp LEAVE-PA))))))
+      CONTINUE
        ;; Recalculate DST as a tagged pointer to the last cons
        (inst lea dst (ea (- list-pointer-lowtag (* cons-size n-word-bytes)) dst rcx))
        (inst shr :dword rcx (1+ word-shift)) ; convert bytes to number of cells
@@ -1341,6 +1368,8 @@
        (inst inc rcx) ; :QWORD because it's a signed number
        (inst jmp :nz loop)
        LEAVE-PA)
+    ;; This label is branched to only if there were no &REST args
+    ;; and we never entered a pseudo-atomic section.
     DONE))
 
 ;;; Return the location and size of the &MORE arg glob created by
@@ -1382,6 +1411,15 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 3
+#|
+    ;; See if SML# collector has asked us to run a little bit
+    ;; (to be replaced by POSIX signal, but for now, no signals)
+    (inst mov temp (ea (make-fixup "sml_check_flag" :foreign-dataref)))
+    (inst test :dword (ea temp) -1)
+    (inst jmp :z SKIP)
+    (invoke-asm-routine 'call 'gc-cooperate vop)
+    SKIP
+|#
     ;; NOTE: copy-more-arg expects this to issue a CMP for min > 1
     (let ((err-lab
             (generate-error-code vop 'invalid-arg-count-error nargs)))

src/compiler/x86-64/cell.lisp

@@ -24,6 +24,7 @@
   #-ubsan (:ignore name)
   (:results (result :scs (descriptor-reg any-reg)))
   (:generator 1
+   (check-alivep object lowtag)
    (cond #+ubsan
          ((member name '(sb-c::vector-length %array-fill-pointer)) ; half-sized slot
           (inst mov :dword result (vector-len-ea object)))
@@ -42,6 +43,7 @@
   (:arg-refs args)
   (:temporary (:sc unsigned-reg) val-temp)
   (:generator 1
+    (check-alivep object lowtag)
     (cond #+ubsan
           ((and (eql offset sb-vm:array-fill-pointer-slot) ; half-sized slot
                 (or (eq name 'make-array)
@@ -56,9 +58,15 @@
            ;; But funcallable-instances are on PAGE_TYPE_CODE, and code pages do not use
            ;; MMU-based protection regardless of this feature.
            ;; So we have to alter the card mark differently.
+           (inst lea val-temp (object-slot-ea object offset lowtag))
+           (inst push value)
+           (inst push val-temp)
+           (inst push object)
+           (invoke-asm-routine 'call 'set-funinstance-ref vop)
+           #+nil
            (pseudo-atomic ()
              (emit-code-page-gengc-barrier object val-temp)
-             (emit-store (object-slot-ea object offset lowtag) value val-temp)))
+             (emit-store vop t object (object-slot-ea object offset lowtag) value val-temp)))
           (t
            (let* ((value-tn (tn-ref-tn (tn-ref-across args)))
                   (prim-type (sb-c::tn-primitive-type value-tn))
@@ -73,7 +81,10 @@
                        (eq name :allocator)
                        (sb-c::set-slot-old-p node)))
                (emit-gengc-barrier object nil val-temp (vop-nth-arg 1 vop) value)))
-           (emit-store (object-slot-ea object offset lowtag) value val-temp)))))
+           (emit-store vop
+                       (neq (fourth (vop-codegen-info vop)) :pseudo-atomic)
+                       object (object-slot-ea object offset lowtag)
+                       value val-temp)))))
 
 (define-vop (compare-and-swap-slot)
   (:args (object :scs (descriptor-reg) :to :eval)
@@ -89,9 +100,10 @@
   (:results (result :scs (descriptor-reg any-reg)))
   (:vop-var vop)
   (:generator 5
+     (check-alivep object lowtag)
      (emit-gengc-barrier object nil rax (vop-nth-arg 2 vop) new)
-     (move rax old)
+     (emit-cmpxchg vop t object (ea (- (* offset n-word-bytes) lowtag) object)
-     (inst cmpxchg :lock (ea (- (* offset n-word-bytes) lowtag) object) new)
+                   old new rax)
      (move result rax)))
 
 ;;;; symbol hacking VOPs
@@ -114,11 +126,18 @@
   (:temporary (:sc unsigned-reg) val-temp)
   (:vop-var vop)
   (:generator 4
+    (check-alivep symbol other-pointer-lowtag)
     (emit-symbol-write-barrier symbol nil val-temp (vop-nth-arg 1 vop) value)
-    (emit-store (if (sc-is symbol immediate)
+    (let* ((imm-value-p
+            (if (sc-is symbol immediate)
+                (csubtypep (info :variable :type (tn-value symbol))
+                           (specifier-type '(or fixnum boolean)))))
+           (possible-pointerp (not imm-value-p)))
+      (emit-store vop possible-pointerp symbol
+                  (if (sc-is symbol immediate)
                       (symbol-slot-ea (tn-value symbol) symbol-value-slot)
                       (object-slot-ea symbol symbol-value-slot other-pointer-lowtag))
-                  value val-temp)))
+                  value val-temp))))
 
 ;;; This does not resolve the TLS-INDEX at load-time, because we don't want to
 ;;; waste TLS indices for symbols that may never get thread-locally bound.
@@ -161,34 +180,40 @@
   #+gs-seg (:temporary (:sc unsigned-reg) thread-temp)
   (:vop-var vop)
   (:generator 4
-    (if (and (sc-is symbol immediate)
+    (when (and (sc-is symbol immediate)
-             (eq (info :variable :wired-tls (tn-value symbol)) :always-thread-local))
+               (eq (info :variable :wired-tls (tn-value symbol)) :always-thread-local))
-        ;; We never need the GC barrier for TLS.  I think it would be preferable
+      ;; We never need the generational GC barrier or CMS GC barrier for TLS stores.
-        ;; to resolve this in IR1, maybe turning it into SET-TLS-VALUE.
+      ;; I think it would be preferable to resolve this in IR1, maybe turning it into SET-TLS-VALUE.
-        (emit-store (ea (make-fixup (tn-value symbol) :symbol-tls-index) thread-tn)
+      (emit-store vop nil symbol
-                      value val-temp)
+                  (ea (make-fixup (tn-value symbol) :symbol-tls-index) thread-tn)
-        (let ((store (gen-label)))
+                  value val-temp)
-          (cond ((and (sc-is symbol immediate)
+      (return-from set))
-                      (info :variable :wired-tls (tn-value symbol)))
+    (cond ((and (sc-is symbol immediate)
-                 ;; The TLS index is arbitrary but known to be nonzero,
+                (info :variable :wired-tls (tn-value symbol)))
-                 ;; so we can resolve the displacement of the thread-local value
+           ;; The TLS index is arbitrary but known to be nonzero,
-                 ;; at load-time, saving one instruction over the general case.
+           ;; so we can resolve the displacement of the thread-local value
-                 (inst lea cell (ea (make-fixup (tn-value symbol) :symbol-tls-index)
+           ;; at load-time, saving one instruction over the general case.
-                                    thread-tn)))
+           (inst lea cell (ea (make-fixup (tn-value symbol) :symbol-tls-index)
-                (t
+                              thread-tn)))
-                 ;; These MOVs look the same, but when the symbol is immediate, this is
+          (t
-                 ;; a load from an absolute address. Needless to say, the names of these
+           ;; These MOVs look the same, but when the symbol is immediate, this is
-                 ;; accessor macros are arbitrary - the difference is not very apparent.
+           ;; a load from an absolute address. Needless to say, the names of these
-                 (inst mov :dword cell (if (sc-is symbol immediate)
+           ;; accessor macros are arbitrary - the difference is not very apparent.
-                                           (symbol-tls-index-ea symbol)
+           (inst mov :dword cell (if (sc-is symbol immediate)
-                                           (tls-index-of symbol)))
+                                     (symbol-tls-index-ea symbol)
-                 (inst add cell thread-tn)))
+                                     (tls-index-of symbol)))
-          (inst cmp :qword (ea cell) no-tls-value-marker)
+           (inst add cell thread-tn)))
-          (inst jmp :ne STORE)
+    (inst cmp :qword (ea cell) no-tls-value-marker)
-          (emit-symbol-write-barrier symbol nil val-temp (vop-nth-arg 1 vop) value)
+    (inst jmp :e GLOBAL)
-          (get-symbol-value-slot-ea cell symbol)
+    (emit-store vop nil symbol (ea cell) value val-temp)
-          (emit-label STORE)
+    (inst jmp DONE)
-          (emit-store (ea cell) value val-temp)))))
+    GLOBAL
+    ;; gencgc barrier
+    (emit-symbol-write-barrier symbol nil val-temp (vop-nth-arg 1 vop) value)
+    ;; concurrent barrier store
+    (emit-store vop t symbol (object-slot-ea symbol symbol-value-slot other-pointer-lowtag)
+      value val-temp)
+    DONE))
 
 (define-vop (fast-symbol-global-value)
   (:args (object :scs (descriptor-reg immediate)))
@@ -230,11 +255,7 @@
              `(thread-tls-ea (load-time-tls-offset ,sym)))
            (symbol-value-slot-ea (sym) ; SYM is a TN
              `(ea (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)
-                  ,sym))
+                  ,sym)))
-           (load-oldval ()
-             `(if (sc-is old immediate)
-                  (inst mov rax (encode-value-if-immediate old))
-                  (move rax old))))
 
 (define-vop (%cas-symbol-global-value)
     (:translate %cas-symbol-global-value)
@@ -248,12 +269,13 @@
     (:policy :fast-safe)
     (:vop-var vop)
     (:generator 10
+      (check-alivep symbol other-pointer-lowtag)
       (emit-symbol-write-barrier symbol nil rax (vop-nth-arg 2 vop) new)
-      (load-oldval)
+      (emit-cmpxchg vop t symbol
-      (inst cmpxchg :lock (if (sc-is symbol immediate)
+                    (if (sc-is symbol immediate)
-                              (symbol-slot-ea (tn-value symbol) symbol-value-slot)
+                        (symbol-slot-ea (tn-value symbol) symbol-value-slot)
-                              (symbol-value-slot-ea symbol))
+                        (symbol-value-slot-ea symbol))
-            new)
+                    old new rax)
       (move result rax)))
 
 (define-vop (%compare-and-swap-symbol-value)
@@ -276,6 +298,7 @@
     ;; Even worse: don't supply old=NO-TLS-VALUE with a symbol whose
     ;; tls-index=0, because that would succeed, assigning NEW to each
     ;; symbol in existence having otherwise no thread-local value.
+      (check-alivep symbol other-pointer-lowtag)
       #+sb-thread (progn
       (inst mov :dword cell (if (sc-is symbol immediate)
                                 (symbol-tls-index-ea symbol)
@@ -287,8 +310,7 @@
       (emit-symbol-write-barrier symbol nil cell (vop-nth-arg 2 vop) new)
       (get-symbol-value-slot-ea cell symbol)
       CAS
-      (load-oldval)
+      (emit-cmpxchg vop t symbol (ea cell) old new rax)
-      (inst cmpxchg :lock (ea cell) new)
       ;; FIXME: if :ALWAYS-BOUND then elide the BOUNDP check.
       ;; But we don't accept a constant or immediate, so how to know
       ;; what symbol is being CASed? I kind of feel like whether to perform
@@ -544,17 +566,24 @@
   (:args (function :scs (descriptor-reg) :target result)
          (fdefn :scs (descriptor-reg)))
   (:temporary (:sc unsigned-reg) raw)
+  ;(:temporary (:sc unsigned-reg) temp)
   (:results (result :scs (descriptor-reg)))
+  (:vop-var vop)
   (:generator 38
-    (emit-gengc-barrier fdefn nil raw)
     (inst mov raw (make-fixup 'closure-tramp :assembly-routine))
-    (inst cmp :byte (ea (- fun-pointer-lowtag) function)
+    (inst cmp :byte (ea (- fun-pointer-lowtag) function) simple-fun-widetag)
-          simple-fun-widetag)
     (inst cmov :e raw
           (ea (- (* simple-fun-self-slot n-word-bytes) fun-pointer-lowtag) function))
-    (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
+    (inst push raw)
-    (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+    (inst push function)
+    (inst push fdefn)
+    (invoke-asm-routine 'call 'set-fdefn-fun vop)
+    ;(emit-store vop t fdefn (object-slot-ea fdefn fdefn-fun-slot other-pointer-lowtag)
+    ;            function temp)
+    ;(emit-store vop t fdefn (object-slot-ea fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+    ;            raw temp 'raw-addr)
     (move result function)))
+
 #+immobile-code
 (progn
 (define-vop (set-direct-callable-fdefn-fun)
@@ -777,12 +806,19 @@
          (value :scs (any-reg descriptor-reg)))
   (:arg-types * tagged-num *)
   (:temporary (:sc unsigned-reg) val-temp)
+  (:vop-var vop)
   (:generator 4
    (let ((ea (ea (- (* funcallable-instance-info-offset n-word-bytes) fun-pointer-lowtag)
                  object index (index-scale n-word-bytes index))))
+     (inst lea val-temp ea)
+     (inst push value)
+     (inst push val-temp)
+     (inst push object)
+     (invoke-asm-routine 'call 'set-funinstance-ref vop)
+     #+nil
      (pseudo-atomic ()
        (emit-code-page-gengc-barrier object val-temp)
-       (emit-store ea value val-temp))))))
+       (emit-store vop t object ea value val-temp))))))
 
 (define-vop (closure-ref)
   (:args (object :scs (descriptor-reg)))
@@ -796,7 +832,6 @@
          (value :scs (descriptor-reg any-reg)))
   (:info offset dx)
   (:vop-var vop)
-  ;; temp is wasted if we don't need a barrier, which we almost never do
   (:temporary (:sc unsigned-reg) temp)
   (:generator 4
     (unless dx
@@ -806,7 +841,11 @@
         (when (and (not (singleton-p scs))
                    (member descriptor-reg-sc-number scs))
           (emit-gengc-barrier object nil temp (vop-nth-arg 1 vop) value))))
-    (storew value object (+ closure-info-offset offset) fun-pointer-lowtag)))
+    (emit-store vop
+                (and (not dx) (neq (third (vop-codegen-info vop)) :pseudo-atomic))
+                object
+                (object-slot-ea object (+ closure-info-offset offset) fun-pointer-lowtag)
+                value temp)))
 
 (define-vop (closure-init-from-fp)
   (:args (object :scs (descriptor-reg)))
@@ -858,14 +897,24 @@
 ;;; all the more so if we are permitted to optimize the slot order of the defstruct
 ;;; by putting all tagged slots together, then all raw slots together.
 ;;;
-(define-vop (instance-set-multiple)
+;;; TODO: for cmsgc emit:
+;;;   begin pseudo-atomic
+;;;   if barrier on go slow-path
+;;;   emit-store ...
+;;;   end-pseudo-atomic
+;;; slow-path:
+;;;   end-pseudo-atomic
+;;;   emit-store-slow ...
+#+nil (define-vop (instance-set-multiple)
   (:args (instance :scs (descriptor-reg))
          (values :more t :scs (descriptor-reg constant immediate)))
   (:temporary (:sc unsigned-reg) val-temp)
   ;; Would like to try to store adjacent 0s (and/or NILs) using 16 byte stores.
   (:temporary (:sc int-sse-reg) xmm-temp)
   (:info indices)
+  (:vop-var vop)
   (:generator 1
+    (error "Should not get here")
     (let* ((max-index (reduce #'max indices))
            ;;(min-index (reduce #'min indices))
            ;;(count (length indices))
@@ -917,7 +966,7 @@
             (inst mov val-temp val)
             (inst mov ea val-temp))
            (t
-            (emit-store ea val val-temp)))
+            (emit-store vop t instance ea val val-temp)))
          (unless indices (return)))))
     (aver (not values))))
 
@@ -1061,6 +1110,7 @@
   (move rdx old-hi)
   (move rbx new-lo)
   (move rcx new-hi)
+  ;; FIXME: needs help for concurrent GC
   (inst cmpxchg16b :lock memory-operand)
   ;; RDX:RAX hold the actual old contents of memory.
   ;; Manually analyze result lifetimes to avoid clobbering.

src/compiler/x86-64/float.lisp

@@ -174,8 +174,9 @@
   (:node-var node)
   (:note "float to pointer coercion")
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 13
-     (alloc-other double-float-widetag double-float-size y node nil thread-tn)
+     (alloc-other double-float-widetag double-float-size y node (list temp temp2) thread-tn)
      (inst movsd (ea-for-df-desc y) x)))
 (define-move-vop move-from-double :move
   (double-reg) (descriptor-reg))
@@ -185,8 +186,9 @@
   (:temporary (:sc unsigned-reg) bits)
   (:node-var node)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 3
-     (alloc-other double-float-widetag double-float-size copy node nil thread-tn)
+     (alloc-other double-float-widetag double-float-size copy node (list temp temp2) thread-tn)
      (loadw bits x double-float-value-slot other-pointer-lowtag)
      (storew bits copy double-float-value-slot other-pointer-lowtag)))
 
@@ -239,8 +241,10 @@
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
   (:note "complex float to pointer coercion")
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 13
-     (alloc-other complex-single-float-widetag complex-single-float-size y node nil thread-tn)
+     (alloc-other complex-single-float-widetag complex-single-float-size y node
+                  (list temp temp2) thread-tn)
      (inst movlps (ea-for-csf-data-desc y) x)))
 (define-move-vop move-from-complex-single :move
   (complex-single-reg) (descriptor-reg))
@@ -251,8 +255,10 @@
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
   (:note "complex float to pointer coercion")
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 13
-     (alloc-other complex-double-float-widetag complex-double-float-size y node nil thread-tn)
+     (alloc-other complex-double-float-widetag complex-double-float-size y node
+                  (list temp temp2) thread-tn)
      (inst movapd (ea-for-cdf-data-desc y) x)))
 (define-move-vop move-from-complex-double :move
   (complex-double-reg) (descriptor-reg))

src/compiler/x86-64/insts.lisp

@@ -23,7 +23,7 @@
   #+sb-simd-pack-256
   (import '(sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg))
   (import '(sb-vm::tn-byte-offset sb-vm::tn-reg sb-vm::reg-name
-            sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn
+            sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn sb-vm::rsp-tn
             sb-vm::gpr-tn-p sb-vm::stack-tn-p sb-c::tn-reads sb-c::tn-writes
             sb-vm::ymm-reg
             sb-vm::registers sb-vm::float-registers sb-vm::stack))) ; SB names

src/compiler/x86-64/macros.lisp

@@ -13,6 +13,11 @@
 
 ;;;; instruction-like macros
 
+(defun cons-stats-v ()
+  (+ (static-data-collection-vector)
+     (ash vector-data-offset word-shift)
+     (- other-pointer-lowtag)))
+
 ;;; This used to be a macro (and still is on the other platforms) but
 ;;; the support for SC-dependent move instructions needed here makes
 ;;; that expand into so large an expression that the resulting code
@@ -107,8 +112,8 @@
 
 ;;; assert that alloc-region->free_pointer and ->end_addr can be accessed
 ;;; using a single byte displacement from thread-tn
-(eval-when (:compile-toplevel)
+#+nil(eval-when (:compile-toplevel)
-  (aver (<= (1+ thread-boxed-tlab-slot) 15))
+  ;(aver (<= (1+ thread-boxed-tlab-slot) 15))
   (aver (<= (1+ thread-mixed-tlab-slot) 15))
   (aver (<= (1+ thread-cons-tlab-slot) 15)))
 
@@ -217,31 +222,53 @@
              #+(and sb-thread (not gs-seg)) 'thread-tn
              #-(and sb-thread (not gs-seg)) 'rbp-tn))
   (defun emit-begin-pseudo-atomic ()
-    #-sb-safepoint (inst mov (pa-bits-ea) (nonzero-bits)))
+    #-sb-safepoint (inst mov (pa-bits-ea) (nonzero-bits))
+    #+nil
+    (progn (let ((foo (gen-label)))
+             (inst mov (pa-bits-ea) (nonzero-bits))
+             (inst call foo)
+             (emit-label foo)
+             (inst pop (thread-slot-ea thread-et-bzeroing-slot)))))
+
   (defun emit-end-pseudo-atomic ()
     #+sb-safepoint (emit-safepoint)
     #-sb-safepoint
     (assemble ()
+      ;(inst mov :qword (thread-slot-ea thread-et-bzeroing-slot) 0)
       (inst xor (pa-bits-ea) (nonzero-bits))
       (inst jmp :z OUT)
       ;; if PAI was set, interrupts were disabled at the same time
       ;; using the process signal mask.
       #+int1-breakpoints (inst icebp)
       #-int1-breakpoints (inst break pending-interrupt-trap)
-      OUT)))
+      OUT
+      )))
 
 ;;; This macro is purposely unhygienic with respect to THREAD-TN,
 ;;; which is either a global symbol macro, or a LET-bound variable,
 ;;; depending on #+gs-seg.
-(defmacro pseudo-atomic ((&key ((:thread-tn thread)) elide-if (default-exit t))
+(defvar *in-pseudoatomic* nil)
+(defmacro pseudo-atomic ((&key ((:thread-tn thread)) elide-if (default-exit t) (sml-check t))
                          &body forms)
-  (declare (ignorable thread))
+  (declare (ignorable thread sml-check))
   `(macrolet ((exit-pseudo-atomic () '(emit-end-pseudo-atomic)))
      (unless ,elide-if
        (emit-begin-pseudo-atomic))
-     (assemble () ,@forms)
+     (let ((*in-pseudoatomic* t)) (assemble () ,@forms))
      (when (and ,default-exit (not ,elide-if))
-       (exit-pseudo-atomic))))
+       (exit-pseudo-atomic)
+       #+nil
+       (when ,sml-check
+         (assemble ()
+           (inst test :byte (static-symbol-value-ea '*sml-check-flag*) 2)
+           (inst jmp :z NO-PHASE-CHANGE)
+           (inst call (ea (make-fixup 'gc-check :assembly-routine*)))
+           NO-PHASE-CHANGE
+           (inst cmp :qword (static-symbol-value-ea '*n-malloc-segments-to-release*) 0)
+           (inst jmp :z NO-RELEASE-MEM)
+           (inst call (ea (make-fixup 'release-malloc-segments :assembly-routine*)))
+           NO-RELEASE-MEM
+           )))))
 
 ;;;; indexed references
 
@@ -261,10 +288,63 @@
                           (* max-offset sb-vm:n-word-bytes))
                        scale)))
 
+(defun bignum-index-check (bignum index addend vop)
+  (declare (ignore bignum index addend vop))
+  ;; Conditionally compile this in to sanity-check the bignum logic
+  #+nil
+  (let ((ok (gen-label)))
+    (cond ((and (tn-p index) (not (constant-tn-p index)))
+           (aver (sc-is index any-reg))
+           (inst lea :dword temp-reg-tn (ea (fixnumize addend) index))
+           (inst shr :dword temp-reg-tn n-fixnum-tag-bits))
+          (t
+           (inst mov temp-reg-tn (+ (if (tn-p index) (tn-value index) index) addend))))
+    (inst cmp :dword temp-reg-tn (ea (- 1 other-pointer-lowtag) bignum))
+    (inst jmp :b ok)
+    (inst break halt-trap)
+    (emit-label ok)))
+
+;;; used for: INSTANCE-INDEX-SET %CLOSURE-INDEX-SET
+;;;           SB-BIGNUM:%BIGNUM-SET %SET-ARRAY-DIMENSION %SET-VECTOR-RAW-BITS
+(defmacro define-full-setter (name type offset lowtag scs el-type translate)
+  (let ((barrierp (case name
+                    (%closure-index-set '(not (sc-is value any-reg)))
+                    ((instance-index-set #|%weakvec-set|#)
+                     '(or (not (sc-is index immediate))
+                       (slot-type-requires-gcbarrier args (tn-value index))))
+                    (%weakvec-set :weak))))
+    `(define-vop (,name)
+       (:translate ,translate)
+       (:arg-refs args)
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+              (index :scs (any-reg immediate signed-reg unsigned-reg))
+              (value :scs ,scs))
+       (:arg-types ,type tagged-num ,el-type)
+       (:vop-var vop)
+       (:temporary (:sc unsigned-reg) val-temp)
+       (:arg-refs args)
+       (:generator 4
+         ,@(when (eq translate 'sb-bignum:%bignum-set)
+             '((bignum-index-check object index 0 vop)))
+         (let ((ea (if (sc-is index immediate)
+                       (ea (- (* (+ ,offset (tn-value index)) n-word-bytes) ,lowtag)
+                           object)
+                       (ea (- (* ,offset n-word-bytes) ,lowtag)
+                           object index (index-scale n-word-bytes index)))))
+           ,@(when (member name '(instance-index-set %closure-index-set %weakvec-set))
+               '((emit-gengc-barrier object nil val-temp (vop-nth-arg 2 vop) value)))
+           (emit-store vop ,barrierp object ea value val-temp))))))
+
 (defmacro define-full-compare-and-swap
     (name type offset lowtag scs el-type &optional translate)
-  `(progn
+  (let ((barrierp (case name
-     (define-vop (,name)
+                    (%instance-cas
+                     '(or (not (sc-is index immediate))
+                          (slot-type-requires-gcbarrier args (tn-value index))))
+                    (%compare-and-swap-svref t)
+                    (t nil))))
+  `(define-vop (,name)
        (:translate ,translate)
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg) :to :eval)
@@ -282,6 +362,7 @@
                         #|:from (:argument 2)|# :to :result :target value)  rax)
        (:results (value :scs ,scs))
        (:result-types ,el-type)
+       (:arg-refs args)
        (:generator 5
          (let ((ea (ea (- (* (+ (if (sc-is index immediate) (tn-value index) 0) ,offset)
                          n-word-bytes)
@@ -297,26 +378,14 @@
                 ;; store barrier affects only the object's base address
                 '((emit-gengc-barrier object nil rax (vop-nth-arg 3 vop) new-value)))
                ((%raw-instance-cas/word %raw-instance-cas/signed-word)))
-           (move-immediate rax (encode-value-if-immediate old-value ,(and (memq 'any-reg scs) t)))
+           ,(if barrierp ; the s-expression is non-nil though may eval to nil
-           (inst cmpxchg :lock ea new-value)
+                `(emit-cmpxchg vop ,barrierp object ea old-value new-value rax)
+                `(progn
+                   (move-immediate rax
+                    (encode-value-if-immediate old-value ,(and (memq 'any-reg scs) t)))
+                   (inst cmpxchg :lock ea new-value)))
            (move value rax))))))
 
-(defun bignum-index-check (bignum index addend vop)
-  (declare (ignore bignum index addend vop))
-  ;; Conditionally compile this in to sanity-check the bignum logic
-  #+nil
-  (let ((ok (gen-label)))
-    (cond ((and (tn-p index) (not (constant-tn-p index)))
-           (aver (sc-is index any-reg))
-           (inst lea :dword temp-reg-tn (ea (fixnumize addend) index))
-           (inst shr :dword temp-reg-tn n-fixnum-tag-bits))
-          (t
-           (inst mov temp-reg-tn (+ (if (tn-p index) (tn-value index) index) addend))))
-    (inst cmp :dword temp-reg-tn (ea (- 1 other-pointer-lowtag) bignum))
-    (inst jmp :b ok)
-    (inst break halt-trap)
-    (emit-label ok)))
-
 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
   `(progn
      (define-vop (,name)
@@ -408,27 +477,3 @@
          (let ((ea (ea (- (* (+ ,offset index addend) n-word-bytes) ,lowtag) object)))
            ,@(trap '(emit-constant (+ index addend)))
            (inst mov value ea)))))))
-
-;;; used for: INSTANCE-INDEX-SET %CLOSURE-INDEX-SET
-;;;           SB-BIGNUM:%BIGNUM-SET %SET-ARRAY-DIMENSION %SET-VECTOR-RAW-BITS
-(defmacro define-full-setter (name type offset lowtag scs el-type translate)
-  `(define-vop (,name)
-       (:translate ,translate)
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-              (index :scs (any-reg immediate signed-reg unsigned-reg))
-              (value :scs ,scs))
-       (:arg-types ,type tagged-num ,el-type)
-       (:vop-var vop)
-       (:temporary (:sc unsigned-reg) val-temp)
-       (:generator 4
-         ,@(when (eq translate 'sb-bignum:%bignum-set)
-             '((bignum-index-check object index 0 vop)))
-         (let ((ea (if (sc-is index immediate)
-                       (ea (- (* (+ ,offset (tn-value index)) n-word-bytes) ,lowtag)
-                           object)
-                       (ea (- (* ,offset n-word-bytes) ,lowtag)
-                           object index (index-scale n-word-bytes index)))))
-           ,@(when (member name '(instance-index-set %closure-index-set %weakvec-set))
-               '((emit-gengc-barrier object nil val-temp (vop-nth-arg 2 vop) value)))
-           (emit-store ea value val-temp)))))

src/compiler/x86-64/memory.lisp

@@ -63,28 +63,140 @@
   (inst and :dword scratch-reg card-index-mask)
   (inst mov :byte (ea gc-card-table-reg-tn scratch-reg) CARD-MARKED))
 
-(defun emit-store (ea value val-temp)
+(defun branch-if-barrier-on (where)
-  (sc-case value
+  (when *in-pseudoatomic* (error "can't emit CMS barrier if already pseudoatomic"))
-   (immediate
+  (inst cmp :byte (thread-slot-ea thread-gc-phase-slot) GC-PHASE-SYNC1)
-      (let ((bits (encode-value-if-immediate value)))
+  (let ((label (gen-label)))
-        ;; Try to move imm-to-mem if BITS fits
+    (emit-label label)
-        (acond ((or (and (fixup-p bits)
+    (push label (sb-assem::asmstream-pseudo-atomic-locs sb-assem:*asmstream*)))
-                         ;; immobile-object fixups must fit in 32 bits
+  (inst jmp :ae where))
-                         (eq (fixup-flavor bits) :immobile-symbol)
-                         bits)
-                    (plausible-signed-imm32-operand-p bits))
-                (inst mov :qword ea it))
-               (t
-                (inst mov val-temp bits)
-                (inst mov ea val-temp)))))
-   (constant
-      (inst mov val-temp value)
-      (inst mov :qword ea val-temp))
-   (t
-      (inst mov :qword ea value))))
 
-;; This vop's sole purpose is to provide the implementation of value-cell-set.
+;;; FIXME: if and when I implement SIGUSR2 as the signal to cooperate
-;; It could be removed, for x86-64 anyway.
+;;; with GC - so that we don't switch over to safepoints -
+;;; then the only instruction sequences which will be _implicitly_ pseudo-atomic
+;;; will be:
+;;;   inst cmp [phase], 2
+;;;   inst jmp :a elsewhere
+;;;   inst mov [ea], something # any number of stores
+;;; so if the interrupt handler sees that it has been interrupted in lisp code
+;;; at a mov to memory, it will emulate the mov without allowing a phase change.
+;;; It will NOT work to have either of the following:
+;;;   inst cmp [phase], 2       |  inst cmp [phase], 2
+;;;   inst jmp :a elsewhere     |  inst jmp :a elsewhere
+;;;   inst mov temp, [rip-n]    |  inst mov temp, imm        <-- interrupted here
+;;;   inst mov [ea], temp       |  inst mov [ea], temp
+;;; In this instruction sequence, if we allow the interrupt to take place,
+;;; and it changes the GC phase, then the preceding comparison answer can not be
+;;; taken as correct. Perhaps we should have branched to the fallback code to
+;;; perform a barrier, but we did not, because the phase looked like it was ASYNC.
+;;; Somehow the GC phase has to be examined just before performing the store.
+;;;
+(defun emit-store (vop barrierp object ea value val-temp
+                   &optional slot-name
+                   &aux (asm-routine
+                         (case barrierp
+                           (:weak 'weak-vector-set)
+                           (:untagged 'gc-barrier-store-untagged)
+                           (t 'gc-barrier-store)))
+                   notinline done)
+  (declare (type (member t nil :weak :untagged) barrierp))
+  (declare (ignorable slot-name))
+
+  (when (and barrierp (stack-consed-p object))
+    ;; barriers do not pertain to stack objects
+    (setq barrierp nil))
+  #+smlgc-telemetry
+  (inst inc :qword (thread-slot-ea (if (stack-consed-p object)
+                                       thread-ct-stack-obj-stores-slot
+                                       thread-ct-heap-obj-stores-slot)))
+  (labels ((imm (operation)
+             (let ((bits (encode-value-if-immediate value)))
+               ;; Try to move imm-to-mem if BITS fits
+               (acond ((or (and (fixup-p bits)
+                                ;; immobile-object fixups must fit in 32 bits
+                                (eq (fixup-flavor bits) :immobile-symbol)
+                                bits)
+                           (plausible-signed-imm32-operand-p bits))
+                       (if (eq operation 'push)
+                           (inst push it) ; real good
+                           (progn (barrier)
+                                  (inst mov :qword ea it))))
+                      (t
+                       (inst mov val-temp bits)
+                       (if (eq operation 'push)
+                           (inst push val-temp)
+                           (progn (barrier)
+                                  (inst mov ea val-temp)))))))
+           (barrier ()
+             (when barrierp
+               (branch-if-barrier-on (setq notinline (gen-label))))))
+    (when (eq barrierp :weak) ; always call C
+      (if (sc-is value immediate) (imm 'push) (inst push value))
+      (inst lea val-temp ea)
+      (inst push val-temp)
+      (inst push (encode-value-if-immediate object))
+      (invoke-asm-routine 'call asm-routine vop)
+      (return-from emit-store))
+    (sc-case value
+     (immediate (imm 'store))
+     (constant
+      (inst mov val-temp value)
+      (barrier)
+      (inst mov :qword ea val-temp))
+     (t
+      (barrier)
+      (inst mov :qword ea value)))
+    (when barrierp
+      (emit-label (setq done (gen-label)))
+      (assemble (:elsewhere)
+        (emit-label NOTINLINE)
+        (if (sc-is value immediate) (imm 'push) (inst push value))
+        (inst lea val-temp ea)
+        (inst push val-temp)
+        (inst push (encode-value-if-immediate object))
+        (invoke-asm-routine 'call asm-routine vop)
+        (inst jmp DONE)))))
+
+;;; RAX is loaded with the expected oldval. Return from the slow path
+;;; is the same as if by the fast path (actual oldval is in RAX)
+(defun emit-cmpxchg (vop barrierp object ea old new rax
+                     &aux (asm-routine
+                           (if (eq barrierp :untagged)
+                               'gc-barrier-cmpxchg-untagged
+                               'gc-barrier-cmpxchg))
+                           (notinline (gen-label)))
+  (unless barrierp
+    (inst mov rax (encode-value-if-immediate old))
+    (inst cmpxchg :lock ea new)
+    (return-from emit-cmpxchg))
+  (assemble ()
+    ;; optimistically assume we're taking the fast path
+    (inst mov rax (encode-value-if-immediate old))
+    (branch-if-barrier-on NOTINLINE)
+    (inst cmpxchg :lock ea new)
+    DONE
+    (assemble (:elsewhere)
+      (emit-label NOTINLINE)
+      (inst push new)
+      (inst lea rax ea)
+      (inst push rax)
+      (inst push (encode-value-if-immediate object))
+      (inst mov rax (encode-value-if-immediate old))
+      (invoke-asm-routine 'call asm-routine vop)
+      (inst jmp done))))
+
+;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the
+;;; offset to be read or written is a property of the VOP used.
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (check-alivep object lowtag)
+    (loadw value object offset lowtag)))
+;; This vop's sole purpose is to be an ancestor for other vops, to assign
+;; default operands, policy, and generator.
 (define-vop (cell-set)
   (:args (object :scs (descriptor-reg))
          (value :scs (descriptor-reg any-reg immediate)))
@@ -93,9 +205,9 @@
   (:temporary (:sc unsigned-reg) val-temp)
   (:vop-var vop)
   (:generator 4
+    (check-alivep object lowtag)
     (emit-gengc-barrier object nil val-temp (vop-nth-arg 1 vop) value)
-    (let ((ea (object-slot-ea object offset lowtag)))
+    (emit-store vop t object (object-slot-ea object offset lowtag) value val-temp)))
-      (emit-store ea value val-temp))))
 
 ;;; X86 special
 (define-vop (cell-xadd)
@@ -286,3 +398,50 @@
   ;; It wants a function, not a symbol
   (setf (sb-c::vop-info-optimizer (template-or-lose name))
         (lambda (vop) (sb-c::elide-zero-fill vop))))
+
+;; Placeholders until non-STW GC becomes a reality
+#+weak-vector-readbarrier
+(progn
+  (define-full-setter %weakvec-set * vector-data-offset other-pointer-lowtag
+    (any-reg descriptor-reg) * %weakvec-set)
+
+  (define-vop (%weakvec-ref)
+    (:translate %weakvec-ref)
+    (:policy :fast-safe)
+    (:args (object :scs (descriptor-reg))
+           (index :scs (any-reg signed-reg unsigned-reg)))
+    (:arg-types * tagged-num)
+    (:results (value :scs (descriptor-reg)))
+    (:result-types *)
+(:temporary (:sc unsigned-reg) junk)
+    (:vop-var vop)
+    (:generator 10
+      (pseudo-atomic ()
+        (inst mov junk (ea (make-fixup "weakrefget_ct" :foreign-dataref)))
+        (inst add :dword :lock (ea junk) 1)
+        (inst cmp :byte (thread-slot-ea thread-gc-phase-slot) GC-PHASE-ASYNC)
+        (inst jmp :e FAST)
+        (inst push object)
+        (inst push index)
+        (unless (sc-is index any-reg) (inst shl (ea rsp-tn) n-fixnum-tag-bits)) ; pass as fixnum
+        (invoke-asm-routine 'call 'weak-vector-ref vop)
+        FAST
+        (inst mov value (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+                          object index (index-scale n-word-bytes index))))))
+
+  (define-vop (%weak-pointer-value)
+    (:policy :fast-safe)
+    (:args (weakptr :scs (descriptor-reg)))
+    (:results (value :scs (descriptor-reg)))
+    (:vop-var vop)
+    (:temporary (:sc unsigned-reg) junk)
+    (:generator 10
+      (pseudo-atomic ()
+        (inst mov junk (ea (make-fixup "weakrefget_ct" :foreign-dataref)))
+        (inst add :dword :lock (ea junk) 1)
+        (inst cmp :byte (thread-slot-ea thread-gc-phase-slot) GC-PHASE-ASYNC)
+        (inst jmp :e FAST)
+        (inst push weakptr)
+        (invoke-asm-routine 'call 'weak-pointer-ref vop)
+        FAST
+        (loadw value weakptr weak-pointer-value-slot other-pointer-lowtag)))))

src/compiler/x86-64/move.lisp

@@ -78,6 +78,7 @@
   (any-reg descriptor-reg))
 
 (defun move-immediate (target val &optional tmp-tn zeroed)
+  (setq zeroed nil)
   ;; Try to emit the smallest immediate operand if the destination word
   ;; is already zeroed. Otherwise a :qword.
   (cond

src/compiler/x86-64/parms.lisp

@@ -22,12 +22,12 @@
 ;;; This size is supposed to indicate something about the actual granularity
 ;;; at which you can map memory.  We just hardwire it, but that may or may not
 ;;; be necessary any more.
-(defconstant +backend-page-bytes+ #+win32 65536 #-win32 32768)
+(defconstant +backend-page-bytes+ #+win32 65536 #-win32 4096) ; 32768)
 
 ;;; The size in bytes of GENCGC pages. A page is the smallest amount of memory
 ;;; that a thread can claim for a thread-local region, and also determines
 ;;; the granularity at which we can find the start of a sequence of objects.
-(defconstant gencgc-page-bytes 32768)
+(defconstant gencgc-page-bytes 4096) ; 32768)
 ;;; The divisor relative to page-bytes which computes the granularity
 ;;; at which writes to old generations are logged.
 #+soft-card-marks (defconstant cards-per-page

src/compiler/x86-64/sap.lisp

@@ -30,8 +30,9 @@
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:note "SAP to pointer coercion")
   (:node-var node)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 20
-    (alloc-other sap-widetag sap-size res node nil thread-tn)
+    (alloc-other sap-widetag sap-size res node (list temp temp2) thread-tn)
     (storew sap res sap-pointer-slot other-pointer-lowtag)))
 (define-move-vop move-from-sap :move
   (sap-reg) (descriptor-reg))

src/compiler/x86-64/simd-pack-256.lisp

@@ -96,8 +96,10 @@
                     (:node-var node)
                     (:arg-types ,type)
                     (:note "AVX2 to pointer coercion")
+                    (:temporary (:sc unsigned-reg) temp temp2)
                     (:generator 13
-                      (alloc-other simd-pack-256-widetag simd-pack-256-size y node nil thread-tn)
+                      (alloc-other simd-pack-256-widetag simd-pack-256-size y node
+                                   (list temp temp2) thread-tn)
                       (storew (fixnumize ,tag)
                               y simd-pack-256-tag-slot other-pointer-lowtag)
                       (let ((ea (object-slot-ea
@@ -198,8 +200,10 @@
   (:result-types t)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 13
-    (alloc-other simd-pack-256-widetag simd-pack-256-size dst node nil thread-tn)
+    (alloc-other simd-pack-256-widetag simd-pack-256-size dst node
+                 (list temp temp2) thread-tn)
     ;; see +simd-pack-element-types+
     (storew tag dst simd-pack-256-tag-slot other-pointer-lowtag)
     (storew p0 dst simd-pack-256-p0-slot other-pointer-lowtag)

src/compiler/x86-64/simd-pack.lisp

@@ -90,8 +90,10 @@
                     (:node-var node)
                     (:arg-types ,type)
                     (:note "AVX2 to pointer coercion")
+                    (:temporary (:sc unsigned-reg) temp temp2)
                     (:generator 13
-                      (alloc-other simd-pack-widetag simd-pack-size y node nil thread-tn)
+                      (alloc-other simd-pack-widetag simd-pack-size y node
+                                   (list temp temp2) thread-tn)
                       (storew (fixnumize ,tag)
                               y simd-pack-tag-slot other-pointer-lowtag)
                       (let ((ea (object-slot-ea y simd-pack-lo-value-slot other-pointer-lowtag)))
@@ -197,8 +199,9 @@
   (:result-types t)
   #+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
   (:node-var node)
+  (:temporary (:sc unsigned-reg) temp temp2)
   (:generator 13
-    (alloc-other simd-pack-widetag simd-pack-size dst node nil thread-tn)
+    (alloc-other simd-pack-widetag simd-pack-size dst node (list temp temp2) thread-tn)
       ;; see +simd-pack-element-types+
     (storew tag dst simd-pack-tag-slot other-pointer-lowtag)
     (storew lo dst simd-pack-lo-value-slot other-pointer-lowtag)

src/compiler/x86-64/target-insts.lisp

@@ -358,8 +358,13 @@
                           'list))
            (a (make-array (1+ (slot-offset (car (last slots))))
                           :initial-element nil)))
-      (dolist (slot slots a)
+      (dolist (slot slots)
-        (setf (aref a (slot-offset slot)) (slot-name slot)))))
+        (setf (aref a (slot-offset slot)) (slot-name slot)))
+      (let ((i sb-vm::thread-ap4-slot))
+        (setf (aref a i) "ap4.freebit.ptr"
+              (aref a (+ i 1)) "ap4.freebit.mask"
+              (aref a (+ i 2)) "ap4.freeptr"))
+      a))
 
 ;;; Prints a memory reference to STREAM. VALUE is a list of
 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component may be

src/runtime/GNUmakefile

@@ -86,7 +86,12 @@ C_SRC = $(COMMON_SRC) ${ARCH_SRC} ${OS_SRC} ${GC_SRC}
 
 SRCS = $(C_SRC) ${ASSEM_SRC}
 
-OBJS = $(C_SRC:.c=.o) $(ASSEM_SRC:.S=.o) ../../tlsf-bsd/tlsf/tlsf.o
+SMLSHARPGC_OBJS = ../../smlsharpgc/control.o ../../smlsharpgc/error.o \
+ ../../smlsharpgc/heap_concurrent.o ../../smlsharpgc/lispobj.o ../../smlsharpgc/xmalloc.o
+
+../../smlsharpgc/%.o: CFLAGS+=-I../../smlsharpgc -DHAVE_GENESIS_CONFIG -DHAVE_CONFIG_H -DWITHOUT_MASSIVETHREADS
+
+OBJS = $(C_SRC:.c=.o) $(ASSEM_SRC:.S=.o) ../../tlsf-bsd/tlsf/tlsf.o $(SMLSHARPGC_OBJS)
 
 LIBS = ${OS_LIBS} $(LDLIBS) -lm
 
@@ -101,6 +106,7 @@ ldb: $(LIBSBCL)
 $(TARGET): $(LIBSBCL)
 	$(CC) ${LINKFLAGS} -o $@ $(USE_LIBSBCL) $(LIBS)
 	$(SBCL_PAXCTL) $@
+	#rm -f mylib.a ; ar cqD mylib.a $(filter-out main.o,$(USE_LIBSBCL))
 
 # tests/heap-reloc/fake-mman.c assumes #+linux, so this recipe
 # only works on linux.
@@ -178,8 +184,8 @@ TAGS tags: $(SRCS) $(HEADERS) $(INC)
 	@etags --language=c $(SRCS) $(HEADERS) $(INC) || true
 
 clean:
-	-rm -f *.[do] ../../tlsf-bsd/tlsf/tlsf.o $(TARGET) *.tmp libsbcl.a sbcl.h \
+	-rm -f *.[do] ../../tlsf-bsd/tlsf/tlsf.o ../../smlsharpgc/*.o $(TARGET) *.tmp libsbcl.a \
- ldb unit-tests libsbcl.a shrinkwrap-sbcl* sbcl.mk core
+ ldb unit-tests libsbcl.a shrinkwrap-sbcl* sbcl.mk core sbcl.h
 
 %.d: %.c sbcl.h
 	@$(CC) $(DEPEND_FLAGS) $(CPPFLAGS) $< > $@.tmp; \

src/runtime/arena.c

@@ -698,7 +698,7 @@ struct visitor {
     long nwords;
 };
 
-static void visit(lispobj obj, void* arg) {
+static void visit(__attribute__((unused)) lispobj parent, lispobj obj, void* arg) {
     struct visitor* v = arg;
     if (find_containing_arena(obj) == v->arena) v->nwords += object_size(native_pointer(obj));
 }
@@ -707,8 +707,7 @@ size_t count_arena_live_bytes(lispobj arena) {
     struct visitor v;
     v.arena = arena;
     v.nwords = 0;
-    struct grvisit_context* c =
+    struct grvisit_context* c = visit_heap_from_roots(&h, visit, &v, 0, NULL, 0);
-        visit_heap_from_static_roots(&h, visit, &v);
     hopscotch_destroy(&h);
     free(c);
     return v.nwords * N_WORD_BYTES;

src/runtime/backtrace.c

@@ -558,6 +558,8 @@ static void print_backtrace_frame(char *pc, void *fp, int i, FILE *f) {
 #endif
     struct code *code = (void*)component_ptr_from_pc(pc);
     if (code) {
+        fprintf(f, "= id %x + %x ", code_serialno(code),
+                (int)((char*)pc - (char*)code_text_start(code)));
         struct compiled_debug_fun *df = debug_function_from_pc(code, pc);
         if (df)
             print_entry_name(barrier_load(&df->name), f);
@@ -614,6 +616,9 @@ log_backtrace_from_fp(struct thread* th, void *fp, int nframes, int start, FILE
 void backtrace_from_fp(void *fp, int nframes, int start) {
     log_backtrace_from_fp(get_sb_vm_thread(), fp, nframes, start, stdout);
 }
+extern void backtrace_to_file(FILE* f) {
+    log_backtrace_from_fp(get_sb_vm_thread(), __builtin_frame_address(0), 100, 0, f);
+}
 
 void print_backtrace_from_context(os_context_t *context, int nframes, FILE* file) {
     void *fp = (void *)os_context_frame_pointer(context);
@@ -659,8 +664,11 @@ int simple_fun_index_from_pc(struct code* code, char *pc)
 static bool __attribute__((unused)) print_lisp_fun_name(char* pc)
 {
   struct code* code;
-  if (gc_managed_heap_space_p((uword_t)pc) &&
+  extern uword_t* codeblob_from_interior_ptr(void* addr);
-      (code = (void*)component_ptr_from_pc(pc)) != 0) {
+  code = (void*)codeblob_from_interior_ptr(pc);
+  if (!code && gc_managed_heap_space_p((uword_t)pc))
+    code = (void*)component_ptr_from_pc(pc);
+  if (code) {
       struct compiled_debug_fun* df = debug_function_from_pc(code, pc);
       if (df) {
           fprintf(stderr, " %p [", pc);
@@ -712,7 +720,9 @@ void libunwind_backtrace(struct thread *th, os_context_t *context)
     // In case you get no backtrace whatsoever, maybe at least see where the
     // signal was received, probably in a function without the standard
     // frame pointer setup.
-    fprintf(stderr, " interrupted @ PC %p\n", (void*)OS_CONTEXT_PC(context));
+    fprintf(stderr, " interrupted FP=%p, PC=%p\n",
+            (void*)*os_context_fp_addr(context),
+            (void*)OS_CONTEXT_PC(context));
     if (lispthread->waiting_for != NIL) {
         fprintf(stderr, "waiting for %p", (void*)lispthread->waiting_for);
         if (instancep(lispthread->waiting_for)) {
@@ -747,14 +757,19 @@ void libunwind_backtrace(struct thread *th, os_context_t *context)
     do {
         uword_t offset;
         char *pc;
-        unw_get_reg(&cursor, UNW_TDEP_IP, (uword_t*)&pc);
+        uword_t *bp, *sp;
+        unw_get_reg(&cursor, UNW_TDEP_IP, (unw_word_t*)&pc);
+        unw_get_reg(&cursor, UNW_TDEP_BP, (unw_word_t*)&bp);
+        unw_get_reg(&cursor, UNW_TDEP_SP, (unw_word_t*)&sp);
+        fprintf(stderr, " %p %p %p ", sp, bp, pc);
         if (print_lisp_fun_name(pc)) {
             // printed
         } else if (!unw_get_proc_name(&cursor, procname, sizeof procname, &offset)) {
-            fprintf(stderr, " %p [%s]\n", pc, procname);
+            fprintf(stderr, "[%s]", procname);
         } else {
-            fprintf(stderr, " %p ?\n", pc);
+            fprintf(stderr, "?");
         }
+        putc('\n', stderr);
     } while (unw_step(&cursor));
 #else
     // If you don't have libunwind, this will almost surely not work,

src/runtime/coreparse.c

@@ -234,6 +234,7 @@ struct heap_adjust {
 #include "genesis/cons.h"
 #include "genesis/hash-table.h"
 #include "genesis/vector.h"
+#include "genesis/weak-pointer.h"
 
 static inline sword_t calc_adjustment(struct heap_adjust* adj, lispobj x)
 {
@@ -1205,7 +1206,7 @@ void gc_load_corefile_ptes(int card_table_nbits,
 
     // Apply physical page protection as needed.
     // The non-soft-card-mark code is disgusting and I do not understand it.
-    if (gen != 0 && ENABLE_PAGE_PROTECTION) {
+    if (0 && gen != 0 && ENABLE_PAGE_PROTECTION) {
 #ifdef LISP_FEATURE_SOFT_CARD_MARKS
         page_index_t p;
         for (p = 0; p < next_free_page; ++p)
@@ -1258,6 +1259,32 @@ void gc_load_corefile_ptes(int card_table_nbits,
 #endif
 }
 
+int enable_async_gc = 1;
+
+static void gather_weak_objects() {
+    extern void record_weak_object(lispobj);
+    lispobj* where = (lispobj*)DYNAMIC_SPACE_START;
+    lispobj* limit = (lispobj*)dynamic_space_highwatermark();
+    int tables = 0, vectors = 0;
+    while (where < limit) {
+        switch (widetag_of(where)) {
+        case INSTANCE_WIDETAG:
+            if (layout_depth2_id(LAYOUT(instance_layout(where))) == HASH_TABLE_LAYOUT_ID
+                && hashtable_weakp(((struct hash_table*)where)))
+                ++tables, record_weak_object(make_lispobj(where, INSTANCE_POINTER_LOWTAG));
+            break;
+        case WEAK_POINTER_WIDETAG:
+            // weak pointers that aren't vectors need not be recorded
+            // since they can't point to managed space.
+            if (weakptr_vectorp((struct weak_pointer*)where))
+                ++vectors, record_weak_object(make_lispobj(where, OTHER_POINTER_LOWTAG));
+            break;
+        }
+        where += object_size(where);
+    }
+    fprintf(stderr, "coreparse: registered %d weak tables, %d weak vectors\n", tables, vectors);
+}
+
 /* '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
@@ -1333,6 +1360,8 @@ load_core_file(char *file, os_vm_offset_t file_offset, int merge_core_pages)
             process_directory(remaining_len / NDIR_ENTRY_LENGTH,
                               (struct ndir_entry*)ptr, fd, file_offset,
                               merge_core_pages, spaces, &adj);
+            // before write-protecting
+            if (use_smlgc) gather_weak_objects();
             break;
         case PAGE_TABLE_CORE_ENTRY_TYPE_CODE:
             // elements = gencgc-card-table-index-nbits, n-ptes, nbytes, data-page
@@ -1362,6 +1391,51 @@ load_core_file(char *file, os_vm_offset_t file_offset, int merge_core_pages)
                 print_generation_stats();
             }
             sanity_check_loaded_core(initial_function);
+            extern void smlgc_init(long);
+            size_t smlgc_heapsize = 4*1024*1024;
+            char* specified_heapsize = getenv("SMLGC_HEAPSIZE");
+            if (specified_heapsize) // in megabytes
+                smlgc_heapsize = atol(specified_heapsize) * 1048576;
+            // default is now asynchronous enabled
+            if (getenv("SMLGC_ASYNC") && !strcmp(getenv("SMLGC_ASYNC"),"0"))
+                enable_async_gc = 0;
+            if (use_smlgc && !specified_heapsize)
+                smlgc_heapsize = 1024*1024*1024;
+            smlgc_heapsize = ALIGN_DOWN(smlgc_heapsize, 65536);
+            //gclogfd = open("/tmp/gclog.txt", O_WRONLY|O_CREAT|O_TRUNC|O_APPEND, 0666);
+            smlgc_init(smlgc_heapsize);
+            int import_dynamic = 0;
+            if (getenv("SMLGC_IMPORT_CORE"))
+              import_dynamic = atoi(getenv("SMLGC_IMPORT_CORE"));
+            if (import_dynamic) {
+              lose("Won't import dynamic space");
+                extern lispobj import_dynamic_space(lispobj);
+                //initial_function = import_dynamic_space(initial_function);
+                if (import_dynamic == 2) {
+                  uword_t end = dynamic_space_highwatermark();
+                  // change to unallocated
+                  next_free_page = 0;
+                  munmap((char*)DYNAMIC_SPACE_START, end - DYNAMIC_SPACE_START);
+                  fprintf(stderr, "--> Unmapped gencgc dynamic space [%p:%p]\n",
+                          (char*)DYNAMIC_SPACE_START, (char*)end);
+                }
+            } else if (!import_dynamic && use_smlgc) {
+              char* unmap_from = page_address(next_free_page);
+              long unmap_len = page_address(page_table_pages) - unmap_from;
+              mprotect(unmap_from, unmap_len, PROT_NONE);
+              fprintf(stderr, "--> gencgc space [%p:%p] has PROT_NONE\n",
+                      unmap_from, page_address(page_table_pages));
+            }
+            fprintf(stderr, "R/O @ %p:%p\n",
+                    (void*)READ_ONLY_SPACE_START, read_only_space_free_pointer);
+#if 0
+            int* hint = 0;
+            lispobj sym =
+                find_symbol("*SHOW-NEW-CODE*",
+                            VECTOR(lisp_package_vector)->data[20], &hint);
+            printf("show_new_code=%lx\n", sym);
+            if(sym) SYMBOL(sym)->value = LISP_T;
+#endif
             return initial_function;
         case RUNTIME_OPTIONS_MAGIC: break; // already processed
         default:
@@ -1414,7 +1488,21 @@ void asm_routine_poke(const char* routine, int offset, char byte)
 
 static void trace_sym(lispobj, struct symbol*, struct grvisit_context*);
 
-#define RECURSE(x) if(is_lisp_pointer(x))graph_visit(ptr,x,context)
+static int reject(lispobj ptr)
+{
+    struct thread* th;
+    if (ptr >= READ_ONLY_SPACE_START && ptr < (lispobj)read_only_space_free_pointer)
+        return 1;
+    for_each_thread(th) {
+      if (ptr >= (lispobj)th->control_stack_start
+          && ptr < (lispobj)th->control_stack_end) return 1;
+    }
+    return 0;
+}
+
+#define RECURSE(x) if(is_lisp_pointer(x) && !reject(x)) graph_visit(ptr,x,context)
+
+int graph_visit_skip_weak_pointers;
 
 /* Despite this being a nice concise expression of a pointer tracing algorithm,
  * it turns out to be almost unusable in any sufficiently complicated object graph
@@ -1430,12 +1518,21 @@ static void graph_visit(lispobj referer, lispobj ptr, struct grvisit_context* co
     if (++context->depth > context->maxdepth) context->maxdepth = context->depth;
     // TODO: add rejection function for off-heap objects as part of supplied context
     hopscotch_insert(context->seen, ptr, 1);
-    if (context->action) context->action(ptr, context->data);
+    if (context->action) context->action(referer, ptr, context->data);
     lispobj layout, *obj;
     sword_t nwords, i;
     if (lowtag_of(ptr) == LIST_POINTER_LOWTAG) {
+        // When constructing lists there is a transient state with a bad cdr depending on
+        // whether more than one aallocation is needed.
+        // It might not be an error, as long as no other thread can see the data.
+        if (CONS(ptr)->car == (uword_t)-1 || CONS(ptr)->cdr == (uword_t)-1) {
+            char buf[80];
+            int n = snprintf(buf, sizeof buf,
+                             "sus' cons @ %p: %lx %lx\n", (void*)ptr, CONS(ptr)->car, CONS(ptr)->cdr);
+            write(2, buf, n);
+        }
         RECURSE(CONS(ptr)->car);
-        RECURSE(CONS(ptr)->cdr);
+        if (CONS(ptr)->cdr != (uword_t)-1) RECURSE(CONS(ptr)->cdr);
     } else switch (widetag_of(obj = native_pointer(ptr))) {
         case SIMPLE_VECTOR_WIDETAG:
             {
@@ -1447,11 +1544,13 @@ static void graph_visit(lispobj referer, lispobj ptr, struct grvisit_context* co
         case INSTANCE_WIDETAG:
         case FUNCALLABLE_INSTANCE_WIDETAG:
             layout = layout_of(obj);
-            graph_visit(ptr, layout, context);
+            if (layout != 0) {
-            nwords = headerobj_size(obj);
+                graph_visit(ptr, layout, context);
-            struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout));
+                nwords = headerobj_size(obj);
-            for (i=0; i<(nwords-1); ++i)
+                struct bitmap bitmap = get_layout_bitmap(LAYOUT(layout));
-                if (bitmap_logbitp(i, bitmap)) RECURSE(obj[1+i]);
+                for (i=0; i<(nwords-1); ++i)
+                    if (bitmap_logbitp(i, bitmap)) RECURSE(obj[1+i]);
+            }
             break;
         case CODE_HEADER_WIDETAG:
             nwords = code_header_words((struct code*)obj);
@@ -1479,6 +1578,9 @@ static void graph_visit(lispobj referer, lispobj ptr, struct grvisit_context* co
             RECURSE(obj[2]);
             RECURSE(decode_fdefn_rawfun((struct fdefn*)obj));
             break;
+        case WEAK_POINTER_WIDETAG:
+            if (graph_visit_skip_weak_pointers) break;
+            // else FALLTHROUGH
         default:
             // weak-pointer can be considered an ordinary boxed object.
             // the 'next' link looks like a fixnum.
@@ -1504,15 +1606,20 @@ static void trace_sym(lispobj ptr, struct symbol* sym, struct grvisit_context* c
  * dictated by thread stacks, etc. Caller may - but need not - provide
  * an 'action' to invoke on each object */
 struct grvisit_context*
-visit_heap_from_static_roots(struct hopscotch_table* reached,
+visit_heap_from_roots(struct hopscotch_table* reached,
-                             void (*action)(lispobj, void*),
+                      void (*action)(lispobj, lispobj, void*),
-                             void* data)
+                      void* data,
+                      int quasi_static_roots_too,
+                      lispobj* extra_roots,
+                      int n_extra_roots)
 {
     hopscotch_create(reached, HOPSCOTCH_HASH_FUN_DEFAULT,
                      0, // no values
                      1<<18, /* initial size */
                      0);
 
+    struct timespec start_time, end_time;
+    clock_gettime(CLOCK_REALTIME, &start_time);
     struct grvisit_context* context = malloc(sizeof (struct grvisit_context));
     context->seen = reached;
     context->action = action;
@@ -1525,9 +1632,38 @@ visit_heap_from_static_roots(struct hopscotch_table* reached,
         graph_visit(0, compute_lispobj(where), context);
         where += object_size(where);
     }
+    if (quasi_static_roots_too) {
+        where = (lispobj*)DYNAMIC_SPACE_START;
+        end = (lispobj*)dynamic_space_highwatermark();
+        while (where<end) {
+            if (page_table[find_page_index(where)].gen
+                == PSEUDO_STATIC_GENERATION) {
+                graph_visit(0, compute_lispobj(where), context);
+            }
+            where += object_size(where);
+        }
+    }
+    int i;
+    for (i=0; i<n_extra_roots; ++i) {
+        lispobj root = extra_roots[i];
+        gc_assert(is_lisp_pointer(root));
+        graph_visit(0, root, context);
+    }
+    clock_gettime(CLOCK_REALTIME, &end_time);
+    context->microsec_elapsed =
+        (end_time.tv_sec - start_time.tv_sec)*1000000
+        + (end_time.tv_nsec - start_time.tv_nsec)/1000;
     return context;
 }
 
+int calc_log2size(long size)
+{
+    int log2size = 3; // naive integer-length algorithmn
+    while (1<<log2size < size) ++log2size;
+    gc_assert(log2size <= 12);
+    return log2size;
+}
+
 // Caution: use at your own risk
 #if defined DEBUG_CORE_LOADING && DEBUG_CORE_LOADING
 struct visitor {
@@ -1537,6 +1673,8 @@ struct visitor {
         int count;
         int words;
     } headers[65], sv_subtypes[3];
+    int log2size_histo[13];
+    int n_oversized;
     struct hopscotch_table *reached;
 };
 
@@ -1563,6 +1701,12 @@ static void tally(lispobj ptr, struct visitor* v)
             v->sv_subtypes[subtype].words += words;
         }
     }
+    sword_t bytes = words * N_WORD_BYTES;
+    if (bytes > 4096)
+        ++v->n_oversized;
+    else {
+        ++v->log2size_histo[calc_log2size(bytes)];
+    }
 }
 
 /* This printing in here is useful, but it's too much to output in make-target-2,
@@ -1587,7 +1731,7 @@ static uword_t visit(lispobj* where, lispobj* limit, uword_t arg)
         }
         lispobj ptr = compute_lispobj(obj);
         tally(ptr, v);
-        if (!hopscotch_get(v->reached, ptr, 0)) printf("unreachable: %p\n", (void*)ptr);
+        //if (!hopscotch_get(v->reached, ptr, 0)) printf("unreachable: %p\n", (void*)ptr);
         obj += object_size(obj);
     }
     return 0;
@@ -1602,7 +1746,7 @@ static void sanity_check_loaded_core(lispobj initial_function)
     memset(v, 0, sizeof v);
     // Pass 1: Count objects reachable from known roots.
     struct grvisit_context* c
-        = visit_heap_from_static_roots(&reached, 0, 0);
+        = visit_heap_from_roots(&reached, 0, 0, 0, 0);
     graph_visit(0, initial_function, c); // initfun is not otherwise reachable
     // having computed the reaching graph, tally up the dynamic space objects
     int key_index;
@@ -1652,6 +1796,10 @@ static void sanity_check_loaded_core(lispobj initial_function)
             v[1].headers[64].words += v[1].headers[i].words;
         }
     }
+    printf("Breakdown by log2(size):\n");
+    for (i=(N_WORD_BYTES==32)?3:4; i<=12; ++i)
+        printf(" %d", v[1].log2size_histo[i]);
+    printf(" oversized=%d\n", v[1].n_oversized);
     hopscotch_destroy(&reached);
 }
 #else
@@ -1675,3 +1823,22 @@ void gc_store_corefile_ptes(struct corefile_pte *ptes)
         ptes[i].words_used = used | page_single_obj_p(i);
     }
 }
+static uword_t visit_instances(lispobj* where, lispobj* limit, uword_t arg)
+{
+    lispobj* obj = where;
+    while (obj < limit) {
+        if (widetag_of(obj) == INSTANCE_WIDETAG) {
+            if (instance_layout(obj) == 0) {
+              fprintf(stderr, "bad: %p\n", obj);
+              ++ *(int*)arg;
+            }
+        }
+        obj += object_size(obj);
+    }
+    return 0;
+}
+void check_for_layoutless_instances() {
+    int bad_count = 0;
+    walk_generation(visit_instances, -1, (uword_t)&bad_count);
+    if (bad_count) { fprintf(stderr, "total bad instances: %d\n", bad_count); }
+}

src/runtime/gc-common.c

@@ -346,6 +346,37 @@ void scan_binding_stack()
 #endif
 }
 
+// Forwarded code objects contain FPs for each embedded function
+void store_code_forwarding_ptrs(struct code* old, struct code* new)
+
+{
+    set_forwarding_pointer((lispobj *)old, make_lispobj(new, OTHER_POINTER_LOWTAG));
+
+    sword_t displacement = (char*)new - (char*)old;
+
+#if defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 || \
+    defined LISP_FEATURE_X86 || defined LISP_FEATURE_X86_64
+    // Fixup absolute jump tables. These aren't recorded in code->fixups
+    // because we don't need to denote an arbitrary set of places in the code.
+    // The count alone suffices. A GC immediately after creating the code
+    // could cause us to observe some 0 words here. Those should be ignored.
+    lispobj* jump_table = code_jumptable_start(new);
+    int count = jumptable_count(jump_table);
+    int i;
+    for (i = 1; i < count; ++i)
+        if (jump_table[i]) jump_table[i] += displacement;
+#endif
+    for_each_simple_fun(i, new_fun, new, 1, {
+        // Calculate the old raw function pointer
+        struct simple_fun* old_fun = (struct simple_fun*)((char*)new_fun - displacement);
+        if (fun_self_from_baseptr(old_fun) == old_fun->self) {
+            new_fun->self = fun_self_from_baseptr(new_fun);
+            set_forwarding_pointer((lispobj*)old_fun,
+                                   make_lispobj(new_fun, FUN_POINTER_LOWTAG));
+        }
+    })
+}
+
 extern int pin_all_dynamic_space_code;
 static struct code *
 trans_code(struct code *code)
@@ -378,32 +409,8 @@ trans_code(struct code *code)
 
     if (l_new_code == l_code) return code;
 
-    set_forwarding_pointer((lispobj *)code, l_new_code);
+    struct code* new_code = (void*)(l_new_code-OTHER_POINTER_LOWTAG);
-
+    store_code_forwarding_ptrs(code, new_code);
-    struct code *new_code = (struct code *) native_pointer(l_new_code);
-    sword_t displacement = l_new_code - l_code;
-
-#if defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC64 || \
-    defined LISP_FEATURE_X86 || defined LISP_FEATURE_X86_64
-    // Fixup absolute jump tables. These aren't recorded in code->fixups
-    // because we don't need to denote an arbitrary set of places in the code.
-    // The count alone suffices. A GC immediately after creating the code
-    // could cause us to observe some 0 words here. Those should be ignored.
-    lispobj* jump_table = code_jumptable_start(new_code);
-    int count = jumptable_count(jump_table);
-    int i;
-    for (i = 1; i < count; ++i)
-        if (jump_table[i]) jump_table[i] += displacement;
-#endif
-    for_each_simple_fun(i, new_fun, new_code, 1, {
-        // Calculate the old raw function pointer
-        struct simple_fun* old_fun = (struct simple_fun*)((char*)new_fun - displacement);
-        if (fun_self_from_baseptr(old_fun) == old_fun->self) {
-            new_fun->self = fun_self_from_baseptr(new_fun);
-            set_forwarding_pointer((lispobj*)old_fun,
-                                   make_lispobj(new_fun, FUN_POINTER_LOWTAG));
-        }
-    })
     gencgc_apply_code_fixups(code, new_code);
     os_flush_icache(code_text_start(new_code), code_text_size(new_code));
     return new_code;
@@ -1169,8 +1176,10 @@ DEF_SCAV_TRANS_SIZE_UB(128)
  * containing a single key */
 static sword_t scav_weakptr(lispobj *where, lispobj __attribute__((unused)) object)
 {
+    // fprintf(stderr, "scav_weakptr %p (hdr=%lx) ", where, object);
     if (weakptr_vectorp((struct weak_pointer*)where)) {
         add_to_weak_vector_list(where, *where); // treat it like weak simple-vector
+        // fprintf(stderr, "vectorp\n");
         return size_vector_t(where);
     }
     struct weak_pointer * wp = (struct weak_pointer*)where;
@@ -1188,6 +1197,7 @@ static sword_t scav_weakptr(lispobj *where, lispobj __attribute__((unused)) obje
              immobile_obj_gen_bits(base_pointer(pointee)) == from_space)
 #endif
             );
+        // fprintf(stderr, "pointee=%lx%s\n", pointee, breakable?" BREAKABLE":"");
         if (breakable) { // Pointee could potentially be garbage.
             // But it might already have been deemed live and forwarded.
             if (forwarding_pointer_p(native_pointer(pointee)))
@@ -1905,14 +1915,17 @@ sword_t scav_code_blob(lispobj *object, lispobj header);
 lispobj *
 component_ptr_from_pc(char *pc)
 {
+  extern uword_t* codeblob_from_interior_ptr(void* addr);
+  lispobj* object = NULL;
+  if(use_smlgc) object = codeblob_from_interior_ptr(pc);
+
     /* This will safely look in one or both codeblob trees and/or the
      * sorted array of immobile text pages. Failing those, it'll perform
      * the usual linear scan of generation 1 and up pages. In any case
      * it should be perfectly threadsafe because the trees are made of immutable
      * nodes, and linear scan only operates on pages that can't be
      * concurrently manipulated */
-    lispobj *object = search_all_gc_spaces(pc);
+    if (object == NULL) object = search_all_gc_spaces(pc);
-
     if (object != NULL && widetag_of(object) == CODE_HEADER_WIDETAG)
         return object;
 
@@ -2076,6 +2089,8 @@ properly_tagged_p_internal(lispobj pointer, lispobj *start_addr)
 int
 valid_tagged_pointer_p(lispobj pointer)
 {
+    extern int smlgc_valid_tagged_pointer_p();
+    if (smlgc_valid_tagged_pointer_p(pointer)) return 1;
     /* We don't have a general way to ask a specific GC implementation
      * whether 'pointer' is definitely the tagged pointer to an object -
      * all we have is "search for a containing object" and then a decision
@@ -2099,8 +2114,7 @@ valid_tagged_pointer_p(lispobj pointer)
                == pointer;
     }
     lispobj *start = search_all_gc_spaces((void*)pointer);
-    if (start != NULL)
+    if (start != NULL) return properly_tagged_descriptor_p((void*)pointer, start);
-        return properly_tagged_descriptor_p((void*)pointer, start);
     return 0;
 }
 
@@ -2972,6 +2986,7 @@ int hexdump_and_verify_heap(lispobj* cur_thread_approx_stackptr, int flags)
 }
 #endif
 
+#if 0
 /* These are do-nothing wrappers for now */
 lispobj *lisp_component_ptr_from_pc(char *pc) {
     lispobj *result = component_ptr_from_pc(pc);
@@ -2981,3 +2996,4 @@ int lisp_valid_tagged_pointer_p(lispobj pointer) {
     int result = valid_tagged_pointer_p(pointer);
     return result;
 }
+#endif

src/runtime/gencgc-alloc-region.h

@@ -1,6 +1,8 @@
 #ifndef _GENCGC_ALLOC_REGION_H_
 #define _GENCGC_ALLOC_REGION_H_
 
+#include "../../smlsharpgc/alloc_ptr.h"
+
 /* Abstract out the data for an allocation region allowing a single
  * routine to be used for allocation and closing. */
 /* Caution: if you change this, you may have to change compiler/generic/objdef
@@ -34,7 +36,7 @@ static inline void gc_init_region(struct alloc_region *region)
 typedef struct {
     struct alloc_region cons;
     struct alloc_region mixed;
-    uword_t token;
+    uintptr_t token;
 } arena_state;
 
 // One region for each of page type.

src/runtime/gencgc.c

@@ -654,6 +654,33 @@ bool page_is_zeroed(page_index_t page)
 }
 #endif
 
+__attribute__((unused)) static char* region_name(struct thread* th, struct alloc_region* r) {
+  if (r == &th->mixed_tlab) { return "um"; }
+  if (r == &th->cons_tlab) { return "uc"; }
+  if (r == &th->sys_mixed_tlab) { return "sm"; }
+  if (r == &th->sys_cons_tlab) { return "sc"; }
+  if (r == code_region) { return "code"; }
+  return 0;
+}
+static void show_new_region(__attribute__((unused)) struct alloc_region* r,
+                            __attribute__((unused)) int page_type) {
+#if 0
+  extern struct thread* mainthread;
+  struct thread* th = get_sb_vm_thread();
+  char *name = name_of_region(th, r);
+  char buf[100];
+  int n;
+  if (name)
+    n = snprintf(buf, sizeof buf, "%s: %s = %lx..%lx %x\n",
+                 th == mainthread ? "m" : "f", name,
+                 (uword_t)r->start_addr, (uword_t)r->end_addr, page_type);
+  else
+    n = snprintf(buf, sizeof buf, "%s: %p = %lx..%lx %x\n",
+                 th == mainthread ? "m" : "f", r,
+                 (uword_t)r->start_addr, (uword_t)r->end_addr, page_type);
+#endif
+}
+
 static void*
 gc_alloc_new_region(sword_t nbytes, int page_type, struct alloc_region *alloc_region, int unlock)
 {
@@ -694,6 +721,7 @@ gc_alloc_new_region(sword_t nbytes, int page_type, struct alloc_region *alloc_re
           }
         alloc_region->free_pointer = alloc_region->start_addr;
         gc_assert(find_page_index(alloc_region->start_addr) == page);
+        show_new_region(alloc_region, page_type);
         return alloc_region->free_pointer;
     }
 
@@ -764,6 +792,7 @@ gc_alloc_new_region(sword_t nbytes, int page_type, struct alloc_region *alloc_re
     INSTRUMENTING(zeroize_pages_if_needed(first_page+(page_words_used(first_page)?1:0),
                                           last_page, page_type), et_bzeroing);
 
+    show_new_region(alloc_region, page_type);
     return alloc_region->free_pointer;
 }
 
@@ -869,6 +898,20 @@ gc_close_region(struct alloc_region *alloc_region, int page_type)
     char *page_base = page_address(first_page);
     char *free_pointer = alloc_region->free_pointer;
 
+#if 0
+    extern struct thread* mainthread;
+    char buf[100];
+    int n;
+    struct thread* th = get_sb_vm_thread();
+    char* name = name_of_region(th, alloc_region);
+    if (name)
+      n = snprintf(buf, sizeof buf, "%s: c %s %x\n",
+                   th == mainthread ? "m" : "f", name, page_type);
+    else
+      n = snprintf(buf, sizeof buf, "%s: c %p %x\n",
+                   th == mainthread ? "m" : "f", alloc_region, page_type);
+#endif
+
 #if defined LISP_FEATURE_SYSTEM_TLABS && defined DEBUG
     if (alloc_region == &get_sb_vm_thread()->sys_mixed_tlab ||
         alloc_region == &get_sb_vm_thread()->sys_cons_tlab) {
@@ -4018,6 +4061,7 @@ long tot_gc_nsec;
 void NO_SANITIZE_ADDRESS NO_SANITIZE_MEMORY
 collect_garbage(generation_index_t last_gen)
 {
+    if (get_sb_vm_thread()->ap4.freebit.mask != (uint32_t)-1) { fprintf(stderr, "gencgc ignoring collect_garbage call\n"); return; }
     ++n_gcs;
     THREAD_JIT(0);
     generation_index_t gen = 0, i;
@@ -4302,6 +4346,7 @@ lisp_alloc(int flags, struct alloc_region *region, sword_t nbytes,
 {
     os_vm_size_t trigger_bytes = 0;
 
+    if (use_smlgc) lose("How did we get a gencgc allocation request?");
     gc_assert(nbytes > 0);
 
     /* Check for alignment allocation problems. */

src/runtime/globals.h

@@ -12,6 +12,9 @@
 #ifndef _INCLUDED_GLOBALS_H_
 #define _INCLUDED_GLOBALS_H_
 
+extern int use_smlgc;
+extern int enable_async_gc;
+
 #ifndef __ASSEMBLER__
 # include <stdbool.h>
 # include <sys/types.h>

src/runtime/graphvisit.h

@@ -15,14 +15,21 @@
 #include "hopscotch.h"
 struct grvisit_context {
   struct hopscotch_table* seen;
-  void (*action)(lispobj, void*);
+  void (*action)(lispobj, lispobj, void*);
   void* data;
   int depth;
   int maxdepth;
+  long microsec_elapsed;
+  int n_known_ranges;
+  struct {
+    lispobj start, end;
+    unsigned int *markbits;
+  } ranges[4];
 };
 
 extern struct grvisit_context*
-visit_heap_from_static_roots(struct hopscotch_table* reached,
+visit_heap_from_roots(struct hopscotch_table* reached,
-                             void (*action)(lispobj, void*),
+                      void (*action)(lispobj, lispobj, void*),
-                             void* data);
+                      void* data, int,
+                      lispobj*, int);
 #endif

src/runtime/interr.h

@@ -19,6 +19,7 @@ extern void lose(char *fmt, ...)
 #endif
  never_returns;
 extern void tprintf(char *fmt, ...);
+extern void tprintf_(char *fmt, ...);
 extern int lose_on_corruption_p;
 extern void corruption_warning_and_maybe_lose(char *fmt, ...);
 extern void enable_lossage_handler(void);

src/runtime/interrupt.c

@@ -69,6 +69,7 @@
 #include "genesis/cons.h"
 #include "genesis/vector.h"
 #include "atomiclog.inc"
+#include "search.h"
 
 #ifdef ATOMIC_LOGGING
 uword_t *eventdata;
@@ -258,10 +259,12 @@ resignal_to_lisp_thread(int signal, os_context_t *context)
 char* vm_thread_name(struct thread* th)
 {
     if (!th) return "non-lisp";
-    struct thread_instance *lispthread =
+    if (th->lisp_thread) {
-        (void*)(th->lisp_thread - INSTANCE_POINTER_LOWTAG);
+        struct thread_instance *lispthread =
-    lispobj name = lispthread->_name;
+            (void*)(th->lisp_thread - INSTANCE_POINTER_LOWTAG);
-    if (simple_base_string_p(name)) return vector_sap(name);
+        lispobj name = lispthread->_name;
+        if (simple_base_string_p(name)) return vector_sap(name);
+    }
     return "?";
 }
 
@@ -329,7 +332,12 @@ static void record_signal(int sig, void* context)
 {
     event2("got signal %d @ pc=%p", sig, os_context_pc(context));
 }
-#define RECORD_SIGNAL(sig,ctxt) if(sig!=SIGSEGV)record_signal(sig,ctxt);
+#define RECORD_SIGNAL(sig,ctxt) if(sig!=4) { \
+    char buf[100]; \
+    int n = snprintf(buf, sizeof buf,"[%s] sig%d @ pc=%lx fp=%lx sp=%lx\n", \
+                     vm_thread_name(get_sb_vm_thread()),                \
+                     sig, os_context_pc(ctxt), *os_context_fp_addr(ctxt), \
+                     *os_context_sp_addr(ctxt)); write(2,buf,n); }
 #else
 #define RECORD_SIGNAL(sig,ctxt)
 #endif
@@ -337,7 +345,12 @@ static void record_signal(int sig, void* context)
 #ifdef LISP_FEATURE_WIN32
 # define should_handle_in_this_thread(c) (1)
 #else
-# define should_handle_in_this_thread(c) lisp_thread_p(c)
+// collector needs to handle sigsegv in exception_handling_load()
+// in otherptr_mseg. Probably would be best to consider the collector thread
+// to be a Lisp thread, or else specifically allow that thread.
+// But wait! low_level_handle_now no longer uses SAVE_ERRNO so therefore
+// does not use should_handle_in_this_thread so why is this diff here?
+# define should_handle_in_this_thread(c) (lisp_thread_p(c)||signal==SIGSEGV)
 #endif
 #define SAVE_ERRNO(signal,context,void_context)                 \
     {                                                           \
@@ -1040,6 +1053,7 @@ bool interrupt_handler_pending_p(void)
 void
 interrupt_handle_pending(os_context_t *context)
 {
+  //  fprintf(stderr, "entered interrupt_handle_pending\n");
 #ifdef ADDRESS_SANITIZER
     __asan_unpoison_memory_region(context, sizeof *context);
 #endif
@@ -1401,10 +1415,18 @@ maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
 #ifdef LISP_FEATURE_GC_METRICS
 pthread_cond_t gcmetrics_condvar = PTHREAD_COND_INITIALIZER;
 pthread_mutex_t gcmetrics_mutex = PTHREAD_MUTEX_INITIALIZER;
+int current_thread_total_gc_pause_microseconds() {
+    struct thread* th = get_sb_vm_thread();
+    struct extra_thread_data *data = thread_extra_data(th);
+    return data->sum_gc_wait;
+}
 #endif
 
 #ifdef THREADS_USING_GCSIGNAL
 
+extern int enable_async_gc;
+extern void sml_check_internal(void *);
+
 /* This function must not cons, because that may trigger a GC. */
 void
 sig_stop_for_gc_handler(int __attribute__((unused)) signal,
@@ -1417,17 +1439,20 @@ sig_stop_for_gc_handler(int __attribute__((unused)) signal,
     /* Test for GC_INHIBIT _first_, else we'd trap on every single
      * pseudo atomic until gc is finally allowed. */
     if (read_TLS(GC_INHIBIT,thread) != NIL) {
+      tprintf_("GC sig deferred: INHIBIT");
         event0("stop_for_gc deferred for *GC-INHIBIT*");
         write_TLS(STOP_FOR_GC_PENDING, LISP_T, thread);
         return;
     } else if (arch_pseudo_atomic_atomic(thread)) {
-        event0("stop_for_gc deferred for PA");
+      tprintf_("GC sig deferred: pseudo-atomic");
+        event0("GC-cooperate deferred for PA");
         write_TLS(STOP_FOR_GC_PENDING, LISP_T, thread);
         arch_set_pseudo_atomic_interrupted(thread);
         maybe_save_gc_mask_and_block_deferrables(context);
         return;
     }
-
+    extern void adjust_context_for_implicit_pseudoatomic(os_context_t*);
+    adjust_context_for_implicit_pseudoatomic(context);
     event0("stop_for_gc");
 
     /* Not PA and GC not inhibited -- we can stop now. */
@@ -1460,6 +1485,12 @@ sig_stop_for_gc_handler(int __attribute__((unused)) signal,
         interrupt_data->gc_blocked_deferrables = 0;
     }
 
+    if (use_smlgc && enable_async_gc) {
+         extern void cooperate_with_gc(uword_t);
+         cooperate_with_gc(*os_context_sp_addr(context));
+         goto Done;
+    }
+
     /* No need to use an atomic memory load here - this thead "owns" its state
      * for now, and nobody else touches it, the sole exception being that GC
      * sets it to RUNNING. The loads inside thread_wait_until_not()
@@ -1515,6 +1546,7 @@ sig_stop_for_gc_handler(int __attribute__((unused)) signal,
     if (my_state != STATE_RUNNING)
         lose("stop_for_gc: bad state on wakeup: %x", my_state);
 
+Done:
     if (was_in_lisp) {
         undo_fake_foreign_function_call(context);
     }
@@ -1911,6 +1943,7 @@ extern void restore_sbcl_signals () {
     }
 }
 
+extern int is_collector_thread();
 static void
 low_level_handle_now_handler(int signal, siginfo_t *info, void *void_context)
 {
@@ -1924,7 +1957,8 @@ low_level_handle_now_handler(int signal, siginfo_t *info, void *void_context)
     RECORD_SIGNAL(signal,void_context);
     UNBLOCK_SIGSEGV();
     RESTORE_FP_CONTROL_WORD(context,void_context);
-    if (lisp_thread_p(void_context)) {
+    // assume we know how to handle signals (SIGSEGV) in the collector thread
+    if (lisp_thread_p(void_context) || is_collector_thread()) {
         interrupt_low_level_handlers[signal](signal, info, context);
     }
 #if defined LISP_FEATURE_DARWIN && defined LISP_FEATURE_SB_THREAD

src/runtime/linux-os.c

@@ -59,6 +59,15 @@ int personality (unsigned long);
 #include <sys/personality.h>
 #endif
 
+char * cur_thread_name()
+{
+  struct thread *th = get_sb_vm_thread();
+  if (!th) return "gc";
+  struct thread_instance *ti = (void*)native_pointer(th->lisp_thread);
+  lispobj threadname = ti->_name;
+  return (char*)VECTOR(threadname)->data;
+}
+
 #ifdef LISP_FEATURE_SB_FUTEX
 #include <sys/syscall.h>
 #include <unistd.h>
@@ -113,6 +122,7 @@ void lisp_mutex_start_eventrecording() {
     eventcount = 0;
     record_mutex_events = 1;
 }
+
 void lisp_mutex_done_eventrecording() {
     record_mutex_events = 0;
     int i;
@@ -259,7 +269,7 @@ void os_init()
 #ifdef LISP_FEATURE_SB_FUTEX
     futex_init();
 #endif
-#ifdef LISP_FEATURE_SB_DEVEL
+#if 1 // def LISP_FEATURE_SB_DEVEL
     prctl(PR_SET_PTRACER, PR_SET_PTRACER_ANY);
 #endif
 }
@@ -375,11 +385,27 @@ fallback_sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
 void (*sbcl_fallback_sigsegv_handler)  // Settable by user.
        (int, siginfo_t*, os_context_t*) = fallback_sigsegv_handler;
 
+extern uword_t exception_handling_load(uword_t*);
+extern void ldb_monitor();
+
 static void
 sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
 {
+    uword_t pc = os_context_pc(context);
+    if (pc == (uword_t)&exception_handling_load) {
+        // instruction at PC: 488B07 MOV RAX, [RDI]
+        set_os_context_pc(context, pc + 3);
+        extern int mseg_rej_memfault;
+        __sync_fetch_and_add(&mseg_rej_memfault, 1);
+        *os_context_register_addr(context, 0) = 0;
+        return;
+    }
     os_vm_address_t addr = arch_get_bad_addr(signal, info, context);
 
+    //fprintf(stderr, "fault @ pc=%p addr=%p fp=%lx\n", (void*)pc, addr, *os_context_fp_addr(context));
+
+    if (find_page_index(addr)<0) ldb_monitor();
+
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     if (handle_safepoint_violation(context, addr)) return;
 #endif
@@ -395,12 +421,20 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
             sbcl_fallback_sigsegv_handler(signal, info, context);
 }
 
+void crash(__attribute__((unused)) int sig,
+           __attribute__((unused)) siginfo_t* info,
+           void* context)
+{
+  extern void sb_dump_mcontext(char*,void*);
+  fprintf(stderr, "pthread %lx vm-thread %p\n", pthread_self(), get_sb_vm_thread());
+  sb_dump_mcontext("SIGSEGV", context);
+  ldb_monitor();
+}
+
 void
 os_install_interrupt_handlers(void)
 {
-    if (INSTALL_SIG_MEMORY_FAULT_HANDLER) {
     ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler);
-    }
 }
 
 char *os_get_runtime_executable_path()
@@ -416,3 +450,5 @@ char *os_get_runtime_executable_path()
 
     return copied_string(path);
 }
+
+uword_t get_stderr() { return (uword_t)stderr; }

src/runtime/main.c

@@ -1,8 +1,12 @@
 #include "interr.h"
 
+int use_smlgc;
+
 int main(int argc, char *argv[], char *envp[])
 {
+    if (getenv("SMLGC")) use_smlgc = 1;
     extern int initialize_lisp(int argc, char *argv[], char *envp[]);
+
     initialize_lisp(argc, argv, envp);
     lose("unexpected return from initial thread in main()");
     return 0;

src/runtime/monitor.c

@@ -234,10 +234,11 @@ void save_gc_crashdump(char *pathname,
 #endif
 
 static cmd call_cmd, dump_cmd, print_cmd, quit_cmd, help_cmd;
-static cmd flush_cmd, regs_cmd, exit_cmd;
+static cmd findpath_cmd, flush_cmd, regs_cmd, exit_cmd;
 static cmd print_context_cmd, pte_cmd, search_cmd;
 static cmd backtrace_cmd, catchers_cmd;
 static cmd threads_cmd, findpath_cmd, layouts_cmd;
+static cmd segs_cmd, hashsets_cmd;
 
 extern void gc_stop_the_world(), gc_start_the_world();
 static void suspend_other_threads() {
@@ -267,7 +268,8 @@ static int save_cmd(char **ptr) {
 #endif
     return 0;
 }
-void list_lisp_threads(int regions) {
+extern uword_t* obj_from_ambiguous_ptr(lispobj);
+void list_lisp_threads(int regions, int stack) {
     struct thread* th;
     fprintf(stderr, "(thread*,pthread,sb-vm:thread,name)\n");
     void* pthread;
@@ -301,9 +303,27 @@ void list_lisp_threads(int regions) {
         show_tlab("cons     ", cons_region);
 #undef show_tlab
     }
+    if (stack) { // show stack roots of current thread only
+        lispobj* low = (void*)ALIGN_DOWN((uword_t)&regions, N_WORD_BYTES);
+        lispobj* high = get_sb_vm_thread()->control_stack_end;
+        lispobj* sp;
+        for (sp = high-1; sp >= low; --sp) {
+            lispobj word = *sp;
+            lispobj* obj;
+            if ((word >= READ_ONLY_SPACE_START && word < (lispobj)read_only_space_free_pointer) ||
+                (word >= STATIC_SPACE_START && word < (lispobj)static_space_free_pointer)) {
+            } else if ((obj = obj_from_ambiguous_ptr(word)) != 0) {
+                fprintf(stderr, "%p: %16lx -> %p (%s)\n", sp, word, obj,
+                        (lowtag_of(word) == LIST_POINTER_LOWTAG) ? "cons"
+                        : widetag_names[widetag_of(obj)>>2]);
+            }
+        }
+    }
 }
 static int threads_cmd(char **ptr) {
-    list_lisp_threads(more_p(ptr) && !strncmp(*ptr, "-r", 2));
+    int show_regions = more_p(ptr) && !strncmp(*ptr, "-r", 2);
+    int show_stack = more_p(ptr) && !strncmp(*ptr, "-s", 2);
+    list_lisp_threads(show_regions, show_stack);
     return 0;
 }
 extern int heap_trace_verbose;
@@ -365,6 +385,18 @@ static int verify_cmd(char __attribute__((unused)) **ptr) {
     return 0;
 }
 static int gc_cmd(char **ptr) {
+#if 0
+  extern void sml_force_gc();
+  extern int sml_current_phase();
+  extern void sml_check_internal(void *frame_pointer);
+  int old =  sml_current_phase();
+    if (!strncmp(*ptr, "start", 5))
+      sml_force_gc();
+    else if (!strncmp(*ptr, "sync", 4))
+      sml_check_internal(&ptr);
+  int new =  sml_current_phase();
+  fprintf(stderr, "Phase %d -> %d\n", old, new);
+#else
     int last_gen = 0;
     extern generation_index_t verify_gens;
     if (more_p(ptr)) parse_number(ptr, &last_gen);
@@ -374,6 +406,7 @@ static int gc_cmd(char **ptr) {
     suspend_other_threads();
     collect_garbage(last_gen);
     unsuspend_other_threads();
+#endif
     return 0;
 }
 
@@ -404,12 +437,14 @@ static struct cmd {
     {"findpath", "Find path to an object.", findpath_cmd},
     {"flush", "Flush all temp variables.", flush_cmd},
     {"layouts", "Dump LAYOUT instances.", layouts_cmd},
+    {"hashsets", "Show hashsets.", hashsets_cmd},
     {"print", "Print object at ADDRESS.", print_cmd},
     {"p", "(an alias for print)", print_cmd},
     {"pte", "Page table entry for address", pte_cmd},
     {"quit", "Quit.", quit_cmd},
     {"regs", "Display current Lisp registers.", regs_cmd},
     {"search", "Search heap for object.", search_cmd},
+    {"segs", "List all segments", segs_cmd},
     {"save", "Produce crashdump", save_cmd},
     {"threads", "List threads", threads_cmd},
     {"tlsfdump", "Dump TLSF structures", tlsf_cmd},
@@ -546,11 +581,15 @@ dump_cmd(char **ptr)
     return 0;
 }
 
+extern void gc_show_seg(lispobj);
 static int
 print_cmd(char **ptr)
 {
     lispobj obj;
-    if (parse_lispobj(ptr, &obj)) print(obj);
+    if (parse_lispobj(ptr, &obj)) {
+      if (use_smlgc) gc_show_seg(obj);
+      print(obj);
+    }
     return 0;
 }
 
@@ -563,6 +602,12 @@ pte_cmd(char **ptr)
     return 0;
 }
 
+static int segs_cmd(__attribute__((unused)) char **ptr) {
+    extern void sml_heap_dump_everything();
+    //sml_heap_dump_everything();
+    return 0;
+}
+
 static int
 regs_cmd(char __attribute__((unused)) **ptr)
 {
@@ -761,6 +806,12 @@ backtrace_cmd(char **ptr)
     int n;
 
     if (more_p(ptr)) {
+      long fp = strtol(*ptr, 0, 0);
+      fprintf(stderr, "using fp %lx\n", fp);
+      extern void log_backtrace_from_fp(struct thread* th, void *fp, int nframes, int start, FILE *f);
+
+      log_backtrace_from_fp(get_sb_vm_thread(), (void*)fp, 1000, 0, stdout);
+      return 0;
         if (!parse_number(ptr, &n)) return 0;
     } else
         n = 100;
@@ -1192,3 +1243,32 @@ int main(int argc, char *argv[], char **envp)
     ldb_monitor();
 }
 #endif
+
+static uword_t scan_for_hashsets(lispobj* where, lispobj* limit, uword_t arg)
+{
+  for ( ; where < limit ; where += object_size(where) ) {
+    if (widetag_of(where)==SYMBOL_WIDETAG) {
+      lispobj value = ((struct symbol*)where)->value;
+      if (instancep(value)) {
+        lispobj layout = instance_layout(INSTANCE(value));
+        if (layout_depth2_id(LAYOUT(layout)) == 145) {
+          lispobj lname = decode_symbol_name(((struct symbol*)where)->name);
+          struct vector* name = VECTOR(lname);
+          lispobj storage = INSTANCE(value)->slots[INSTANCE_DATA_START];
+          lispobj cells = storage ? INSTANCE(storage)->slots[INSTANCE_DATA_START] : 0;
+          fprintf(stderr, "sym %lx -> hs %lx -> storage %lx -> cells %lx [%lx] (%s)\n",
+                  (uword_t)where, value, storage, cells, *native_pointer(cells),
+                  (char*)name->data);
+        }
+      }
+    }
+
+  }
+  return 0;
+}
+
+static int hashsets_cmd(char __attribute__((unused)) **ptr)
+{
+  walk_generation(scan_for_hashsets, -1, 0);
+  return 0;
+}

src/runtime/os-common.c

@@ -208,6 +208,7 @@ void os_unlink_runtime()
 
 bool gc_managed_heap_space_p(lispobj addr)
 {
+    extern int in_bitmapped_subheap(void* addr);
     if ((READ_ONLY_SPACE_START <= addr && addr < READ_ONLY_SPACE_END)
         || (STATIC_SPACE_START <= addr && addr < STATIC_SPACE_END)
 #if defined LISP_FEATURE_GENERATIONAL
@@ -225,6 +226,7 @@ bool gc_managed_heap_space_p(lispobj addr)
 #endif
         )
         return 1;
+    if (use_smlgc && in_bitmapped_subheap((void*)addr)) return 1;
     return 0;
 }
 

src/runtime/parse.c

@@ -205,6 +205,8 @@ int parse_addr(char **ptr, bool safely, char **output)
 
 static lispobj lookup_symbol(char *name)
 {
+    extern lispobj search_smlgc_heap_for_symbol(char*);
+    return search_smlgc_heap_for_symbol(name);
     uword_t ranges[][2] = {
       { STATIC_SPACE_OBJECTS_START, (uword_t)static_space_free_pointer },
 #ifdef LISP_FEATURE_IMMOBILE_SPACE

src/runtime/print.c

@@ -339,10 +339,15 @@ char * simple_base_stringize(struct vector * string)
   return newstring;
 }
 
+struct vector * classoid_name(lispobj* classoid);
 static void brief_struct(lispobj obj)
 {
+    if (layoutp(obj)) { // print the classoid this layout is for
+        struct vector* name = classoid_name(native_pointer(LAYOUT(obj)->classoid));
+        printf("#<layout-for %s %"OBJ_FMTX">", (char*)name->data, obj);
+        return;
+    }
     struct instance *instance = INSTANCE(obj);
-    extern struct vector * instance_classoid_name(lispobj*);
     struct vector * classoid_name;
     classoid_name = instance_classoid_name((lispobj*)instance);
     lispobj layout = instance_layout((lispobj*)instance);

src/runtime/print.h

@@ -31,4 +31,6 @@ extern void print_list_car_ptrs(lispobj, FILE*);
 
 void odxprint_fun(const char *fmt, ...);
 
+extern struct vector* instance_classoid_name(lispobj*);
+
 #endif

src/runtime/runtime.c

@@ -605,6 +605,8 @@ parse_argv(struct memsize_options memsize_options,
     return o;
 }
 
+extern void instant_stop_handler(int, siginfo_t*, void*);
+
 int
 initialize_lisp(int argc, char *argv[], char *envp[])
 {
@@ -770,6 +772,15 @@ initialize_lisp(int argc, char *argv[], char *envp[])
     ll_install_handler(SIGURG, thruption_handler);
 # elif defined LISP_FEATURE_SB_THREAD
     ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler);
+
+    struct sigaction sa;
+    sa.sa_sigaction = instant_stop_handler;
+    sa.sa_mask = blockable_sigset;
+    sa.sa_flags = SA_SIGINFO | SA_RESTART | SA_NODEFER;
+    sigaction(SIGPROF, &sa, 0);
+
+    //ll_install_handler(SIGPWR, sigpwr_handler);
+    fprintf(stderr, "installed stop-for-gc handler\n");
 # endif
 #else
 /*     wos_install_interrupt_handlers(handler); */

src/runtime/save.c

@@ -661,6 +661,7 @@ static void prepare_dynamic_space_for_final_gc()
 char gc_coalesce_string_literals = 0;
 
 extern void move_rospace_to_dynamic(int), prepare_readonly_space(int,int);
+extern lispobj copy_smlgc_heap_to_gencgc(lispobj);
 
 /* Do a non-conservative GC twice, and then save a core with the initial
  * function being set to the value of 'lisp_init_function'.
@@ -743,6 +744,10 @@ gc_and_save(char *filename, bool prepend_runtime, bool purify,
     struct thread *thread = get_sb_vm_thread();
     gc_close_thread_regions(thread, 0);
     gc_close_collector_regions(0);
+    gencgc_verbose = 1;
+    if (use_smlgc) {
+        lisp_init_function = copy_smlgc_heap_to_gencgc(lisp_init_function);
+    }
 #ifdef LISP_FEATURE_MARK_REGION_GC
     /* Do a minor GC to instate allocation bitmap for new objects.
      * This is needed to make heap walking in move_rospace_to_dynamic

src/runtime/search.c

@@ -277,6 +277,24 @@ uword_t brothertree_find_greatereql(uword_t key, lispobj tree)
     return best;
 }
 
+#include <stdio.h>
+void dump_brothertree(lispobj tree)
+{
+    if (tree == NIL) return;
+    lispobj layout = instance_layout(INSTANCE(tree));
+    if (layout_depth2_id(LAYOUT(layout)) == BROTHERTREE_UNARY_NODE_LAYOUT_ID)
+        dump_brothertree(((struct unary_node*)INSTANCE(tree))->child);
+    else {
+        struct binary_node* node = (void*)INSTANCE(tree);
+        lispobj l = NIL, r = NIL;
+        // unless a fringe node, read the left and right pointers
+        if (!fringe_node_p(node)) l = node->_left, r = node->_right;
+        dump_brothertree(l);
+        printf("%lx\n", node->uw_key);
+        dump_brothertree(r);
+    }
+}
+
 #define BSEARCH_ALGORITHM_IMPL \
     int low = 0; \
     int high = nelements - 1; \
@@ -363,3 +381,24 @@ split_ordered_list_find(struct split_ordered_list* solist,
         node = (void*)native_pointer(node->_node_next);
     }
 }
+
+#include <stdio.h>
+void dump_solist(lispobj list)
+{
+    lispobj ptr = ((struct split_ordered_list*)INSTANCE(list))->head;
+    int n = 0;
+    do {
+        struct split_ordered_list_node* node = (void*)native_pointer(ptr);
+        lispobj next = node->_node_next;
+        sword_t hash = fixnum_value(node->node_hash);
+        if (hash & 1) { // ordinary node
+            fprintf(stderr, "key   node %p hash=%16lx next=%lx key=%lx\n",
+                    node, hash, next, node->so_key);
+            ++n;
+        } else {
+            fprintf(stderr, "dummy node %p hash=%16lx next=%lx\n", node, hash, next);
+        }
+        ptr = next;
+    } while (ptr != LFLIST_TAIL_ATOM);
+    fprintf(stderr, "%d keys\n", n);
+}

src/runtime/thread.c

@@ -92,6 +92,13 @@ link_thread(struct thread *th)
     th->next=all_threads;
     th->prev=0;
     all_threads=th;
+    /* This ID is just for debugging the C runtime with a relatively small number of
+     * threads and you want to refer to them in diagnostic messages using an identifier
+     * other than kernel thread or pthread which are often hard to distinguish by eye,
+     * and if thread names are blank or otherwise non-identifying.
+     * This number can wrap around, resulting in accidental re-use */
+    static uword_t serialno;
+    th->serialno = ++serialno; // under a lock, so this is fine
 }
 
 #ifdef LISP_FEATURE_SB_THREAD
@@ -284,7 +291,7 @@ extern pthread_key_t ignore_stop_for_gc;
 
 #if !defined COLLECT_GC_STATS && !defined STANDALONE_LDB && \
   defined LISP_FEATURE_LINUX && defined LISP_FEATURE_SB_THREAD && defined LISP_FEATURE_64_BIT
-#define COLLECT_GC_STATS
+#undef COLLECT_GC_STATS
 #endif
 #ifdef COLLECT_GC_STATS
 static struct timespec gc_start_time;
@@ -326,6 +333,11 @@ char* thread_name_from_pthread(pthread_t pointer){
 }
 #endif
 
+struct thread*  mainthread;
+extern void sml_current_user_set_arbdata(void*);
+extern void sml_current_worker_set_thread(void*,int);
+extern void smlgc_clear_alloc_ptr(struct alloc_ptr*);
+
 void create_main_lisp_thread(lispobj function) {
 #ifdef LISP_FEATURE_WIN32
     InitializeCriticalSection(&all_threads_lock);
@@ -333,8 +345,13 @@ void create_main_lisp_thread(lispobj function) {
     InitializeCriticalSection(&in_gc_lock);
 #endif
     struct thread *th = alloc_thread_struct(0);
+    mainthread = th;
     if (!th || arch_os_thread_init(th)==0 || !init_shared_attr_object())
         lose("can't create initial thread");
+    sml_current_worker_set_thread(th, 1);
+    sml_current_user_set_arbdata(th);
+
+    //SYMBOL(FORCE_WEAK_POINTER_BARRIER_ON)->value = 0;
     th->state_word.sprof_enable = 1;
 #if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_GCC_TLS && !defined LISP_FEATURE_WIN32
     pthread_key_create(&current_thread, 0);
@@ -373,6 +390,10 @@ void create_main_lisp_thread(lispobj function) {
 #ifdef COLLECT_GC_STATS
     atexit(summarize_gc_stats);
 #endif
+    fprintf(stderr, "create_main_thread: stack=%p:%p bindings=%p:%p TLS=%p:%p\n",
+            th->control_stack_start, th->control_stack_end,
+            th->binding_stack_start, th->alien_stack_start,
+            th, (char*)th + dynamic_values_bytes);
     /* WIN32 has a special stack arrangement, calling
      * call_into_lisp_first_time will put the new stack in the middle
      * of the current stack */
@@ -449,11 +470,13 @@ init_new_thread(struct thread *th,
 #endif
 }
 
+extern void smlgc_unregister_lisp_thread(struct thread*);
 static void
 unregister_thread(struct thread *th,
                   init_thread_data __attribute__((unused)) *scribble)
 {
     block_blockable_signals(0);
+    smlgc_unregister_lisp_thread(th);
     gc_close_thread_regions(th, LOCK_PAGE_TABLE|CONSUME_REMAINDER);
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     pop_gcing_safety(&scribble->safety);
@@ -479,6 +502,7 @@ unregister_thread(struct thread *th,
     os_sem_destroy(&semaphores->sprof_sem);
 #endif
 #ifndef LISP_FEATURE_SB_SAFEPOINT
+    //pthread_mutex_destroy(&extra_data->signal_delivery_lock);
     os_sem_destroy(&semaphores->state_sem);
     os_sem_destroy(&semaphores->state_not_running_sem);
     os_sem_destroy(&semaphores->state_not_stopped_sem);
@@ -515,6 +539,7 @@ void* new_thread_trampoline(void* arg)
 {
     struct thread* th = arg;
     ASSOCIATE_OS_THREAD(th);
+    th->os_kernel_tid = get_nonzero_tid();
 
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     init_thread_data scribble;
@@ -568,8 +593,14 @@ void* new_thread_trampoline(void* arg)
     && !defined LISP_FEATURE_SB_SAFEPOINT
     th->control_stack_end = (lispobj*)&arg + 1;
 #endif
-    th->os_kernel_tid = get_nonzero_tid();
     init_new_thread(th, SCRIBBLE, 0);
+    long foo[3] = {0xFEED, 0xC0FFEE, 0xBEAD};
+    extern void sml_start(void*), sml_end();
+    fprintf(stderr, "SB-VM thread %p gets control_stack_end %p\n", th, th->control_stack_end);
+    sml_start(foo);
+    sml_current_worker_set_thread(th, 1);
+    sml_current_user_set_arbdata(th);
+/*if (SYMBOL(USE_SMLGC)->value == make_fixnum(-1)) smlgc_clear_alloc_ptr(&th->cons_ap);*/
     // Passing the untagged pointer ensures 2 things:
     // - that the pinning mechanism works as designed, and not just by accident.
     // - that the initial stack does not contain a lisp pointer after it is not needed.
@@ -577,6 +608,7 @@ void* new_thread_trampoline(void* arg)
     funcall1(startfun, (lispobj)lispthread); // both pinned
     // Close the GC region and unlink from all_threads
     unregister_thread(th, SCRIBBLE);
+    sml_end(); // must balance with sml_start
 
     return 0;
 }
@@ -840,6 +872,18 @@ callback_wrapper_trampoline(
 
 #endif /* LISP_FEATURE_SB_THREAD */
 
+extern void smlgc_clear_alloc_ptr(struct alloc_ptr*);
+void initialize_bitmap_alloc_pointers(struct thread* th, int enable) {
+    int size_log2;
+    struct alloc_ptr* ap = &th->ap4;
+    sml_bmword_t mask = enable ? 1 : (sml_bmword_t)-1;
+    for (size_log2 = 4; size_log2 <= 12; ++size_log2, ++ap) {
+        ap->blocksize_bytes = 1 << size_log2;
+        smlgc_clear_alloc_ptr(ap);
+        ap->freebit.mask = mask;
+    }
+}
+
 /* this is called from any other thread to create the new one, and
  * initialize all parts of it that can be initialized from another
  * thread
@@ -926,7 +970,7 @@ alloc_thread_struct(void* spaces) {
     th->tls_size = dynamic_values_bytes;
 #endif
 
-    __attribute((unused)) lispobj* tls = (lispobj*)th;
+    lispobj* tls = (lispobj*)th;
 #ifdef THREAD_T_NIL_CONSTANTS_SLOT
     tls[THREAD_T_NIL_CONSTANTS_SLOT] = (NIL << 32) | LISP_T;
 #endif
@@ -945,6 +989,7 @@ alloc_thread_struct(void* spaces) {
     tls[THREAD_TEXT_CARD_COUNT_SLOT] = text_space_size / IMMOBILE_CARD_BYTES;
     tls[THREAD_TEXT_CARD_MARKS_SLOT] = (lispobj)text_page_touched_bits;
 #endif
+    tls[THREAD_STEPPING_SLOT] = 0;
 
     th->os_address = spaces;
     th->control_stack_start = (lispobj*)aligned_spaces;
@@ -994,6 +1039,7 @@ alloc_thread_struct(void* spaces) {
     memset(extra_data, 0, sizeof *extra_data);
 
 #if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT
+    //pthread_mutex_init(&extra_data->signal_delivery_lock);
     os_sem_init(&extra_data->state_sem, 1);
     os_sem_init(&extra_data->state_not_running_sem, 0);
     os_sem_init(&extra_data->state_not_stopped_sem, 0);
@@ -1029,6 +1075,8 @@ alloc_thread_struct(void* spaces) {
 #endif
 
     INIT_THREAD_REGIONS(th);
+    initialize_bitmap_alloc_pointers(th, use_smlgc);
+
 #ifdef LISP_FEATURE_SB_THREAD
     /* This parallels the same logic in globals.c for the
      * single-threaded foreign_function_call_active, KLUDGE and
@@ -1093,7 +1141,8 @@ alloc_thread_struct(void* spaces) {
         thread_private_events(th,i) = CreateEvent(NULL,FALSE,FALSE,NULL);
     thread_extra_data(th)->synchronous_io_handle_and_flag = 0;
 #endif
-    th->stepping = 0;
+    fprintf(stderr, "alloc_thread_struct: stack range: %p .. %p\n", th->control_stack_start,
+            th->control_stack_end);
     return th;
 }
 #ifdef LISP_FEATURE_SB_THREAD
@@ -1322,3 +1371,13 @@ void wake_thread(struct thread_instance* lispthread)
 #endif
 }
 #endif
+
+void print_thread_cons_metrics(){
+  /*
+  struct thread* th = get_sb_vm_thread();
+  printf("cons stats: 1=%d+%d 2=%d+%d 3=%d+%d\n",
+         (int)th->cons1_fast, (int)th->cons1_slow,
+         (int)th->cons2_fast, (int)th->cons2_slow,
+         (int)th->cons3_fast, (int)th->cons3_slow);
+  */
+}

src/runtime/traceroot.c

@@ -47,7 +47,7 @@ typedef struct hopscotch_table* inverted_heap_t;
 #define inverted_heap_get_ref(graph, key) hopscotch_get_ref(graph, key)
 #endif
 
-int heap_trace_verbose = 0;
+int heap_trace_verbose = 2;
 
 typedef uintptr_t traceroot_pointer;
 
@@ -91,12 +91,10 @@ static int traceroot_gen_of(lispobj obj) {
 
 static const char* classify_obj(lispobj ptr)
 {
-    extern lispobj* instance_classoid_name(lispobj*);
-
     lispobj* name; // a Lisp string
     switch(lowtag_of(ptr)) {
     case INSTANCE_POINTER_LOWTAG:
-        name = instance_classoid_name(native_pointer(ptr));
+        name = (void*)instance_classoid_name(native_pointer(ptr));
         if (widetag_of(name) == SIMPLE_BASE_STRING_WIDETAG) return (char*)(name + 2);
         break;
     case LIST_POINTER_LOWTAG:
@@ -715,8 +713,10 @@ static bool record_ptr(lispobj* source, lispobj target, struct scan_state* ss)
     return 1;
 }
 
+extern int in_sml_heap_range_p(lispobj);
 #define relevant_ptr_p(x) \
- (find_page_index((void*)(x))>=0||immobile_space_p((lispobj)(x))||readonly_space_p(x))
+ (in_sml_heap_range_p(x) || find_page_index((void*)(x))>=0 || \
+  immobile_space_p((lispobj)(x)) || readonly_space_p(x))
 
 #define COUNT_POINTER(x) { ++n_scanned_words; \
       if (!is_lisp_pointer(x)) ++n_immediates; \
@@ -812,6 +812,15 @@ static uword_t build_refs(lispobj* where, lispobj* end,
                 }
             }
             break;
+        case SYMBOL_WIDETAG:
+            {
+            struct symbol* sym = (void*)where;
+            check_ptr(decode_symbol_name(sym->name));
+            check_ptr(sym->value);
+            check_ptr(sym->info);
+            check_ptr(sym->fdefn);
+            }
+            continue;
         case FILLER_WIDETAG: continue;
         default:
             if (!(other_immediate_lowtag_p(widetag) && LOWTAG_FOR_WIDETAG(widetag)))
@@ -871,6 +880,20 @@ static void scan_spaces(struct scan_state* ss)
     show_tally(old, ss, "text");
 #endif
     old = *ss;
+#if 0
+    extern int gather_all_smlheap_objects(uword_t** list);
+    uword_t* list;
+    int count = gather_all_smlheap_objects(&list);
+    printf("traceroot got %d SML heap objects\n", count);
+    int i;
+    for(i=0; i<count; ++i) {
+      lispobj* objbase = (lispobj*)list[i];
+      lispobj* end = objbase + object_size(objbase);
+      build_refs(objbase, end, ss);
+    }
+    show_tally(old, ss, "SMLgc");
+    old = *ss;
+#endif
     walk_generation((uword_t(*)(lispobj*,lispobj*,uword_t))build_refs,
                     -1, (uword_t)ss);
     show_tally(old, ss, "dynamic");

src/runtime/wrap.c

@@ -622,3 +622,23 @@ double sb_hypot (double x, double y) {
 }
 
 #endif
+
+#if 0
+extern void clobber_clobberables();
+int clock_gettime(int clockid, struct timespec* ts)
+{
+  int fooseconds = 0;
+  if (clockid == CLOCK_THREAD_CPUTIME_ID) {
+    ts->tv_sec  = 0xBABAB00E;
+    ts->tv_nsec = 0xABADBAD;
+  clobber_clobberables();
+    return 0;
+  } else {
+    ts->tv_sec = ++fooseconds;
+    ts->tv_nsec = 1;
+  clobber_clobberables();
+    return 0;
+  }
+
+}
+#endif

src/runtime/x86-64-arch.c

@@ -29,6 +29,7 @@
 #include "unaligned.h"
 #include "search.h"
 #include "var-io.h"
+#include "code.h"
 
 #include "genesis/fdefn.h"
 #include "genesis/static-symbols.h"
@@ -38,6 +39,7 @@
 
 #define INT3_INST 0xCC
 #define INTO_INST 0xCE
+#define UD1_INST 0xb90f
 #define UD2_INST 0x0b0f
 #define BREAKPOINT_WIDTH 1
 
@@ -820,3 +822,89 @@ lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs) {
 }
 
 #include "x86-arch-shared.inc"
+
+#define JAE_rel8 0x73
+
+int possibly_implicit_pseudoatomic(unsigned char* pc) {
+    unsigned char opcode = *pc;
+    if (opcode == JAE_rel8) return 1;
+    if (opcode == 0x0F && pc[1] == 0x83) return 1; // JAE rel32
+    int lock = 0;
+    if (*pc == 0xF0) { lock = 1; ++pc; }
+    if ((*pc & 0xF8) == 0x48) { // REX.w
+        unsigned char first = pc[1];
+        unsigned char second = pc[2];
+        if (first == 0x89 || // MOV r/m64, r64
+            first == 0xC7 || // MOV r/m64, imm32
+            (lock && (first == 0x0F) && (second == 0xB1)))
+            return 1;
+    }
+    return 0;
+}
+
+uint32_t* code_pseudoatomic_locs(struct code* code, int* pcount)
+{
+    int n_funs = code_n_funs(code);
+    if (!n_funs) return 0;
+    uint32_t* end = (uint32_t*)((lispobj*)code + code_total_nwords(code));
+    int n_locations = end[-(n_funs + 2)];
+    if (!n_locations) return 0;
+    *pcount = n_locations;
+    return &end[-(n_funs + 2 + n_locations)];
+}
+
+void adjust_context_for_implicit_pseudoatomic(os_context_t* context)
+{
+    extern uword_t* codeblob_from_interior_ptr(void* addr);
+    unsigned char* pc = (void*)os_context_pc(context);
+    if (!possibly_implicit_pseudoatomic(pc)) { // look only at the bytes @ PC
+        tprintf_("GC sig @ %p", pc);
+        return;
+    }
+    lispobj* code = codeblob_from_interior_ptr(pc);
+    if (!code) {
+        tprintf_("GC sig @ %p (non-lisp)", pc);
+        return;
+    }
+    uint32_t* pa_locs;
+    int nlocs, loc_index = -1;
+    pa_locs = code_pseudoatomic_locs((void*)code, &nlocs);
+    unsigned char *condjmp = 0, *memory_op = 0;
+    if (pa_locs) {
+        // find the nearest pseudoatomic store (or cmpxchg) below PC
+        unsigned char* insts = (void*)code_text_start((void*)code);
+        uint32_t pc_offs = pc - insts;
+        loc_index = bsearch_lesseql_uint32(pc_offs, pa_locs, nlocs);
+        if (loc_index >= 0) {
+            condjmp = insts + pa_locs[loc_index];
+            if (*condjmp == JAE_rel8)
+                memory_op = condjmp + 2;
+            else
+                memory_op = condjmp + 6;
+        }
+    }
+    // If the interrupted PC is one of the two indivisible instructions
+    // following the CMP of the GC phase, then upon return-from-interupt
+    // take the branch.
+    if (pc == condjmp || pc == memory_op) {
+        /* If interrupted at either of the 2 instructions that follow comparison
+         * of the GC phase, take the slow path on return from interrupt, as if
+         * a phase change occurred just prior to delivery of the signal */
+        unsigned char* next_inst;
+        int disp;
+        if (*condjmp == JAE_rel8) {
+            next_inst = condjmp + 2;
+            disp = (int)*(signed char*)(condjmp + 1);
+        } else {
+            next_inst = condjmp + 6;
+            disp = *(int*)(condjmp + 2);
+        }
+        pc = next_inst + disp;
+        set_os_context_pc(context, (uword_t)pc);
+        tprintf_("GC sig @ %p code %p + %x [%02x %02x %02x] phase %d, PA @ %p",
+                 pc, code, (int)((char*)pc - code_text_start((struct code*)code)),
+                 pc[0], pc[1], pc[3], get_sb_vm_thread()->gc_phase, condjmp);
+    } else {
+        tprintf_("GC sig @ %p not pseudo-atomic");
+    }
+}

src/runtime/x86-64-assem.S

@@ -83,7 +83,16 @@
 #define CARG2 %rsi
 #define CARG3 %rdx
 #endif
-	
+
+	.text
+	.globl  GNAME(exception_handling_load)
+	TYPE(GNAME(exception_handling_load))
+	.align	align_16byte,0x90
+GNAME(exception_handling_load):
+	mov (CARG1), %rax # if fault, handler loads RAX with 0 and skips this
+	ret
+	SIZE(GNAME(exception_handling_load))
+
 #ifdef LISP_FEATURE_OS_THREAD_STACK
         .text
 	.globl  GNAME(funcall1_switching_stack)
@@ -114,6 +123,37 @@ GNAME(funcall1_switching_stack):
 #endif
 
 	.text
+	.globl  GNAME(get_nonvolatile_gprs)
+	TYPE(GNAME(get_nonvolatile_gprs))
+	.align	align_16byte,0x90
+	// copy rbx, r12..r15 (in no particular order) into array pointed to rdi
+GNAME(get_nonvolatile_gprs):
+	mov %r12, 0(%rdi)
+	mov %r13, 8(%rdi)
+	mov %r14, 16(%rdi)
+	mov %r15, 24(%rdi)
+	mov %rbx, 32(%rdi)
+	ret
+	SIZE(GNAME(get_nonvolatile_gprs))
+
+	.globl	GNAME(clobber_clobberables)
+	TYPE(GNAME(clobber_clobberables))
+	.align	align_16byte,0x90
+GNAME(clobber_clobberables):
+	xor %rax, %rax
+        lea 0xeefbad1(%rax), %rcx
+        lea 0xeefbad2(%rax), %rdx
+        lea 0xeefbad3(%rax), %rsi
+        lea 0xeefbad4(%rax), %rdi
+        lea 0xeefbad8(%rax), %r8
+        lea 0xeefbad9(%rax), %r9
+        lea 0xeefbada(%rax), %r10
+        lea 0xeefbadb(%rax), %r11
+	ret
+	SIZE(GNAME(clobber_clobberables))
+
+	.globl	GNAME(clobber_clobberables)
+
 	.globl  GNAME(call_into_lisp_first_time_)
 	TYPE(GNAME(call_into_lisp_first_time_))
 

tests/allocator.pure.lisp

@@ -1,3 +1,4 @@
+(invoke-restart 'run-tests::skip-file)
 (progn
 (defun on-large-page-p (x)
   (and (eq (sb-ext:heap-allocated-p x) :dynamic)

tests/arena.impure.lisp

@@ -606,7 +606,14 @@
                   (format *error-output* "Failure:~{~%~A~}~%" lines)
                   (error  "Bad result for ~S" symbol))))))))))
 
-(defun collect-objects-pointing-off-heap ()
+;;; Using this function you can search for objects pointing
+;;; to a particular subspace, such as :STATIC or :READ-ONLY.
+;;; The default list of spaces '(NIL) implies that you want to see
+;;; any object NOT pointing to a GC-managed space.
+;;; As a special case, we ignore NIL in any slot, because without that
+;;; exception, most objects would point to static space
+;;; which is not particularly enlightening.
+(defun collect-objects-pointing-to (&optional (spaces '(nil)))
   (let (list)
     (flet ((add-to-result (obj referent)
              ;; If this is a code component and it points to fixups
@@ -624,8 +631,9 @@
                           list)))))
       (macrolet ((visit (referent)
                    `(let ((r ,referent))
-                      (when (and (is-lisp-pointer (get-lisp-obj-address r))
+                      (when (and r
-                                 (not (heap-allocated-p r))
+                                 (is-lisp-pointer (get-lisp-obj-address r))
+                                 (member (heap-allocated-p r) spaces)
                                  (add-to-result obj r))
                         (return-from done)))))
         (map-allocated-objects

tests/gc-smoketest.pure.lisp

@@ -1,4 +1,4 @@
-
+#|
 ;;; Please keep all the "smoke" tests in this file fairly lightweight.
 
 ;;; Don't crash on layoutless instances. It's that simple!
@@ -12,3 +12,4 @@
 (defvar *foo* (cons nil nil))
 (rplacd *foo* *foo*)
 (with-test (:name :circular-list) (gc :gen 7))
+|#

tests/run-tests.lisp

@@ -1,4 +1,4 @@
-#+(and linux sb-thread 64-bit)
+#+nil ; (and linux sb-thread 64-bit)
 (sb-alien:alien-funcall (sb-alien:extern-alien
                          "reset_gc_stats"
                          (function sb-alien:void)))

tests/x86-64-codegen.impure.lisp

@@ -19,6 +19,22 @@
   (make-list (reduce #'max (mapcar #'length k))))
 (compile 'foo)
 
+
+(with-test (:name :recognize-implicit-pseudoatomic)
+  (with-alien ((matchp (function int system-area-pointer)
+                       :extern "possibly_implicit_pseudoatomic"))
+    (let ((all (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag))
+          (n 0))
+      (dolist (c all)
+        (let ((locs (sb-impl::code-pseudo-atomic-locations c)))
+          (when (plusp (length locs))
+            (sb-int:dovector (loc locs)
+              (let ((abs-pc (sb-sys:sap+ (sb-kernel:code-instructions c) loc)))
+                (assert (= (alien-funcall matchp abs-pc) 1))))
+            (incf n))))
+      (format t "~&Tested ~D/~D codeblobs~%" n (length all)))))
+
+
 (with-test (:name :lowtag-test-elision)
   ;; This tests a certain behavior that while "undefined" should at least not
   ;; be fatal. This is important for things like hash-table :TEST where we might