scheme-gnunet/tests/lost-and-found.scm

;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;; Copyright © 2022 GNUnet e.V.
;;
;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; Scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later

;; Author: Maxime Devos
(define-module (test-lost-and-found))
(import (ice-9 match)
        (srfi srfi-1)
	(gnu gnunet concurrency lost-and-found)
	(rnrs base)
	(srfi srfi-64)
	(fibers conditions)
	(fibers operations)
	(fibers channels)
	(rnrs records syntactic)
	(fibers)
	(fibers timers)) ; sleep

(test-begin "lost-and-found")

(define-record-type (<losable+datum> make-losable+datum losable+datum?)
  (parent <losable>)
  (fields (immutable datum losable-datum))
  ;; TODO: why is this necessary?
  (protocol (lambda (%make)
	      (lambda (lost-and-found foo)
		((%make lost-and-found) foo)))))

(define (lose lost-and-found start to/exclusive)
  "Lose integers from the range [start to/exclusive)."
  (when (< start to/exclusive)
    (make-losable+datum lost-and-found start)
    (lose lost-and-found (+ 1 start) to/exclusive)))

(define (collect-operation lost-and-found)
  "Make an operation returning the list of found integers
(make sure to gc before performing the operation!)."
  (wrap-operation
   (collect-lost-and-found-operation lost-and-found)
   (lambda (list)
     (map losable-datum list))))

(define (collect lost-and-found)
  "Return a list of found integers (make sure to gc first!)."
  (perform-operation (collect-operation lost-and-found)))

