| 1 | ;; (declare (disable-interrupts))
|
|---|
| 2 | (module
|
|---|
| 3 | srfi18tests
|
|---|
| 4 | ()
|
|---|
| 5 | (import scheme)
|
|---|
| 6 | (cond-expand
|
|---|
| 7 | (chicken-5 (import (chicken base)
|
|---|
| 8 | (chicken gc)
|
|---|
| 9 | (chicken pretty-print)
|
|---|
| 10 | (rename (chicken random) (pseudo-random-integer random)))
|
|---|
| 11 | (import (prefix srfi-18 srfi-18:))
|
|---|
| 12 | (import (only matchable match))
|
|---|
| 13 | (import (only srfi-1 iota)))
|
|---|
| 14 | (else (import chicken)
|
|---|
| 15 | (use (only extras random pp))
|
|---|
| 16 | (use (prefix srfi-18 srfi-18:))
|
|---|
| 17 | (use (only matchable match))
|
|---|
| 18 | (use (only srfi-1 iota))))
|
|---|
| 19 |
|
|---|
| 20 | (define (spin count) (let lp2 ([i 0]) (when (< i count) (lp2 (add1 i)))))
|
|---|
| 21 |
|
|---|
| 22 | (define (run-events evts)
|
|---|
| 23 | (define name (symbol->string (srfi-18:thread-name (srfi-18:current-thread))))
|
|---|
| 24 |
|
|---|
| 25 | (let lp ([evs evts] [event-num 0])
|
|---|
| 26 | (unless (null? evs)
|
|---|
| 27 | ;; (print name " " (car evs))
|
|---|
| 28 | (match (car evs)
|
|---|
| 29 | [('yield) (srfi-18:thread-yield!)]
|
|---|
| 30 | [('spin count) (spin count)]
|
|---|
| 31 | [('sleep t) (srfi-18:thread-sleep! t)]
|
|---|
| 32 | [('add-finalized count) (set-finalizer! (list 'foo) (lambda (o) (spin count)))]
|
|---|
| 33 | [('gc-) (gc)]
|
|---|
| 34 | [('gc #t) (gc #t)]
|
|---|
| 35 | [f (error "unknown event" f)])
|
|---|
| 36 | (lp (cdr evs) (add1 event-num)))))
|
|---|
| 37 |
|
|---|
| 38 | (define (run-threads evts-lists)
|
|---|
| 39 | (let* ([threads (map (lambda [thread-no evts]
|
|---|
| 40 | (srfi-18:make-thread
|
|---|
| 41 | (lambda () (run-events evts))
|
|---|
| 42 | (string->symbol (string-append "thread-" (number->string thread-no)))))
|
|---|
| 43 | (iota (length evts-lists))
|
|---|
| 44 | evts-lists)])
|
|---|
| 45 |
|
|---|
| 46 | (pp (cons 'list (map (lambda (l) `(make-thread (lambda () ,@l))) evts-lists)))
|
|---|
| 47 | (gc #t)
|
|---|
| 48 | (for-each srfi-18:thread-start! threads)
|
|---|
| 49 | (for-each srfi-18:thread-join! threads)))
|
|---|
| 50 |
|
|---|
| 51 | (define (gen-events count)
|
|---|
| 52 | (let lp ([c count] [evs '()])
|
|---|
| 53 | (if (= c 0)
|
|---|
| 54 | evs
|
|---|
| 55 | (lp (sub1 c)
|
|---|
| 56 | (cons (let ([r (random 7)])
|
|---|
| 57 | (cond [(= 0 r) '(yield)]
|
|---|
| 58 | [(= 1 r) '(spin 1000)]
|
|---|
| 59 | [(= 2 r) '(add-finalized 100)]
|
|---|
| 60 | [(= 3 r) '(add-finalized 1000)]
|
|---|
| 61 | [(= 5 r) '(gc #t)]
|
|---|
| 62 | ;; [(= 7 r) 'gc-]
|
|---|
| 63 | [else '(spin 10)]))
|
|---|
| 64 | evs)))))
|
|---|
| 65 |
|
|---|
| 66 | (let lp ([i 0])
|
|---|
| 67 | (when (< i 1000000)
|
|---|
| 68 | (print "######################################## " i)
|
|---|
| 69 | (let ([max-evts 7]
|
|---|
| 70 | [max-threads 2])
|
|---|
| 71 | (run-threads (map (lambda (_) (gen-events (add1 (random max-evts))))
|
|---|
| 72 | (iota (add1 (random max-threads))))))
|
|---|
| 73 | (lp (add1 i))))
|
|---|
| 74 |
|
|---|
| 75 | )
|
|---|
