1.0.23.7: introduce page type flags
[sbcl.git] / src / runtime / gc-common.c
index cdbefd4..2c16012 100644 (file)
 #include "validate.h"
 #include "lispregs.h"
 #include "arch.h"
-#include "fixnump.h"
 #include "gc.h"
 #include "genesis/primitive-objects.h"
 #include "genesis/static-symbols.h"
 #include "genesis/layout.h"
+#include "genesis/hash-table.h"
 #include "gc-internal.h"
 
 #ifdef LISP_FEATURE_SPARC
@@ -52,6 +52,9 @@
 #endif
 #endif
 
+size_t dynamic_space_size = DEFAULT_DYNAMIC_SPACE_SIZE;
+size_t thread_control_stack_size = DEFAULT_CONTROL_STACK_SIZE;
+
 inline static boolean
 forwarding_pointer_p(lispobj *pointer) {
     lispobj first_word=*pointer;
@@ -109,7 +112,7 @@ copy_object(lispobj object, long nwords)
     tag = lowtag_of(object);
 
     /* Allocate space. */
-    new = gc_general_alloc(nwords*N_WORD_BYTES,ALLOC_BOXED,ALLOC_QUICK);
+    new = gc_general_alloc(nwords*N_WORD_BYTES, BOXED_PAGE_FLAG, ALLOC_QUICK);
 
     /* Copy the object. */
     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
@@ -134,7 +137,9 @@ scavenge(lispobj *start, long n_words)
 
         lispobj object = *object_ptr;
 #ifdef LISP_FEATURE_GENCGC
-        gc_assert(!forwarding_pointer_p(object_ptr));
+        if (forwarding_pointer_p(object_ptr))
+            lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n",
+                 object_ptr, start, n_words);
 #endif
         if (is_lisp_pointer(object)) {
             if (from_space_p(object)) {
@@ -156,25 +161,28 @@ scavenge(lispobj *start, long n_words)
                 n_words_scavenged = 1;
             }
         }
-#ifndef LISP_FEATURE_GENCGC
-        /* this workaround is probably not necessary for gencgc; at least, the
-         * behaviour it describes has never been reported */
-        else if (n_words==1) {
-            /* there are some situations where an
-               other-immediate may end up in a descriptor
-               register.  I'm not sure whether this is
-               supposed to happen, but if it does then we
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
+        /* This workaround is probably not needed for those ports
+           which don't have a partitioned register set (and therefore
+           scan the stack conservatively for roots). */
+        else if (n_words == 1) {
+            /* there are some situations where an other-immediate may
+               end up in a descriptor register.  I'm not sure whether
+               this is supposed to happen, but if it does then we
                don't want to (a) barf or (b) scavenge over the
-               data-block, because there isn't one.  So, if
-               we're checking a single word and it's anything
-               other than a pointer, just hush it up */
-            int type=widetag_of(object);
-            n_words_scavenged=1;
-
-            if ((scavtab[type]==scav_lose) ||
-                (((scavtab[type])(start,object))>1)) {
-                fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p.  If you can\nreproduce this warning, send a bug report (see manual page for details)\n",
-                        object,start);
+               data-block, because there isn't one.  So, if we're
+               checking a single word and it's anything other than a
+               pointer, just hush it up */
+            int widetag = widetag_of(object);
+            n_words_scavenged = 1;
+
+            if ((scavtab[widetag] == scav_lose) ||
+                (((sizetab[widetag])(object_ptr)) > 1)) {
+                fprintf(stderr,"warning: \
+attempted to scavenge non-descriptor value %x at %p.\n\n\
+If you can reproduce this warning, please send a bug report\n\
+(see manual page for details).\n",
+                        object, object_ptr);
             }
         }
 #endif
@@ -187,8 +195,8 @@ scavenge(lispobj *start, long n_words)
                 (scavtab[widetag_of(object)])(object_ptr, object);
         }
     }
-    gc_assert_verbose(object_ptr == end, "Final object pointer %p, end %p\n",
-                      object_ptr, end);
+    gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n",
+                      object_ptr, start, end);
 }
 
 static lispobj trans_fun_header(lispobj object); /* forward decls */
