#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
#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;
/*
* copying objects
*/
-
-/* to copy a boxed object */
+static
lispobj
-copy_object(lispobj object, long nwords)
+gc_general_copy_object(lispobj object, long nwords, int page_type_flag)
{
int tag;
lispobj *new;
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, page_type_flag, ALLOC_QUICK);
/* Copy the object. */
memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
return make_lispobj(new,tag);
}
+/* to copy a boxed object */
+lispobj
+copy_object(lispobj object, long nwords)
+{
+ return gc_general_copy_object(object, nwords, BOXED_PAGE_FLAG);
+}
+
+lispobj
+copy_code_object(lispobj object, long nwords)
+{
+ return gc_general_copy_object(object, nwords, CODE_PAGE_FLAG);
+}
+
static long scav_lose(lispobj *where, lispobj object); /* forward decl */
/* FIXME: Most calls end up going to some trouble to compute an
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)) {
nwords = ncode_words + nheader_words;
nwords = CEILING(nwords, 2);
- l_new_code = copy_object(l_code, nwords);
+ l_new_code = copy_code_object(l_code, nwords);
new_code = (struct code *) native_pointer(l_new_code);
#if defined(DEBUG_CODE_GC)
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);
scavenge(&function_ptr->name, 1);
scavenge(&function_ptr->arglist, 1);
scavenge(&function_ptr->type, 1);
+ scavenge(&function_ptr->info, 1);
}
return n_words;
/* 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));
/* 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));
/* 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. */
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;
}
}
+\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
/*
{
lose("no scavenge function for object 0x%08x (widetag 0x%x)\n",
(unsigned long)object,
- widetag_of(*(lispobj*)native_pointer(object)));
+ widetag_of(object));
return 0; /* bogus return value to satisfy static type checking */
}
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
/* 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;
}
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;
#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++)
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);
}
return (NULL);
}
+
+boolean
+maybe_gc(os_context_t *context)
+{
+ lispobj gc_happened;
+ struct thread *thread = arch_os_get_current_thread();
+
+ 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
+ check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
+ unblock_gc_signals(0, 0);
+#endif
+ FSHOW((stderr, "/maybe_gc: calling SUB_GC\n"));
+ /* FIXME: Nothing must go wrong during GC else we end up running
+ * the debugger, error handlers, and user code in general in a
+ * potentially unsafe place. Running out of the control stack or
+ * the heap in SUB-GC are ways to lose. Of course, deferrables
+ * cannot be unblocked because there may be a pending handler, or
+ * we may even be in a WITHOUT-INTERRUPTS. */
+ gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
+ FSHOW((stderr, "/maybe_gc: gc_happened=%s\n",
+ (gc_happened == NIL) ? "NIL" : "T"));
+ if ((gc_happened != NIL) &&
+ /* See if interrupts are enabled or it's possible to enable
+ * them. POST-GC has a similar check, but we don't want to
+ * unlock deferrables in that case and get a pending interrupt
+ * here. */
+ ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) ||
+ (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) {
+#ifndef LISP_FEATURE_WIN32
+ sigset_t *context_sigmask = os_context_sigmask_addr(context);
+ if (!deferrables_blocked_p(context_sigmask)) {
+ thread_sigmask(SIG_SETMASK, context_sigmask, 0);
+ check_gc_signals_unblocked_or_lose(0);
+#endif
+ FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
+ funcall0(StaticSymbolFunction(POST_GC));
+#ifndef LISP_FEATURE_WIN32
+ } else {
+ FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
+ }
+#endif
+ }
+ undo_fake_foreign_function_call(context);
+ FSHOW((stderr, "/maybe_gc: returning\n"));
+ return (gc_happened != NIL);
+}
+
+#define BYTES_ZERO_BEFORE_END (1<<12)
+
+/* There used to be a similar function called SCRUB-CONTROL-STACK in
+ * Lisp and another called zero_stack() in cheneygc.c, but since it's
+ * shorter to express in, and more often called from C, I keep only
+ * the C one after fixing it. -- MG 2009-03-25 */
+
+/* Zero the unused portion of the control stack so that old objects
+ * are not kept alive because of uninitialized stack variables.
+ *
+ * "To summarize the problem, since not all allocated stack frame
+ * slots are guaranteed to be written by the time you call an another
+ * function or GC, there may be garbage pointers retained in your dead
+ * stack locations. The stack scrubbing only affects the part of the
+ * stack from the SP to the end of the allocated stack." - ram, on
+ * cmucl-imp, Tue, 25 Sep 2001
+ *
+ * So, as an (admittedly lame) workaround, from time to time we call
+ * scrub-control-stack to zero out all the unused portion. This is
+ * supposed to happen when the stack is mostly empty, so that we have
+ * a chance of clearing more of it: callers are currently (2002.07.18)
+ * REPL, SUB-GC and sig_stop_for_gc_handler. */
+
+/* Take care not to tread on the guard page and the hard guard page as
+ * it would be unkind to sig_stop_for_gc_handler. Touching the return
+ * guard page is not dangerous. For this to work the guard page must
+ * be zeroed when protected. */
+
+/* FIXME: I think there is no guarantee that once
+ * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This
+ * may be what the "lame" adjective in the above comment is for. In
+ * this case, exact gc may lose badly. */
+void
+scrub_control_stack(void)
+{
+ struct thread *th = arch_os_get_current_thread();
+ os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
+ os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
+ lispobj *sp;
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ sp = (lispobj *)&sp - 1;
+#else
+ sp = current_control_stack_pointer;
+#endif
+ scrub:
+ if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) &&
+ ((os_vm_address_t)sp >= hard_guard_page_address)) ||
+ (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) &&
+ ((os_vm_address_t)sp >= guard_page_address) &&
+ (th->control_stack_guard_page_protected != NIL)))
+ return;
+#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
+ do {
+ *sp = 0;
+ } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
+ if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size))
+ return;
+ do {
+ if (*sp)
+ goto scrub;
+ } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1));
+#else
+ do {
+ *sp = 0;
+ } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
+ if ((os_vm_address_t)sp >= hard_guard_page_address)
+ return;
+ do {
+ if (*sp)
+ goto scrub;
+ } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1));
+#endif
+}
+\f
+#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
+
+/* Scavenging Interrupt Contexts */
+
+static int boxed_registers[] = BOXED_REGISTERS;
+
+/* The GC has a notion of an "interior pointer" register, an unboxed
+ * register that typically contains a pointer to inside an object
+ * referenced by another pointer. The most obvious of these is the
+ * program counter, although many compiler backends define a "Lisp
+ * Interior Pointer" register known to the runtime as reg_LIP, and
+ * various CPU architectures have other registers that also partake of
+ * the interior-pointer nature. As the code for pairing an interior
+ * pointer value up with its "base" register, and fixing it up after
+ * scavenging is complete is horribly repetitive, a few macros paper
+ * over the monotony. --AB, 2010-Jul-14 */
+
+/* These macros are only ever used over a lexical environment which
+ * defines a pointer to an os_context_t called context, thus we don't
+ * bother to pass that context in as a parameter. */
+
+/* Define how to access a given interior pointer. */
+#define ACCESS_INTERIOR_POINTER_pc \
+ *os_context_pc_addr(context)
+#define ACCESS_INTERIOR_POINTER_lip \
+ *os_context_register_addr(context, reg_LIP)
+#define ACCESS_INTERIOR_POINTER_lr \
+ *os_context_lr_addr(context)
+#define ACCESS_INTERIOR_POINTER_npc \
+ *os_context_npc_addr(context)
+#define ACCESS_INTERIOR_POINTER_ctr \
+ *os_context_ctr_addr(context)
+
+#define INTERIOR_POINTER_VARS(name) \
+ unsigned long name##_offset; \
+ int name##_register_pair
+
+#define PAIR_INTERIOR_POINTER(name) \
+ pair_interior_pointer(context, \
+ ACCESS_INTERIOR_POINTER_##name, \
+ &name##_offset, \
+ &name##_register_pair)
+
+/* One complexity here is that if a paired register is not found for
+ * an interior pointer, then that pointer does not get updated.
+ * Originally, there was some commentary about using an index of -1
+ * when calling os_context_register_addr() on SPARC referring to the
+ * program counter, but the real reason is to allow an interior
+ * pointer register to point to the runtime, read-only space, or
+ * static space without problems. */
+#define FIXUP_INTERIOR_POINTER(name) \
+ do { \
+ if (name##_register_pair >= 0) { \
+ ACCESS_INTERIOR_POINTER_##name = \
+ (*os_context_register_addr(context, \
+ name##_register_pair) \
+ & ~LOWTAG_MASK) \
+ + name##_offset; \
+ } \
+ } while (0)
+
+
+static void
+pair_interior_pointer(os_context_t *context, unsigned long pointer,
+ unsigned long *saved_offset, int *register_pair)
+{
+ int i;
+
+ /*
+ * I (RLT) think this is trying to find the boxed register that is
+ * closest to the LIP address, without going past it. Usually, it's
+ * reg_CODE or reg_LRA. But sometimes, nothing can be found.
+ */
+ /* 0x7FFFFFFF on 32-bit platforms;
+ 0x7FFFFFFFFFFFFFFF on 64-bit platforms */
+ *saved_offset = (((unsigned long)1) << (N_WORD_BITS - 1)) - 1;
+ *register_pair = -1;
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ unsigned long reg;
+ long offset;
+ int index;
+
+ index = boxed_registers[i];
+ reg = *os_context_register_addr(context, index);
+
+ /* An interior pointer is never relative to a non-pointer
+ * register (an oversight in the original implementation).
+ * The simplest argument for why this is true is to consider
+ * the fixnum that happens by coincide to be the word-index in
+ * memory of the header for some object plus two. This is
+ * happenstance would cause the register containing the fixnum
+ * to be selected as the register_pair if the interior pointer
+ * is to anywhere after the first two words of the object.
+ * The fixnum won't be changed during GC, but the object might
+ * move, thus destroying the interior pointer. --AB,
+ * 2010-Jul-14 */
+
+ if (is_lisp_pointer(reg) &&
+ ((reg & ~LOWTAG_MASK) <= pointer)) {
+ offset = pointer - (reg & ~LOWTAG_MASK);
+ if (offset < *saved_offset) {
+ *saved_offset = offset;
+ *register_pair = index;
+ }
+ }
+ }
+}
+
+static void
+scavenge_interrupt_context(os_context_t * context)
+{
+ int i;
+
+ /* FIXME: The various #ifdef noise here is precisely that: noise.
+ * Is it possible to fold it into the macrology so that we have
+ * one set of #ifdefs and then INTERIOR_POINTER_VARS /et alia/
+ * compile out for the registers that don't exist on a given
+ * platform? */
+
+ INTERIOR_POINTER_VARS(pc);
+#ifdef reg_LIP
+ INTERIOR_POINTER_VARS(lip);
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+ INTERIOR_POINTER_VARS(lr);
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
+ INTERIOR_POINTER_VARS(npc);
+#endif
+#ifdef LISP_FEATURE_PPC
+ INTERIOR_POINTER_VARS(ctr);
+#endif
+
+ PAIR_INTERIOR_POINTER(pc);
+#ifdef reg_LIP
+ PAIR_INTERIOR_POINTER(lip);
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+ PAIR_INTERIOR_POINTER(lr);
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
+ PAIR_INTERIOR_POINTER(npc);
+#endif
+#ifdef LISP_FEATURE_PPC
+ PAIR_INTERIOR_POINTER(ctr);
+#endif
+
+ /* Scavenge all boxed registers in the context. */
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ int index;
+ lispobj foo;
+
+ index = boxed_registers[i];
+ foo = *os_context_register_addr(context, index);
+ scavenge(&foo, 1);
+ *os_context_register_addr(context, index) = foo;
+
+ /* this is unlikely to work as intended on bigendian
+ * 64 bit platforms */
+
+ scavenge((lispobj *) os_context_register_addr(context, index), 1);
+ }
+
+ /* Now that the scavenging is done, repair the various interior
+ * pointers. */
+ FIXUP_INTERIOR_POINTER(pc);
+#ifdef reg_LIP
+ FIXUP_INTERIOR_POINTER(lip);
+#endif
+#ifdef ARCH_HAS_LINK_REGISTER
+ FIXUP_INTERIOR_POINTER(lr);
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
+ FIXUP_INTERIOR_POINTER(npc);
+#endif
+#ifdef LISP_FEATURE_PPC
+ FIXUP_INTERIOR_POINTER(ctr);
+#endif
+}
+
+void
+scavenge_interrupt_contexts(struct thread *th)
+{
+ int i, index;
+ os_context_t *context;
+
+ index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
+
+#if defined(DEBUG_PRINT_CONTEXT_INDEX)
+ printf("Number of active contexts: %d\n", index);
+#endif
+
+ for (i = 0; i < index; i++) {
+ context = th->interrupt_contexts[i];
+ scavenge_interrupt_context(context);
+ }
+}
+#endif /* x86oid targets */
projects / sbcl.git / blobdiff