(define (verify collected from to/exclusive)
  (define count (- to/exclusive from))
  (define present (make-bitvector count #false))
  (for-each (lambda (i)
	      (assert (not (bitvector-bit-set? present (- i from))))
	      (bitvector-set-bit! present i))
	    collected)
  ;; Presumably due to boehmgc being conservative, this number
  ;; of elements collected tends can be off by one or two.
  ;; Allow being 5 elements off.
  (define fraction (/ (bitvector-count present) (- count 5.)))
  (pk 'f (+ 0.0 fraction))
  (assert (>= fraction 1))
  #true
  #;
  (receive (collected\expected ∩)
      (lset-diff+intersection! = collected (iota count from))
    (assert (null? collected\expected))
    ;; Presumably due to boehmgc being conservative, this number
    ;; of elements collected tends can be off by one or two.
    ;; Allow being 5 elements off.
    (let ((fraction (/ (length ∩) (- count 5))))
      (pk 'f (+ 0.0 fraction))
      (assert (>= fraction 1))
      #true)))

(define %count 1000)
(test-assert "unreachable + gc -> moved into lost and found"
  (let ((lost-and-found (make-lost-and-found)))
    (lose lost-and-found 0 %count)
    (gc)
    (verify (collect lost-and-found) 0 %count)))

(test-assert "new lost between making the operation and performing it (1)"
  (let ((lost-and-found (make-lost-and-found)))
    (lose lost-and-found 0 %count)
    (gc)
    (define operation (collect-operation lost-and-found))
    (lose lost-and-found %count (* 2 %count))
    (gc)
    (verify (perform-operation operation) 0 (* 2 %count))))

(test-assert "new lost between making the operation and performing it (2)"
  (let ((lost-and-found (make-lost-and-found)))
    (lose lost-and-found 0 %count)
    ;; <- no gc!
    (define operation (collect-operation lost-and-found))
    (lose lost-and-found %count (* 2 %count))
    (gc)
    (verify (perform-operation operation) 0 (* 2 %count))))

(test-assert "concurrent collecting (light)"
  (let ((lost-and-found (make-lost-and-found)))
    (lose lost-and-found 0 %count)
    (gc)
    (define operation1 (collect-operation lost-and-found))
    (define operation2 (collect-operation lost-and-found))
    (define result1 (perform-operation operation1))
    ;; Technically, this is allowed to hang (since everything is
    ;; collected by result1), but due to implementation details,
    ;; it doesn't.
    (define result2 (perform-operation operation2))
    (verify result1 0 %count)
    (verify (append result1 result2) 0 %count)))


;; TODO: copied from (tests update)
;; TODO: 1e-4 is not sufficient here, 1e-3 is required to make tests
;; fail (CPU-dependent?).
(define expected-blocking-operation
  (wrap-operation (sleep-operation 1e-3) (lambda () 'blocking)))

(test-eq "block while nothing to collect"
  'blocking
  (perform-operation
   (choice-operation (collect-operation (make-lost-and-found))
		     expected-blocking-operation)))

(test-assert "delaying performing the operation, some concurrency"
  (let* ((lost-and-found (make-lost-and-found))
	 ;; 'lost-and-found' currently has a condition, so the
	 ;; (if (condition? old) ...) case should happen here
	 (operation (collect-operation lost-and-found)))
    ;; Trigger and replace the original condition.
    (lose lost-and-found 0 %count)
    (gc)
    (collect lost-and-found)
    ;; Run the original operation.
    (define result
      (perform-operation
       (choice-operation operation expected-blocking-operation)))
    ;; The lost objects were already collected, so blocking is fine.
    ;; There's a form of concurrency, so a spurious empty list is
    ;; also allowed.
    (memq result '(blocking ()))))

(define add-found! #{ add-found!}#)

;; There is no rule against the GC hook being called from within the GC hook,
;; or the GC hook being called in parallel from another thread running the
;; GC hook, in case a lot of garbage was generated before the original
;; invocation of the GC hook was able to finish.
;;
;; This seems a bit difficult to reliably trigger, so cheat by manually adding
;; running 'add-found!' concurrently.

(define (lose* lost-and-found start to/exclusive)
  "Lose integers from the range [start to/exclusive), bypassing the GC and not
wrap things in a <losable+datum>."
  (when (< start to/exclusive)
    (add-found! lost-and-found start)
    (lose* lost-and-found (+ 1 start) to/exclusive)))

(define (collect* lost-and-found)
  "Return a list of found integers (no need to GC, since the GC and guardian was
bypassed by calling @code{add-found!} directly)."
  (perform-operation (collect-lost-and-found-operation lost-and-found)))

;; In the current implementation of Guile, while to a degree GC is parellelised,
;; gc hooks are serialised (or maybe not, since ‘this hook is run  
(test-assert "concurrent losing"
  (run-fibers
   (lambda ()
     (define %count/fiber 100000)
     (define fibers 8)
     (define start (make-condition))
     (define done-channel (make-channel))
     (define lost-and-found (make-lost-and-found))
     (define (lose/async from to/exclusive)
       (spawn-fiber
	(lambda ()
	  (wait start)
	  (lose* lost-and-found from to/exclusive)
	  (put-message done-channel 'done))))
     (let loop ((i 0))
       (when (< i fibers)
	 (lose/async (* i %count/fiber) (* (+ 1 i) %count/fiber))
	 (loop (+ i 1))))
     (signal-condition! start)
     (let loop ((i 0))
       (when (< i fibers)
	 (get-message done-channel)
	 (loop (+ i 1))))
     (verify (collect* lost-and-found) 0 (* %count/fiber fibers)))
   #:install-suspendable-ports? #false ; unnecessary
   #:hz 10000))

(test-assert "losing and collecting concurrently"
  (run-fibers
   (lambda ()
     ;; 100000 does not suffice for testing the first
     ;; '(loop new-old)' in 'add-found!'.
     (define %count/loser 1000000)
     (define %losers 8)
     (define %collectors 8)
     (define start (make-condition))
     (define done-losing (make-condition))
     (define done-channel/losers (make-channel))
     (define done-channel/collectors (make-channel))
     (define done-losing-operation
       (wrap-operation
	(wait-operation done-losing)
	(lambda () 'done)))
     (define lost-and-found (make-lost-and-found))
     (define (lose/async from to/exclusive)
       (spawn-fiber
	(lambda ()
	  (wait start)
	  (lose* lost-and-found from to/exclusive)
	  (put-message done-channel/losers 'done))))
     ;; vector of list of list of collected objects
     (define collected (make-vector %collectors))
     (define (collect/async i)
       (spawn-fiber
	(lambda ()
	  (wait start)
	  (let loop ((list-of-list-of-results '()))
	    (define r
	      (perform-operation
	       (choice-operation
		(collect-lost-and-found-operation lost-and-found)
		done-losing-operation)))
	    (if (eq? r 'done)
		(begin
		  (vector-set! collected i list-of-list-of-results)
		  (put-message done-channel/collectors 'done))
		(loop (cons r list-of-list-of-results)))))))
     ;; Start fibers collecting integers.
     (let loop ((i 0))
       (when (< i %collectors)
	 (collect/async i)
	 (loop (+ i 1))))
     ;; Start fibers losing integers
     (let loop ((i 0))
       (when (< i %losers)
	 (lose/async (* i %count/loser) (* (+ 1 i) %count/loser))
	 (loop (+ i 1))))
     ;; Try starting the collectors and losers start at the same time, to
     ;; maximise concurrency.
     (signal-condition! start)
     (let loop ((i 0))
       (when (< i %losers)
	 (get-message done-channel/losers)
	 (loop (+ i 1))))
     (signal-condition! done-losing)
     ;; Wait for 'collected' to be initialised.
     (let loop ((i 0))
       (when (< i %collectors)
	 (get-message done-channel/collectors)
	 (loop (+ i 1))))
     ;; Do like 'verify' does, without the - 5 because the GC
     ;; was bypassed.
     (define results (make-bitvector (* %count/loser %losers)))
     (define (register-result! i)
       (assert (not (bitvector-bit-set? results i)))
       (bitvector-set-bit! results i))
     (let loop ((i 0))
       (when (< i %collectors)
	 (for-each
	  (lambda (list)
	    (for-each register-result! list))
	  (vector-ref collected i))
	 (loop (+ i 1))))
     (define fraction (/ (bitvector-count results) (bitvector-length results)))
     (pk 'f (+ 0.0 fraction))
     (assert (>= fraction 1)))
   #:install-suspendable-ports? #false ; unnecessary
   #:hz 10000))

(test-assert "lost-and-found as a string (empty)"
  (let* ((l (make-lost-and-found))
	 (expected (format #f "#<lost-and-found ~x empty>"
			   (object-address l)))
	 (found (object->string l)))
    (string=? expected found)))

;; It is important to _not_ print the objects inside the lost-and-found,
;; because <losable> objects keep a lost-and-found in their fields and hence
;; printing these objects would lead to infinite recursion.
(test-assert "lost-and-found as a string (non-empty)"
  (let* ((l (make-lost-and-found))
	 (expected (format #f "#<lost-and-found ~x non-empty>"
			   (object-address l))))
    (add-found! l (make-losable l))
    (define found (object->string l))
    (string=? expected found)))

;; The exception is better raised during the construction of the
;; <losable> than during the after-gc hook.
(test-error "make-losable without lost-and-found" (make-losable 'bogus))

(test-end "lost-and-found")