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

The resume needs to be adjusted; not yet finished. (TODO: is this still the case?)

Also, the tests + documentation need an update for list->individual element.

1 files changed, 116 insertions, 170 deletions

diff --git a/gnu/gnunet/concurrency/lost-and-found.scm b/gnu/gnunet/concurrency/lost-and-found.scm
index 711f3a6..4b06eb7 100644
--- a/gnu/gnunet/concurrency/lost-and-found.scm
+++ b/gnu/gnunet/concurrency/lost-and-found.scm
@@ -24,196 +24,126 @@
 	  ;; exported for tests
 	  (rename (add-found! | add-found!|)))
   (import (only (rnrs base)
-		begin let define lambda quote if cond eq? assert cons list)
+		begin define lambda if let eq? assert
+		let* call-with-values values)
 	  (only (rnrs control)
-		when unless)
+		when case-lambda)
 	  (only (rnrs records syntactic)
 		define-record-type)
-	  (only (guile)
-		make-guardian add-hook! after-gc-hook object-address)
+	  (only (rnrs exceptions)
+		guard)
+	  (only (fibers operations)
+		wrap-operation)
+	  (only (ice-9 atomic)
+		make-atomic-box atomic-box-ref atomic-box-set!)
 	  (only (ice-9 format)
 		format)
+	  (only (srfi srfi-8)
+		receive)
 	  (only (srfi srfi-9 gnu)
 		set-record-type-printer!)
-	  (only (ice-9 atomic)
-		make-atomic-box atomic-box-ref)
-	  (only (fibers conditions)
-		make-condition condition? signal-condition! wait-operation)
-	  (only (fibers operations)
-		wrap-operation make-base-operation)
+	  (only (srfi srfi-111)
+		box unbox set-box!)
+	  (only (guile)
+		make-guardian add-hook! after-gc-hook error
+		call-with-blocked-asyncs object-address)
+	  (only (gnu gnunet concurrency update)
+		make-update wait-for-update-operation update-value
+		double-update? next-update-peek)
 	  ;; TODO: move elsewhere
 	  (only (gnu gnunet mq envelope)
 		%%bind-atomic-boxen))
   (begin
     (define-record-type (<lost-and-found> make-lost-and-found lost-and-found?)
-      ;; Atomic box of [condition | (found found* ...)].
-      ;; When there is nothing found, the condition is unsignalled.
+      ;; An atomic box containing an update object, with the property that
+      ;; the values of all the descendants of the update object (excluding the
+      ;; update itself!) together form the uncollected objects.
       ;;
-      ;; To register something lost, it is added to the list (if any),
-      ;; otherwise the condition is replaced by the lost object, then
-      ;; the condition is signalled.
-      (fields (immutable contents-box lost-and-found-contents-box))
-      (protocol (lambda (%make)
-		  (lambda ()
-		    (%make (make-atomic-box (make-condition)))))))
+      ;; (The values in the update's descendants are themselves wrapped in
+      ;; a box, which will be set to #false to allow freeing memory.)
+      ;;
+      ;; To wait/ask for unprocessed objects, one needs to wait for the next
+      ;; update and then read the value in the next update (and adjust
+      ;; the atomic box accordingly).  Trickyness: some other fiber
+      ;; might have ‘claimed’ the update first, so it needs to be
+      ;; confirmed with compare-and-swap.
+      (fields (immutable box lost-and-found-box)
+	      ;; atomic box containing the _latest_ update! procedure --
+	      ;; quite possibly this is ahead of the unprocessed objects!.
+	      ;;
+	      ;; This needs to be an atomic box because multiple instances
+	      ;; of after-gc-hook might be run at the same time or re-entrantly
+	      ;; (unlikely, but technically allowed and perhaps possible!).
+	      (immutable update!-box lost-and-found-update!-box))
+      (protocol
+       (lambda (%make)
+	 (lambda ()
+	   (receive (update update!) (make-update #false)
+	     (%make (make-atomic-box update)
+		    (make-atomic-box update!)))))))
 
     (set-record-type-printer!
      <lost-and-found>
      (lambda (record port)
        (format port "#<lost-and-found ~x ~a>"
 	       (object-address record)
-	       (if (condition?
-		    (atomic-box-ref (lost-and-found-contents-box record)))
-		   "empty"
-		   "non-empty"))))
+	       (if (next-update-peek
+		    (atomic-box-ref
+		     (lost-and-found-box record)))
+		   "non-empty"
+		   "empty"))))
 
