Let's turn this into a proper operation that can be moved into Guile Fibers.gc-adjust

The resume needs to be adjusted; not yet finished.

1 files changed, 48 insertions, 72 deletions

diff --git a/gnu/gnunet/concurrency/lost-and-found.scm b/gnu/gnunet/concurrency/lost-and-found.scm
index 711f3a6..0063bc1 100644
--- a/gnu/gnunet/concurrency/lost-and-found.scm
+++ b/gnu/gnunet/concurrency/lost-and-found.scm
@@ -30,13 +30,14 @@
 	  (only (rnrs records syntactic)
 		define-record-type)
 	  (only (guile)
-		make-guardian add-hook! after-gc-hook object-address)
+		make-guardian add-hook! after-gc-hook object-address error
+		@@ pk)
 	  (only (ice-9 format)
 		format)
 	  (only (srfi srfi-9 gnu)
 		set-record-type-printer!)
 	  (only (ice-9 atomic)
-		make-atomic-box atomic-box-ref)
+		make-atomic-box atomic-box-ref atomic-box-compare-and-swap!)
 	  (only (fibers conditions)
 		make-condition condition? signal-condition! wait-operation)
 	  (only (fibers operations)
@@ -67,80 +68,55 @@
 		   "empty"
 		   "non-empty"))))
 
-    ;; TODO: concurrency this operation, not reusable
+    (define base-op-try-fn (pk (@@ (fibers operations) base-op-try-fn)))
+    (define base-op-block-fn (@@ (fibers operations) base-op-block-fn))
+
     (define (collect-lost-and-found-operation lost-and-found)
       "Make an operation that will complete when something lost has been
-found and return the newly found objects as a list.  If this operation is
-performed multiple times concurrently on the same lost and found, spurious
-wakeups where the empty list is returned are possible."
+found and return the newly found objects as a list."
+      (pk 'hi)
       (%%bind-atomic-boxen
        ((value (lost-and-found-contents-box lost-and-found) swap!))
-       (let ((old value)
-	     (new-condition (make-condition)))
-	 (define (loop old)
-	   ;; The mutation replacing 'old' by 'value' is detected by
-	   ;; the tests "new lost between making the operation and performing
-	   ;; it".
-	   (define new-old (swap! old new-condition))
-	   ;; If a condition, a concurrent
-	   ;; 'collect-lost-and-found-operation' has took the found
-	   ;; objects, return a spurious empty list.
-	   ;;
-	   ;; The mutations ‘inverse the condition’, ‘remove this clause’,
-	   ;; and ‘return new-old’ are detected by the test "concurrent
-	   ;; collecting (light)".
-	   ;;
-	   ;; The mutation ‘replace ‘new-old’ by ‘old’ or ‘value’’ is detected
-	   ;; by "new lost between making the operation and performing it (2)".
-	   ;;
-	   ;; TODO: detect switching the first two clauses.
-	   (cond ((condition? new-old) '())
-		 ;; eq? and not a condition --> succesfully replaced a
-		 ;; list of found objects with 'new-condition', return
-		 ;; the list.
-		 ;;
-		 ;; The mutations ‘remove this clause’, ‘always return the
-		 ;; empty list’, ‘inverse the condition’, ‘replace new-old or
-		 ;; old by value’ are detected by the test "unreachable + gc ->
-		 ;; moved into lost and found".
-		 ((eq? old new-old) old)
-		 ;; not eq? --> a race happened, retry
-		 ;;
-		 ;; The mutations ‘removing this clause’,
-		 ;; ‘returning the empty list’ and ‘calling loop twice’ are
-		 ;; detected by tests "new lost between making the operation and
-		 ;; performing it".
-		 (#true (loop new-old))))
-	 ;; The mutation ‘use value instead of old’ is detected ‘losing and
-	 ;; collecting concurrently’ (somewhat irreproducible).
-	 (if (condition? old)
-	     (wrap-operation
-	      ;; The mutation ‘don't wait for anything’ is detected by
-	      ;; the test "block while nothing to collect".
-	      ;; The mutation ‘use value instead of old’ is detected by
-	      ;; the test "losing and collecting concurrently".
-	      (wait-operation old)
-	      ;; The mutations 'always return the empty list' and 'call loop
-	      ;; twice' are detected by test "new lost between making the
-	      ;; operation and performing it (2)".
-	      ;;
-	      ;; The mutation ‘replace old by value’ _survives_ but seems
-	      ;; benign.
-	      (lambda () (loop old)))
-	     ;; 'collect-lost' added something before we started waiting,
-	     ;; return it when asked for (unless a race interferes).
-	     (make-base-operation
-	      #false ; wrap
-	      ;; Try (always succeeds).
-	      ;; The mutations ‘always return the empty list’ and
-	      ;; 'call loop twice' are rejected by test
-	      ;; "unreachable + gc -> moved into lost and found".
-	      ;;
-	      ;; The mutation ‘replace old by value’ _survives_ but seems
-	      ;; benign.
-	      (lambda () (lambda () (loop old)))
-	      ;; There is no block, only try -- try always succeeds.
-	      "do not call me, try always returns!")))))
+       (pk 'let's-op)
+       (make-base-operation
+	#false
+	(lambda ()
+	  (pk 'trying)
+	  (let loop ((old value))
+	    (if (condition? old)
+		;; see if the condition is signalled yet 
+		(let ((result ((base-op-try-fn (wait-operation old)))))
+		  (if result
+		      ;; It is!  Let's look what has been collected.  If
+		      ;; this is being done currently, it's possible someone
+		      ;; else collected it first, in which case we may have
+		      ;; to loop.
+		      (loop result)
+		      ;; Not yet, we'll have to block!
+		      #false))
+		;; Claim the collected objects.
+		(let ((new-old (swap! old (make-condition))))
+		  (if (eq? old new-old)
+		      (lambda () old) ; success!
+		      (loop new-old)))))) ; failure, some other fiber did it first.
+	(lambda (flag sched resume)
+	  (pk 'blocking)
+	  (let spin ((old value))
+	    (if (condition? old)
+		((base-op-block-fn (wait-operation old)) flag sched
+		 (lambda (useless-thunk)
+		   (
+			
+		;; Some object was collected between try and block, we can return it!
+		;; But first, claim it.
+		(let ((new-old (swap! old (make-condition))))
+		  (if (eq? old new-old)
+		      ;; Successfully claimed, we can resume.
+		      (if (eq? 'W (atomic-box-compare-and-swap! flag 'W 'S))
+			  (resume (lambda () old))
+			  (error "lost-and-found: seems impossible"))
+		      ;; Some other fiber got to it first, let's retry.
+		      (spin new-old)))))))))
 
     (define (add-found! lost-and-found lost)
       "Add an object @var{lost} to @var{lost-and-found}."