X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fruntime%2Falloc.c;h=2e056b54f8c9be5bf976082a3a9c869e04de072c;hb=02d7495253b9075e4d86275590c3e827c814b596;hp=e53b2781d66c93ff3be6fb69d99851506db6bab3;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git

diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c
index e53b278..2e056b5 100644
--- a/src/runtime/alloc.c
+++ b/src/runtime/alloc.c
@@ -29,55 +29,66 @@
 #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 LISP_FEATURE_GENCGC
-extern lispobj *alloc(int bytes);
-lispobj *
+static lispobj *
 pa_alloc(int bytes)
 {
-    lispobj *result=0;
-    struct thread *th=arch_os_get_current_thread();
+    lispobj *result;
+#ifdef LISP_FEATURE_GENCGC
+    struct thread *th = arch_os_get_current_thread();
+
     /* FIXME: OOAO violation: see arch_pseudo_* */
-    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 (fixnum_value(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 */
+    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();
-    return result;
-}
-
+#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+        current_control_stack_pointer -= 1;
+        result = (lispobj *) *current_control_stack_pointer;
+#endif
+    }
 #else
-static lispobj *
-pa_alloc(int bytes)
-{
-    char *result;
+    /* 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;
+    /* Align up to next dual word boundary. */
+    bytes = ALIGNED_SIZE(bytes);
 
-    result = (char *)GET_FREE_POINTER();
+    dynamic_space_free_pointer = (lispobj *)((char *)result + bytes);
 
-    SET_FREE_POINTER((lispobj *)(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;
-}
 #endif
+    return result;
+}
 
 
 lispobj *