-    ;; TODO: concurrency this operation, not reusable
     (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."
+      "Make an operation that will complete when something lost has been found
+and returns the newly found object.  Sporadically, it might return #false instead."
       (%%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!")))))
+       ((update (lost-and-found-box lost-and-found) swap!))
+       (let ((old-update update))
+	 (wrap-operation
+	  (wait-for-update-operation old-update)
+	  (lambda (next-update)
+	    (if (eq? old-update (swap! old-update next-update))
+		(let* ((box (update-value next-update))
+		       (box-value (unbox box)))
+		  ;; make sure the lost-and-found loses its reference,
+		  ;; such that the value can be collected once the callee
+		  ;; loses its reference.
+		  (set-box! box #false)
+		  (if (eq? box-value #false)
+		      (error "fibers (lost-and-found): seems impossible")
+		      box-value))
+		;; spurious #false -- TODO: once we have
+		;; https://github.com/wingo/fibers/issues/97,
+		;; in particular guard-operation, we could eliminate
+		;; this spurious #false
+		#false))))))
 
     (define (add-found! lost-and-found lost)
       "Add an object @var{lost} to @var{lost-and-found}."
-      (%%bind-atomic-boxen
-       ((value (lost-and-found-contents-box lost-and-found) swap!))
-       (let loop ((old value))
-	 ;; The mutations ‘simply run the first branch’, ‘simply run
-	 ;; the second branch’, ‘run both branches’ and ‘invert the
-	 ;; branch condition’ are detected by test "unreachable + gc ->
-	 ;; moved into lost and found".
-	 ;;
-	 ;; TODO: maybe detect replacing ‘old’ by ‘value’.
-	 (if (condition? old)
-	     ;; Replace the condition by a list containing lost,
-	     ;; then notify the condition.  This ordering is important,
-	     ;; otherwise 'collect-lost-and-found-soperation' could
-	     ;; be unnecessarily in the ‘spuriously return the empty list’
-	     ;; case, even when there aren't multiple concurrent
-	     ;; 'collect-lost-and-found-operation' operations.
+      (define box (lost-and-found-update!-box lost-and-found))
+      (let loop ()
+	(call-with-values
+	    (lambda ()
+	      (guard (c ((double-update? c) (values))) ; failure
+		     ((atomic-box-ref box) lost))) ; success
+	  (case-lambda
+	   (()
+	     ;; Failure, things are being collected currently!
+	     ;; the other thread has set/will set soon the new
+	     ;; update! procedure.
+	     ;;
+	     ;; All we need to do is retry.
+	     (loop))
+	    ((next-update new-update!)
+	     ;; next-update is irrelevant here.
 	     ;;
-	     ;; (Though in practice, this would not seem to be a problem,
-	     ;; since 'collect-lost-and-found' is called in a loop anyway.)
-	     (let ((new-old (swap! old (list lost))))
-	       ;; The mutations ‘invert the branch condition’ and ‘do both
-	       ;; branches (in order or out-of-order)’ are detected by the test
-	       ;; "unreachable + gc -> moved into lost and found".
-	       ;;
-	       ;; The mutation ‘simply do the second branch’ is detected by
-	       ;; test "new lost between making the operation and performing it
-	       ;; (2)" (timeout).
-	       ;;
-	       ;; The mutation ‘simply do the first branch’ is dected by the
-	       ;; test "losing and collecting concurrently" (not 100%
-	       ;; reproducible).
-	       (if (eq? new-old old)
-		   ;; The mutation ‘don't do anything’ is detected by test
-		   ;; "new lost between making the operation and performing it
-		   ;; (2)" (by timeout).
-		   (signal-condition! old)
-		   ;; Race was lost, try again!
-		   ;;
-		   ;; The mutation ‘don't do anything’ is detected by the test
-		   ;; "losing and collecting concurrently".
-		   ;;
-		   ;; The mutation ‘use old instead of new-old’ is detected by
-		   ;; the test "losing and collecting concurrently" (infinite
-		   ;; loop).
-		   ;;
-		   ;; The mutation ‘use value instead of new-value’ is
-		   ;; _survives_ and seems benign, although possibly suboptimal
-		   ;; performance-wise.
-		   (loop new-old)))
-	     ;; There is already a list of lost objects, extend it.
-	     ;; The mutation ‘replace the first old by value’ causes
-	     ;; "concurrent losing" to fail. TODO: replacing the second ‘old’
-	     ;; is currently undetected.
-	     (let ((new-old (swap! old (cons lost old))))
-	       ;; The mutations ‘don't do anything’, ‘invert the condition’,
-	       ;; ‘replace old by value in the condition’
-	       ;; cause the test "concurrent losing" to fail.
-	       ;;
-	       ;; The mutations ‘always run’ and ‘replace new-old by value in
-	       ;; the condition’ cause an infinite loop (presumambly with
-	       ;; unbounded memory!). The mutation ‘run loop twice’ seems to
-	       ;; cause an OOM or at least very high memory usage.
-	       (unless (eq? new-old old)
-		 ;; Race was lost, try again!
-		 ;;
-		 ;; The mutation ‘replace new-old by old’ causes "concurrent
-		 ;; losing" to busy hang.  The mutation ‘replace new-old by
-		 ;; value’ survives and seems benign, although perhaps
-		 ;; suboptimal performance-wise.
-		 (loop new-old)))))))
+	     ;; We don't need compare-and-swap here, because
+	     ;; other threads can't progress as long as the updater
+	     ;; isn't updated.
+	     ;;
+	     ;; Also, retrying would mean adding the same object
+	     ;; twice, which is undesired.
+	     (atomic-box-set! box new-update!))))))
 
     (define *guard* (make-guardian))
 
@@ -238,11 +168,27 @@ code ..."
       (%losable-lost-and-found losable))
 
     (define (collect-lost)
-      (define object (*guard*))
-      (when object
-	(add-found! (losable-lost-and-found object) object)
-	;; Absence detected by test
-	;; "unreachable + gc -> moved into lost and found"
-	(collect-lost)))
+      ;; An async would be by-itself ok, but if were to, say, call an
+      ;; escape continuation, then some important things in 'add-found!'
+      ;; would be left in a partial state.
+      ;;
+      ;; It would be sufficient to only wrap the (*guard*) + (add-found! ...),
+      ;; at cost of having to wait for another GC cycle.
+      ;;
+      ;; TODO: also check for sufficient stack, and eliminate all
+      ;; memory allocations.
+      ;;
+      ;; TODO: there should be a way to tell Guile to grant the hook
+      ;; some extra stack and to do things directly in call-with-blocked-asyncs,
+      ;; but such a mechanism doesn't seem to exist yet.
+      (call-with-blocked-asyncs
+       (lambda ()
+	 (let loop ()
+	   (define object (*guard*))
+	   (when object
+	     (add-found! (losable-lost-and-found object) (box object))
+	     ;; Absence detected by test
+	     ;; "unreachable + gc -> moved into lost and found"
+	     (loop))))))
 
     (add-hook! after-gc-hook collect-lost)))