weak: Kill race condition in ECL weak pointer implementation.

diff --git a/weak.lisp b/weak.lisp
index ff7c9c3d0279e2bf7ce50225f065c8f50c5e4cc2..b7325d76c9ad5d17fdcbb709079cd796d05eec9b 100644 (file)
--- a/weak.lisp
+++ b/weak.lisp
@@ -39,18 +39,24 @@   (defun weak-pointer-value (weak)
 
 #+ecl
 (progn
 
 #+ecl
 (progn

+  (ffi:clines
+   "static GC_PTR fetch_obj(GC_PTR p) { return *(cl_object *)p; }")

   (defun make-weak-pointer (object)
   (defun make-weak-pointer (object)

-    (ffi:c-inline (object) (:object) :pointer-void
-      "{ cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
-        *weak = #0;
-        GC_general_register_disappearing_link(weak, GC_base(#0));
-        @(return) = weak; }"
+    (ffi:c-inline (object) (:object) :pointer-void "
+      {
+       cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
+       *weak = #0;
+       GC_general_register_disappearing_link(weak, GC_base(#0));
+       @(return) = weak;
+      }"

       :one-liner nil))
   (defun weak-pointer-value (weak)
       :one-liner nil))
   (defun weak-pointer-value (weak)

-    (ffi:c-inline (weak) (:pointer-void) (values :object :object)
-      "{ cl_object *weak = #0;
-        if (*weak) { @(return 0) = *weak; @(return 1) = @t; }
-        else { @(return 0) = @nil; @(return 1) = @nil; } }"
+    (ffi:c-inline (weak) (:pointer-void) (values :object :object) "
+      {
+       cl_object obj = GC_call_with_alloc_lock(fetch_obj, #0);
+       if (obj) { @(return 0) = obj; @(return 1) = @t; }
+       else { @(return 0) = @nil; @(return 1) = @nil; }
+      }"

       :one-liner nil)))
 
 #-(or sbcl cmu clisp allegro common-lispworks ecl)
       :one-liner nil)))
 
 #-(or sbcl cmu clisp allegro common-lispworks ecl)