X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Falloc.c;h=92e237b54662f1d4ae3dcf57c8a1dc69485e2e13;hb=a566e334e16d9cd0ff4f6858d796442305fd0f99;hp=8add02056b0e701235f24680f7aecc7b1cfd2ba9;hpb=902e93736a0888aa6b04dc328b1eb328423bf426;p=sbcl.git diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 8add020..92e237b 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -1,5 +1,5 @@ /* - * allocation routines for C code. For allocation done by Lisp look + * allocation routines for C code. For allocation done by Lisp look * instead at src/compiler/target/alloc.lisp and .../macros.lisp */ @@ -17,85 +17,122 @@ #include #include +#include "sbcl.h" #include "runtime.h" #include "os.h" -#include "sbcl.h" #include "alloc.h" #include "globals.h" #include "gc.h" #include "thread.h" +#include "pseudo-atomic.h" #include "genesis/vector.h" #include "genesis/cons.h" #include "genesis/bignum.h" #include "genesis/sap.h" +#include "genesis/code.h" -#define GET_FREE_POINTER() dynamic_space_free_pointer -#define SET_FREE_POINTER(new_value) \ - (dynamic_space_free_pointer = (new_value)) -#define GET_GC_TRIGGER() current_auto_gc_trigger -#define SET_GC_TRIGGER(new_value) \ - clear_auto_gc_trigger(); set_auto_gc_trigger(new_value); - -#define ALIGNED_SIZE(n) (n+LOWTAG_MASK) & ~LOWTAG_MASK +#define ALIGNED_SIZE(n) ((n) + LOWTAG_MASK) & ~LOWTAG_MASK -#if defined LISP_FEATURE_GENCGC -extern lispobj *alloc(int bytes); -lispobj * -pa_alloc(int bytes) +#ifdef LISP_FEATURE_GENCGC +static lispobj * +pa_alloc(int bytes, int page_type_flag) { - lispobj *result=0; - struct thread *th=arch_os_get_current_thread(); - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0),th); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1),th); - result=alloc(bytes); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0),th); - if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th)) - /* even if we gc at this point, the new allocation will be - * protected from being moved, because result is on the c stack - * and points to it */ - do_pending_interrupt(); - return result; -} + lispobj *result; + struct thread *th = arch_os_get_current_thread(); +#ifndef LISP_FEATURE_SB_SAFEPOINT + /* SIG_STOP_FOR_GC must be unblocked: else two threads racing here + * may deadlock: one will wait on the GC lock, and the other + * cannot stop the first one... */ + check_gc_signals_unblocked_or_lose(0); +#endif + + /* FIXME: OOAO violation: see arch_pseudo_* */ + set_pseudo_atomic_atomic(th); + result = general_alloc(bytes, page_type_flag); +#if 0 + /* See how the runtime deals with GC being triggerred. */ + if ((SymbolValue(GC_PENDING,th) == NIL) && + (SymbolValue(GC_INHIBIT,th) == NIL) && + (random() < RAND_MAX/100)) { + SetSymbolValue(GC_PENDING,T,th); + set_pseudo_atomic_interrupted(th); + maybe_save_gc_mask_and_block_deferrables(NULL); + } +#endif + clear_pseudo_atomic_atomic(th); + + if (get_pseudo_atomic_interrupted(th)) { + /* WARNING KLUDGE FIXME: pa_alloc() is not pseudo-atomic on + * anything but x86[-64]. maybe_defer_handler doesn't defer + * interrupts if foreign_function_call_active + * + * If the C stack is not scavenged during GC, result needs to + * be protected against not being referred to by any roots, so + * we push it onto the lisp control stack, and read it back + * off after any potential GC has finished */ +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK +#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD +#error "!C_STACK_IS_CONTROL_STACK and STACK_GROWS_DOWNWARD_NOT_UPWARD is not supported" +#endif + *access_control_stack_pointer(th) = (lispobj) result; + access_control_stack_pointer(th) += 1; +#endif + do_pending_interrupt(); +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK + access_control_stack_pointer(th) -= 1; + result = (lispobj *) *access_control_stack_pointer(th); +#endif + } + return result; +} #else static lispobj * -pa_alloc(int bytes) +pa_alloc(int bytes, int page_type_flag) { - char *result; + lispobj *result; + + /* This is not pseudo atomic at all, but is called only from + * interrupt safe places like interrupt handlers. MG - + * 2005-08-09 */ + check_deferrables_blocked_or_lose(0); - /* Round to dual word boundary. */ - bytes = (bytes + LOWTAG_MASK) & ~LOWTAG_MASK; + result = dynamic_space_free_pointer; - result = (char *)GET_FREE_POINTER(); + /* Align up to next dual word boundary. */ + bytes = ALIGNED_SIZE(bytes); - SET_FREE_POINTER((lispobj *)(result + bytes)); + dynamic_space_free_pointer = (lispobj *)((char *)result + bytes); - if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) { - SET_GC_TRIGGER((char *)GET_FREE_POINTER() - - (char *)current_dynamic_space); + if (current_auto_gc_trigger + && dynamic_space_free_pointer > current_auto_gc_trigger) { + clear_auto_gc_trigger(); + set_auto_gc_trigger((char *)dynamic_space_free_pointer + - (char *)current_dynamic_space); } - return (lispobj *) result; + return result; } #endif - -lispobj * +static lispobj * alloc_unboxed(int type, int words) { lispobj *result; - result = pa_alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj))); + result = pa_alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)), + UNBOXED_PAGE_FLAG); *result = (lispobj) (words << N_WIDETAG_BITS) | type; return result; } static lispobj -alloc_vector(int type, int length, int size) +alloc_vector(int type, int length, int size, int page_type_flag) { struct vector *result; result = (struct vector *) - pa_alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj))); + pa_alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj)), + page_type_flag); result->header = type; result->length = make_fixnum(length); @@ -106,7 +143,9 @@ alloc_vector(int type, int length, int size) lispobj alloc_cons(lispobj car, lispobj cdr) { - struct cons *ptr = (struct cons *)pa_alloc(ALIGNED_SIZE(sizeof(struct cons))); + struct cons *ptr = + (struct cons *)pa_alloc(ALIGNED_SIZE(sizeof(struct cons)), + BOXED_PAGE_FLAG); ptr->car = car; ptr->cdr = cdr; @@ -115,7 +154,7 @@ alloc_cons(lispobj car, lispobj cdr) } lispobj -alloc_number(long n) +alloc_number(sword_t n) { struct bignum *ptr; @@ -126,7 +165,7 @@ alloc_number(long n) ptr->digits[0] = n; - return make_lispobj(ptr, OTHER_POINTER_LOWTAG); + return make_lispobj(ptr, OTHER_POINTER_LOWTAG); } } @@ -134,7 +173,8 @@ lispobj alloc_base_string(char *str) { int len = strlen(str); - lispobj result = alloc_vector(SIMPLE_BASE_STRING_WIDETAG, len+1, 8); + lispobj result = alloc_vector(SIMPLE_BASE_STRING_WIDETAG, len+1, 8, + UNBOXED_PAGE_FLAG); struct vector *vec = (struct vector *)native_pointer(result); vec->length = make_fixnum(len); @@ -148,7 +188,38 @@ alloc_sap(void *ptr) { struct sap *sap; sap=(struct sap *) - alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1); + alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1); sap->pointer = ptr; return make_lispobj(sap,OTHER_POINTER_LOWTAG); } + +lispobj +alloc_code_object (unsigned boxed, unsigned unboxed) { + struct code * code; + /* Coming in, boxed is the number of boxed words requested. + * Converting it to a fixnum makes it measured in bytes. It's also + * rounded up to double word along the way. */ + boxed = (boxed + 1 + + (offsetof(struct code, trace_table_offset) >> + WORD_SHIFT)) << WORD_SHIFT; + boxed &= ~LOWTAG_MASK; + + /* Unboxed is in bytes, round it up to double word boundary. Now + * it's also a fixnum containing the number of unboxed words. */ + unboxed += LOWTAG_MASK; + unboxed &= ~LOWTAG_MASK; + + code = (struct code *)pa_alloc(boxed + unboxed, CODE_PAGE_FLAG); + + /* It used to be that even on gencgc builds the + * ALLOCATE-CODE-OBJECT VOP did all this initialization within + * pseudo atomic. Here, we rely on gc being inhibited. */ + if (SymbolValue(GC_INHIBIT, arch_os_get_current_thread()) == NIL) + lose("alloc_code_object called with GC enabled."); + boxed = boxed << (N_WIDETAG_BITS - WORD_SHIFT); + code->header = boxed | CODE_HEADER_WIDETAG; + code->code_size = unboxed >> (WORD_SHIFT - N_FIXNUM_TAG_BITS); + code->entry_points = NIL; + code->debug_info = NIL; + return make_lispobj(code, OTHER_POINTER_LOWTAG); +}