;; Fibers: cooperative, event-driven user-space threads.

;;;; Copyright (C) 2025 Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public License
;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;

(define-module (tests cancel-timer)
  #:use-module (fibers)
  #:use-module (fibers io-wakeup)
  #:use-module (fibers operations)
  #:use-module (fibers timers)
  #:use-module (ice-9 format))

;;; Check the heap growth caused by repeated choice operations where one of
;;; the base operations is a 'wait-until-port-*' operation that always
;;; "loses" the choice.
;;;
;;; This situation used to cause file descriptor waiters to accumulate,
;;; thereby leading to unbounded heap growth.  The nack function of
;;; 'wait-until-port-*-operation' fixes that by immediately canceling timers
;;; that lost in a choice operation.  See
;;; <https://codeberg.org/guile/fibers/issues/154>.

(define (heap-size)
  (assoc-ref (gc-stats) 'heap-size))

(define (MiB size)
  (/ size (expt 2 20.)))

(define iterations
  ;; The number of iterations must be high enough to exhibit the original
  ;; leak but not too high so this test is not too expensive.
  15000)

(define nothingness
  ;; File where input is always unavailable.
  (in-vicinity (or (getenv "TMPDIR") "/tmp")
               "nothing"))

(false-if-exception (delete-file nothingness))
(mknod nothingness 'fifo #o400 0)

(run-fibers
 (lambda ()
   (define port
     (open nothingness (logior O_RDONLY O_NONBLOCK)))

   (let ((initial-heap-size (heap-size)))
     (let loop ((i 0))
       (let ((p (perform-operation
                 (choice-operation (wrap-operation (sleep-operation 0.00001)
                                                   (const #f))
                                   (wrap-operation
                                    (wait-until-port-readable-operation port)
                                    (const port))))))

         (when (zero? (modulo i 4000))
           (pk 'heap (MiB (heap-size))))
         (when p
           (read-char p))
         (unless (> i iterations)
           (loop (+ i 1)))))

     (delete-file nothingness)
     (let ((final-heap-size (heap-size)))
       (if (<= final-heap-size (* 2.5 initial-heap-size))
           (format #t "final heap size: ~,2f MiB; initial heap size: ~,2f MiB~%"
                   (MiB final-heap-size) (MiB initial-heap-size))
           (begin
             (format #t "heap grew too much: ~,2f MiB vs. ~,2f MiB~%"
                     (MiB final-heap-size) (MiB initial-heap-size))
             (primitive-exit 1)))))))

;; Ensure that the underlying file descriptor waiter can be canceled
;; without error even if the associated port has been closed.
;; See <https://codeberg.org/guile/fibers/issues/168>.

(run-fibers
 (lambda ()
   (let ((in (car (pipe))))
     (spawn-fiber (lambda () (close-port in)))
     (perform-operation
      (choice-operation (wait-until-port-readable-operation in)
                        (sleep-operation 0.5)))))
 #:parallelism 1)
