#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"
#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) {
/*
* 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)
/* 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. */
unsigned long hash_vector_length;
lispobj empty_symbol;
lispobj weakness = hash_table->weakness;
- long i;
+ unsigned long i;
kv_vector = get_array_data(hash_table->table,
SIMPLE_VECTOR_WIDETAG, &kv_length);
* and fills it with zero, but some other thread simulatenously
* sets the header in %%PUTHASH.
*/
- fprintf(stderr, "Warning: no pointer at %x 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", &where[2]);
+ 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;
}
lispobj *hash_vector;
lispobj empty_symbol;
lispobj weakness = hash_table->weakness;
- long i;
+ unsigned long i;
kv_vector = get_array_data(hash_table->table,
SIMPLE_VECTOR_WIDETAG, NULL);
{
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;
}
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);
boolean
maybe_gc(os_context_t *context)
{
-#ifndef LISP_FEATURE_WIN32
+ lispobj gc_happened;
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
* outer context.
*/
#ifndef LISP_FEATURE_WIN32
- if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) {
+ check_gc_signals_unblocked_in_sigset_or_lose
+ (os_context_sigmask_addr(context));
+ unblock_gc_signals();
+#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))) {
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;
+ if (!deferrables_blocked_in_sigset_p(context_sigmask)) {
+ FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
+ thread_sigmask(SIG_SETMASK, context_sigmask, 0);
+ check_gc_signals_unblocked_or_lose();
+ funcall0(StaticSymbolFunction(POST_GC));
+ } else {
+ FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n"));
}
-#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(SymbolFunction(SUB_GC));
undo_fake_foreign_function_call(context);
- return 1;
+ FSHOW((stderr, "/maybe_gc: returning\n"));
+ return (gc_happened != NIL);
}
projects / sbcl.git / blobdiff