X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Falloc.c;h=2e056b54f8c9be5bf976082a3a9c869e04de072c;hb=02d7495253b9075e4d86275590c3e827c814b596;hp=c78d167335a2d25d758c68b5e6311886d65b5300;hpb=6cbe4d8ba6d7bc469d03a72514c789b1f3944878;p=sbcl.git diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index c78d167..2e056b5 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -1,5 +1,6 @@ /* - * allocation routines + * allocation routines for C code. For allocation done by Lisp look + * instead at src/compiler/target/alloc.lisp and .../macros.lisp */ /* @@ -13,52 +14,90 @@ * files for more information. */ -#include "runtime.h" +#include +#include + #include "sbcl.h" +#include "runtime.h" +#include "os.h" #include "alloc.h" #include "globals.h" #include "gc.h" -#include +#include "thread.h" +#include "genesis/vector.h" +#include "genesis/cons.h" +#include "genesis/bignum.h" +#include "genesis/sap.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 +#ifdef LISP_FEATURE_GENCGC +extern lispobj *alloc(long bytes); +#endif -#if defined GENCGC -extern lispobj *alloc(int bytes); -#else static lispobj * -alloc(int bytes) +pa_alloc(int bytes) { lispobj *result; +#ifdef LISP_FEATURE_GENCGC + struct thread *th = arch_os_get_current_thread(); + + /* FIXME: OOAO violation: see arch_pseudo_* */ + clear_pseudo_atomic_interrupted(th); + set_pseudo_atomic_atomic(th); + result = alloc(bytes); + 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 + *current_control_stack_pointer = (lispobj) result; + current_control_stack_pointer += 1; +#endif + do_pending_interrupt(); +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK + current_control_stack_pointer -= 1; + result = (lispobj *) *current_control_stack_pointer; +#endif + } +#else + /* FIXME: this is not pseudo atomic at all, but is called only from + * interrupt safe places like interrupt handlers. MG - 2005-08-09 */ + result = dynamic_space_free_pointer; - /* Round to dual word boundary. */ - bytes = (bytes + lowtag_Mask) & ~lowtag_Mask; - - result = GET_FREE_POINTER(); + /* Align up to next dual word boundary. */ + bytes = ALIGNED_SIZE(bytes); - SET_FREE_POINTER(result + (bytes / sizeof(lispobj))); + 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); } +#endif return result; } -#endif -static lispobj * + +lispobj * alloc_unboxed(int type, int words) { lispobj *result; - result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj))); - *result = (lispobj) (words << type_Bits) | type; + result = pa_alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj))); + *result = (lispobj) (words << N_WIDETAG_BITS) | type; return result; } @@ -68,23 +107,23 @@ alloc_vector(int type, int length, int size) struct vector *result; result = (struct vector *) - alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj))); + pa_alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj))); result->header = type; result->length = make_fixnum(length); - return ((lispobj)result)|type_OtherPointer; + return make_lispobj(result,OTHER_POINTER_LOWTAG); } lispobj alloc_cons(lispobj car, lispobj cdr) { - struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons))); + struct cons *ptr = (struct cons *)pa_alloc(ALIGNED_SIZE(sizeof(struct cons))); ptr->car = car; ptr->cdr = cdr; - return (lispobj)ptr | type_ListPointer; + return make_lispobj(ptr, LIST_POINTER_LOWTAG); } lispobj @@ -95,20 +134,20 @@ alloc_number(long n) if (-0x20000000 < n && n < 0x20000000) return make_fixnum(n); else { - ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1); + ptr = (struct bignum *)alloc_unboxed(BIGNUM_WIDETAG, 1); ptr->digits[0] = n; - return (lispobj) ptr | type_OtherPointer; + return make_lispobj(ptr, OTHER_POINTER_LOWTAG); } } lispobj -alloc_string(char *str) +alloc_base_string(char *str) { int len = strlen(str); - lispobj result = alloc_vector(type_SimpleString, len+1, 8); - struct vector *vec = (struct vector *)PTR(result); + lispobj result = alloc_vector(SIMPLE_BASE_STRING_WIDETAG, len+1, 8); + struct vector *vec = (struct vector *)native_pointer(result); vec->length = make_fixnum(len); strcpy((char *)vec->data, str); @@ -119,10 +158,9 @@ alloc_string(char *str) lispobj alloc_sap(void *ptr) { - int n_words_to_alloc = - (sizeof(struct sap) - sizeof(lispobj)) / sizeof(u32); - struct sap *sap = - (struct sap *)alloc_unboxed((int)type_Sap, n_words_to_alloc); + struct sap *sap; + sap=(struct sap *) + alloc_unboxed((int)SAP_WIDETAG, sizeof(struct sap)/sizeof(lispobj) -1); sap->pointer = ptr; - return (lispobj) sap | type_OtherPointer; + return make_lispobj(sap,OTHER_POINTER_LOWTAG); }