Ticket #1586: finalizer-fuzz.scm

;; (declare (disable-interrupts))
(module
 srfi18tests
 ()
 (import scheme)
 (cond-expand
  (chicken-5 (import (chicken base)
                     (chicken gc)
                     (chicken pretty-print)
                     (rename (chicken random) (pseudo-random-integer random)))
             (import (prefix srfi-18 srfi-18:))
             (import (only matchable match))
             (import (only srfi-1 iota)))
  (else (import chicken)
        (use (only extras random pp))
        (use (prefix srfi-18 srfi-18:))
        (use (only matchable match))
        (use (only srfi-1 iota))))

 (define (spin count) (let lp2 ([i 0]) (when (< i count) (lp2 (add1 i)))))

 (define (run-events evts)
   (define name (symbol->string (srfi-18:thread-name (srfi-18:current-thread))))

   (let lp ([evs evts] [event-num 0])
     (unless (null? evs)
       ;; (print name " " (car evs))
       (match (car evs)
         [('yield) (srfi-18:thread-yield!)]
         [('spin count) (spin count)]
         [('sleep t) (srfi-18:thread-sleep! t)]
         [('add-finalized count) (set-finalizer! (list 'foo) (lambda (o) (spin count)))]
         [('gc-) (gc)]
         [('gc #t) (gc #t)]
         [f (error "unknown event" f)])
       (lp (cdr evs) (add1 event-num)))))

 (define (run-threads evts-lists)
   (let* ([threads (map (lambda [thread-no evts]
                          (srfi-18:make-thread
                           (lambda () (run-events evts))
                           (string->symbol (string-append "thread-" (number->string thread-no)))))
                        (iota (length evts-lists))
                        evts-lists)])

     (pp (cons 'list (map (lambda (l) `(make-thread (lambda () ,@l))) evts-lists)))
     (gc #t)
     (for-each srfi-18:thread-start! threads)
     (for-each srfi-18:thread-join! threads)))

 (define (gen-events count)
   (let lp ([c count] [evs '()])
     (if (= c 0)
         evs
         (lp (sub1 c)
             (cons (let ([r (random 7)])
                     (cond [(= 0 r) '(yield)]
                           [(= 1 r) '(spin 1000)]
                           [(= 2 r) '(add-finalized 100)]
                           [(= 3 r) '(add-finalized 1000)]
                           [(= 5 r) '(gc #t)]
                           ;; [(= 7 r) 'gc-]
                           [else '(spin 10)]))
                   evs)))))

 (let lp ([i 0])
   (when (< i 1000000)
     (print "######################################## " i)
     (let ([max-evts 7]
           [max-threads 2])
       (run-threads (map (lambda (_) (gen-events (add1 (random max-evts))))
                         (iota (add1 (random max-threads))))))
     (lp (add1 i))))

 )