@@ -320,8 +328,12 @@ trans_code(struct code *code)
     os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words),
                     ncode_words * sizeof(long));
 
+#endif
+
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
     gencgc_apply_code_fixups(code, new_code);
 #endif
+
     return new_code;
 }
 
@@ -348,7 +360,8 @@ scav_code_header(lispobj *where, lispobj object)
          entry_point != NIL;
          entry_point = function_ptr->next) {
 
-        gc_assert_verbose(is_lisp_pointer(entry_point), "Entry point %lx\n",
+        gc_assert_verbose(is_lisp_pointer(entry_point),
+                          "Entry point %lx\n is not a lisp pointer.",
                           (long)entry_point);
 
         function_ptr = (struct simple_fun *) native_pointer(entry_point);
@@ -357,6 +370,7 @@ scav_code_header(lispobj *where, lispobj object)
         scavenge(&function_ptr->name, 1);
         scavenge(&function_ptr->arglist, 1);
         scavenge(&function_ptr->type, 1);
+        scavenge(&function_ptr->xrefs, 1);
     }
 
     return n_words;
@@ -538,7 +552,7 @@ trans_list(lispobj object)
 
     /* Copy 'object'. */
     new_cons = (struct cons *)
-        gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
+        gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
     new_cons->car = cons->car;
     new_cons->cdr = cons->cdr; /* updated later */
     new_list_pointer = make_lispobj(new_cons,lowtag_of(object));
@@ -563,7 +577,7 @@ trans_list(lispobj object)
 
         /* Copy 'cdr'. */
         new_cdr_cons = (struct cons*)
-            gc_general_alloc(sizeof(struct cons),ALLOC_BOXED,ALLOC_QUICK);
+            gc_general_alloc(sizeof(struct cons), BOXED_PAGE_FLAG, ALLOC_QUICK);
         new_cdr_cons->car = cdr_cons->car;
         new_cdr_cons->cdr = cdr_cons->cdr;
         new_cdr = make_lispobj(new_cdr_cons, lowtag_of(cdr));
@@ -698,7 +712,7 @@ size_boxed(lispobj *where)
 
 /* Note: on the sparc we don't have to do anything special for fdefns, */
 /* 'cause the raw-addr has a function lowtag. */
-#ifndef LISP_FEATURE_SPARC
+#if !defined(LISP_FEATURE_SPARC)
 static long
 scav_fdefn(lispobj *where, lispobj object)
 {
@@ -709,8 +723,7 @@ scav_fdefn(lispobj *where, lispobj object)
     /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
        fdefn->fun, fdefn->raw_addr)); */
 
-    if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET)
-        == (char *)((unsigned long)(fdefn->raw_addr))) {
+    if ((char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr) {
         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
 
         /* Don't write unnecessarily. */
@@ -1511,11 +1524,17 @@ size_weak_pointer(lispobj *where)
 
 void scan_weak_pointers(void)
 {
-    struct weak_pointer *wp;
-    for (wp = weak_pointers; wp != NULL; wp=wp->next) {
+    struct weak_pointer *wp, *next_wp;
+    for (wp = weak_pointers, next_wp = NULL; wp != NULL; wp = next_wp) {
         lispobj value = wp->value;
         lispobj *first_pointer;
         gc_assert(widetag_of(wp->header)==WEAK_POINTER_WIDETAG);
+
+        next_wp = wp->next;
+        wp->next = NULL;
+        if (next_wp == wp) /* gencgc uses a ref to self for end of list */
+            next_wp = NULL;
+
         if (!(is_lisp_pointer(value) && from_space_p(value)))
             continue;
 
@@ -1537,6 +1556,312 @@ void scan_weak_pointers(void)
     }
 }
 
+\f
+/* Hash tables */
+
+#if N_WORD_BITS == 32
+#define EQ_HASH_MASK 0x1fffffff
+#elif N_WORD_BITS == 64
+#define EQ_HASH_MASK 0x1fffffffffffffff
+#endif
+
+/* Compute the EQ-hash of KEY. This must match POINTER-HASH in
+ * target-hash-table.lisp.  */
+#define EQ_HASH(key) ((key) & EQ_HASH_MASK)
+
+/* List of weak hash tables chained through their NEXT-WEAK-HASH-TABLE
+ * slot. Set to NULL at the end of a collection.
+ *
+ * This is not optimal because, when a table is tenured, it won't be
+ * processed automatically; only the yougest generation is GC'd by
+ * default. On the other hand, all applications will need an
+ * occasional full GC anyway, so it's not that bad either.  */
+struct hash_table *weak_hash_tables = NULL;
+
+/* Return true if OBJ has already survived the current GC. */
+static inline int
+survived_gc_yet (lispobj obj)
+{
+    return (!is_lisp_pointer(obj) || !from_space_p(obj) ||
+            forwarding_pointer_p(native_pointer(obj)));
+}
+
+static inline int
+weak_hash_entry_alivep (lispobj weakness, lispobj key, lispobj value)
+{
+    switch (weakness) {
+    case KEY:
+        return survived_gc_yet(key);
+    case VALUE:
+        return survived_gc_yet(value);
+    case KEY_OR_VALUE:
+        return (survived_gc_yet(key) || survived_gc_yet(value));
+    case KEY_AND_VALUE:
+        return (survived_gc_yet(key) && survived_gc_yet(value));
+    default:
+        gc_assert(0);
+        /* Shut compiler up. */
+        return 0;
+    }
+}
+
+/* Return the beginning of data in ARRAY (skipping the header and the
+ * length) or NULL if it isn't an array of the specified widetag after
+ * all. */
+static inline lispobj *
+get_array_data (lispobj array, int widetag, unsigned long *length)
+{
+    if (is_lisp_pointer(array) &&
+        (widetag_of(*(lispobj *)native_pointer(array)) == widetag)) {
+        if (length != NULL)
+            *length = fixnum_value(((lispobj *)native_pointer(array))[1]);
+        return ((lispobj *)native_pointer(array)) + 2;
+    } else {
+        return NULL;
+    }
+}
+
+/* Only need to worry about scavenging the _real_ entries in the
+ * table. Phantom entries such as the hash table itself at index 0 and
+ * the empty marker at index 1 were scavenged by scav_vector that
+ * either called this function directly or arranged for it to be
+ * called later by pushing the hash table onto weak_hash_tables. */
+static void
+scav_hash_table_entries (struct hash_table *hash_table)
+{
+    lispobj *kv_vector;
+    unsigned long kv_length;
+    lispobj *index_vector;
+    unsigned long length;
+    lispobj *next_vector;
+    unsigned long next_vector_length;
+    lispobj *hash_vector;
+    unsigned long hash_vector_length;
+    lispobj empty_symbol;
+    lispobj weakness = hash_table->weakness;
+    unsigned long i;
+
+    kv_vector = get_array_data(hash_table->table,
+                               SIMPLE_VECTOR_WIDETAG, &kv_length);
+    if (kv_vector == NULL)
+        lose("invalid kv_vector %x\n", hash_table->table);
+
+    index_vector = get_array_data(hash_table->index_vector,
+                                  SIMPLE_ARRAY_WORD_WIDETAG, &length);
+    if (index_vector == NULL)
+        lose("invalid index_vector %x\n", hash_table->index_vector);
+
+    next_vector = get_array_data(hash_table->next_vector,
+                                 SIMPLE_ARRAY_WORD_WIDETAG,
+                                 &next_vector_length);
+    if (next_vector == NULL)
+        lose("invalid next_vector %x\n", hash_table->next_vector);
+
+    hash_vector = get_array_data(hash_table->hash_vector,
+                                 SIMPLE_ARRAY_WORD_WIDETAG,
+                                 &hash_vector_length);
+    if (hash_vector != NULL)
+        gc_assert(hash_vector_length == next_vector_length);
+
+     /* These lengths could be different as the index_vector can be a
+      * different length from the others, a larger index_vector could
+      * help reduce collisions. */
+     gc_assert(next_vector_length*2 == kv_length);
+
+    empty_symbol = kv_vector[1];
+    /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
+    if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
+        SYMBOL_HEADER_WIDETAG) {
+        lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
+             *(lispobj *)native_pointer(empty_symbol));
+    }
+
+    /* Work through the KV vector. */
+    for (i = 1; i < next_vector_length; i++) {
+        lispobj old_key = kv_vector[2*i];
+        lispobj value = kv_vector[2*i+1];
+        if ((weakness == NIL) ||
+            weak_hash_entry_alivep(weakness, old_key, value)) {
+
+            /* Scavenge the key and value. */
+            scavenge(&kv_vector[2*i],2);
+
+            /* If an EQ-based key has moved, mark the hash-table for
+             * rehashing. */
+            if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
+                lispobj new_key = kv_vector[2*i];
+
+                if (old_key != new_key && new_key != empty_symbol) {
+                    hash_table->needs_rehash_p = T;
+                }
+            }
+        }
+    }
+}
+
+long
+scav_vector (lispobj *where, lispobj object)
+{
+    unsigned long kv_length;
+    lispobj *kv_vector;
+    struct hash_table *hash_table;
+
+    /* SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based and weak
+     * hash tables in the Lisp HASH-TABLE code to indicate need for
+     * special GC support. */
+    if (HeaderValue(object) == subtype_VectorNormal)
+        return 1;
+
+    kv_length = fixnum_value(where[1]);
+    kv_vector = where + 2;  /* Skip the header and length. */
+    /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
+
+    /* Scavenge element 0, which may be a hash-table structure. */
+    scavenge(where+2, 1);
+    if (!is_lisp_pointer(where[2])) {
+        /* This'll happen when REHASH clears the header of old-kv-vector
+         * and fills it with zero, but some other thread simulatenously
+         * sets the header in %%PUTHASH.
+         */
+        fprintf(stderr,
+                "Warning: no pointer at %lx in hash table: this indicates "
+                "non-fatal corruption caused by concurrent access to a "
+                "hash-table from multiple threads. Any accesses to "
+                "hash-tables shared between threads should be protected "
+                "by locks.\n", (unsigned long)&where[2]);
+        // We've scavenged three words.
+        return 3;
+    }
+    hash_table = (struct hash_table *)native_pointer(where[2]);
+    /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
+    if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
+        lose("hash table not instance (%x at %x)\n",
+             hash_table->header,
+             hash_table);
+    }
+
+    /* Scavenge element 1, which should be some internal symbol that
+     * the hash table code reserves for marking empty slots. */
+    scavenge(where+3, 1);
+    if (!is_lisp_pointer(where[3])) {
+        lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
+    }
+
+    /* Scavenge hash table, which will fix the positions of the other
+     * needed objects. */
+    scavenge((lispobj *)hash_table,
+             sizeof(struct hash_table) / sizeof(lispobj));
+
+    /* Cross-check the kv_vector. */
+    if (where != (lispobj *)native_pointer(hash_table->table)) {
+        lose("hash_table table!=this table %x\n", hash_table->table);
+    }
+
+    if (hash_table->weakness == NIL) {
+        scav_hash_table_entries(hash_table);
+    } else {
+        /* Delay scavenging of this table by pushing it onto
+         * weak_hash_tables (if it's not there already) for the weak
+         * object phase. */
+        if (hash_table->next_weak_hash_table == NIL) {
+            hash_table->next_weak_hash_table = (lispobj)weak_hash_tables;
+            weak_hash_tables = hash_table;
+        }
+    }
+
+    return (CEILING(kv_length + 2, 2));
+}
+
+void
+scav_weak_hash_tables (void)
+{
+    struct hash_table *table;
+
+    /* Scavenge entries whose triggers are known to survive. */
+    for (table = weak_hash_tables; table != NULL;
+         table = (struct hash_table *)table->next_weak_hash_table) {
+        scav_hash_table_entries(table);
+    }
+}
+
+/* Walk through the chain whose first element is *FIRST and remove
+ * dead weak entries. */
+static inline void
+scan_weak_hash_table_chain (struct hash_table *hash_table, lispobj *prev,
+                            lispobj *kv_vector, lispobj *index_vector,
+                            lispobj *next_vector, lispobj *hash_vector,
+                            lispobj empty_symbol, lispobj weakness)
+{
+    unsigned index = *prev;
+    while (index) {
+        unsigned next = next_vector[index];
+        lispobj key = kv_vector[2 * index];
+        lispobj value = kv_vector[2 * index + 1];
+        gc_assert(key != empty_symbol);
+        gc_assert(value != empty_symbol);
+        if (!weak_hash_entry_alivep(weakness, key, value)) {
+            unsigned count = fixnum_value(hash_table->number_entries);
+            gc_assert(count > 0);
+            *prev = next;
+            hash_table->number_entries = make_fixnum(count - 1);
+            next_vector[index] = fixnum_value(hash_table->next_free_kv);
+            hash_table->next_free_kv = make_fixnum(index);
+            kv_vector[2 * index] = empty_symbol;
+            kv_vector[2 * index + 1] = empty_symbol;
+            if (hash_vector)
+                hash_vector[index] = MAGIC_HASH_VECTOR_VALUE;
+        } else {
+            prev = &next_vector[index];
+        }
+        index = next;
+    }
+}
+
+static void
+scan_weak_hash_table (struct hash_table *hash_table)
+{
+    lispobj *kv_vector;
+    lispobj *index_vector;
+    unsigned long length = 0; /* prevent warning */
+    lispobj *next_vector;
+    unsigned long next_vector_length = 0; /* prevent warning */
+    lispobj *hash_vector;
+    lispobj empty_symbol;
+    lispobj weakness = hash_table->weakness;
+    unsigned long i;
+
+    kv_vector = get_array_data(hash_table->table,
+                               SIMPLE_VECTOR_WIDETAG, NULL);
+    index_vector = get_array_data(hash_table->index_vector,
+                                  SIMPLE_ARRAY_WORD_WIDETAG, &length);
+    next_vector = get_array_data(hash_table->next_vector,
+                                 SIMPLE_ARRAY_WORD_WIDETAG,
+                                 &next_vector_length);
+    hash_vector = get_array_data(hash_table->hash_vector,
+                                 SIMPLE_ARRAY_WORD_WIDETAG, NULL);
+    empty_symbol = kv_vector[1];
+
+    for (i = 0; i < length; i++) {
+        scan_weak_hash_table_chain(hash_table, &index_vector[i],
+                                   kv_vector, index_vector, next_vector,
+                                   hash_vector, empty_symbol, weakness);
+    }
+}
+
+/* Remove dead entries from weak hash tables. */
+void
+scan_weak_hash_tables (void)
+{
+    struct hash_table *table, *next;
+
+    for (table = weak_hash_tables; table != NULL; table = next) {
+        next = (struct hash_table *)table->next_weak_hash_table;
+        table->next_weak_hash_table = NIL;
+        scan_weak_hash_table(table);
+    }
+
+    weak_hash_tables = NULL;
+}
 
 \f
 /*
@@ -1579,7 +1904,7 @@ size_lose(lispobj *where)
 void
 gc_init_tables(void)
 {
-    long i;
+    unsigned long i;
 
     /* Set default value in all slots of scavenge table.  FIXME
      * replace this gnarly sizeof with something based on
@@ -1599,7 +1924,8 @@ gc_init_tables(void)
         /* skipping OTHER_IMMEDIATE_0_LOWTAG */
         scavtab[LIST_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_list_pointer;
         scavtab[ODD_FIXNUM_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_immediate;
-        scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_instance_pointer;
+        scavtab[INSTANCE_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] =
+            scav_instance_pointer;
         /* skipping OTHER_IMMEDIATE_1_LOWTAG */
         scavtab[OTHER_POINTER_LOWTAG|(i<<N_LOWTAG_BITS)] = scav_other_pointer;
     }
@@ -1715,16 +2041,15 @@ gc_init_tables(void)
     scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
     scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
     scavtab[CODE_HEADER_WIDETAG] = scav_code_header;
-#ifndef LISP_FEATURE_GENCGC     /* FIXME ..._X86 ? */
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
     scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header;
     scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header;
 #endif
+    scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
     scavtab[CLOSURE_HEADER_WIDETAG] = scav_closure_header;
-    scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_closure_header;
 #else
     scavtab[CLOSURE_HEADER_WIDETAG] = scav_boxed;
-    scavtab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = scav_boxed;
 #endif
     scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed;
     scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed;
@@ -1733,11 +2058,12 @@ gc_init_tables(void)
     scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate;
     scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate;
     scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance;
-#ifdef LISP_FEATURE_SPARC
+#if defined(LISP_FEATURE_SPARC)
     scavtab[FDEFN_WIDETAG] = scav_boxed;
 #else
     scavtab[FDEFN_WIDETAG] = scav_fdefn;
 #endif
+    scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
 
     /* transport other table, initialized same way as scavtab */
     for (i = 0; i < ((sizeof transother)/(sizeof transother[0])); i++)
@@ -2044,13 +2370,7 @@ gc_search_space(lispobj *start, size_t words, lispobj *pointer)
         lispobj thing = *start;
 
         /* If thing is an immediate then this is a cons. */
-        if (is_lisp_pointer(thing)
-            || (fixnump(thing))
-            || (widetag_of(thing) == CHARACTER_WIDETAG)
-#if N_WORD_BITS == 64
-            || (widetag_of(thing) == SINGLE_FLOAT_WIDETAG)
-#endif
-            || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG))
+        if (is_lisp_pointer(thing) || is_lisp_immediate(thing))
             count = 2;
         else
             count = (sizetab[widetag_of(thing)])(start);
@@ -2070,3 +2390,64 @@ gc_search_space(lispobj *start, size_t words, lispobj *pointer)
     }
     return (NULL);
 }
+
+boolean
+maybe_gc(os_context_t *context)
+{
+#ifndef LISP_FEATURE_WIN32
+    struct thread *thread = arch_os_get_current_thread();
+#endif
+
+    fake_foreign_function_call(context);
+    /* SUB-GC may return without GCing if *GC-INHIBIT* is set, in
+     * which case we will be running with no gc trigger barrier
+     * thing for a while.  But it shouldn't be long until the end
+     * of WITHOUT-GCING.
+     *
+     * FIXME: It would be good to protect the end of dynamic space for
+     * CheneyGC and signal a storage condition from there.
+     */
+
+    /* Restore the signal mask from the interrupted context before
+     * calling into Lisp if interrupts are enabled. Why not always?
+     *
+     * Suppose there is a WITHOUT-INTERRUPTS block far, far out. If an
+     * interrupt hits while in SUB-GC, it is deferred and the
+     * os_context_sigmask of that interrupt is set to block further
+     * deferrable interrupts (until the first one is
+     * handled). Unfortunately, that context refers to this place and
+     * when we return from here the signals will not be blocked.
+     *
+     * A kludgy alternative is to propagate the sigmask change to the
+     * outer context.
+     */
+#ifndef LISP_FEATURE_WIN32
+    if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) {
+        sigset_t *context_sigmask = os_context_sigmask_addr(context);
+#ifdef LISP_FEATURE_SB_THREAD
+        /* What if the context we'd like to restore has GC signals
+         * blocked? Just skip the GC: we can't set GC_PENDING, because
+         * that would block the next attempt, and we don't know when
+         * we'd next check for it -- and it's hard to be sure that
+         * unblocking would be safe.
+         *
+         * FIXME: This is not actually much better: we may already have
+         * GC_PENDING set, and presumably our caller assumes that we will
+         * clear it. Perhaps we should, even though we don't actually GC? */
+        if (sigismember(context_sigmask,SIG_STOP_FOR_GC)) {
+            undo_fake_foreign_function_call(context);
+            return 1;
+        }
+#endif
+        thread_sigmask(SIG_SETMASK, context_sigmask, 0);
+    }
+    else
+        unblock_gc_signals();
+#endif
+    /* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
+     * otherwise two threads racing here may deadlock: the other will
+     * wait on the GC lock, and the other cannot stop the first one... */
+    funcall0(StaticSymbolFunction(SUB_GC));
+    undo_fake_foreign_function_call(context);
+    return 1;
+}