db: added variations of concurrency test
This commit is contained in:
parent
7c395e9c7c
commit
7da5063782
|
@ -6,9 +6,17 @@
|
||||||
(import database^ config^)
|
(import database^ config^)
|
||||||
(export test^)
|
(export test^)
|
||||||
|
|
||||||
(define (test-concurrency workers)
|
(define (test-concurrency workers [threads? #t] [concurrent? #t])
|
||||||
|
;; if threads?, use threads, else use thunks
|
||||||
|
;; if serialize?, run threads one at a time, else run all at once
|
||||||
(unless (ANYFLAGS 'isora 'isdb2)
|
(unless (ANYFLAGS 'isora 'isdb2)
|
||||||
(test-case (format "lots of threads (~s)" workers)
|
(test-case (format "lots of ~a (~s)"
|
||||||
|
(cond [(and threads? concurrent?)
|
||||||
|
"concurrent threads"]
|
||||||
|
[threads?
|
||||||
|
"serialized threads"]
|
||||||
|
[else "sequential work"])
|
||||||
|
workers)
|
||||||
(call-with-connection
|
(call-with-connection
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(query-exec c "create temporary table play_numbers (n integer)")
|
(query-exec c "create temporary table play_numbers (n integer)")
|
||||||
|
@ -17,14 +25,20 @@
|
||||||
(let ([exns null])
|
(let ([exns null])
|
||||||
(parameterize ((uncaught-exception-handler
|
(parameterize ((uncaught-exception-handler
|
||||||
(lambda (e) (set! exns (cons e exns)) ((error-escape-handler)))))
|
(lambda (e) (set! exns (cons e exns)) ((error-escape-handler)))))
|
||||||
(for-each thread-wait
|
(let* ([workers (for/list ([i (in-range workers)]) (mk-worker c 100 i))]
|
||||||
(map thread
|
[tasks (for/list ([worker (in-list workers)])
|
||||||
(map (mk-worker c 100) (build-list workers add1)))))
|
(cond [(and threads? concurrent?)
|
||||||
|
(let ([thd (thread worker)])
|
||||||
|
(lambda () (thread-wait thd)))]
|
||||||
|
[threads?
|
||||||
|
(lambda () (thread-wait (thread worker)))]
|
||||||
|
[else worker]))])
|
||||||
|
(for ([task (in-list tasks)]) (task))))
|
||||||
(when (pair? exns)
|
(when (pair? exns)
|
||||||
(raise (make-exn (string-append "exception in thread: " (exn-message (car exns)))
|
(raise (make-exn (string-append "exception in thread: " (exn-message (car exns)))
|
||||||
(exn-continuation-marks (car exns)))))))))))
|
(exn-continuation-marks (car exns)))))))))))
|
||||||
|
|
||||||
(define (((mk-worker c iterations) tid))
|
(define ((mk-worker c iterations tid))
|
||||||
(define insert-pst
|
(define insert-pst
|
||||||
(prepare c (sql "insert into play_numbers (n) values ($1)")))
|
(prepare c (sql "insert into play_numbers (n) values ($1)")))
|
||||||
(define (insert x) (query-exec c insert-pst x))
|
(define (insert x) (query-exec c insert-pst x))
|
||||||
|
@ -109,5 +123,7 @@
|
||||||
;; Tests whether connections are properly locked.
|
;; Tests whether connections are properly locked.
|
||||||
(test-concurrency 1)
|
(test-concurrency 1)
|
||||||
(test-concurrency 2)
|
(test-concurrency 2)
|
||||||
(test-concurrency 20)
|
(test-concurrency 20 #t #t)
|
||||||
|
(test-concurrency 20 #t #f)
|
||||||
|
(test-concurrency 20 #f #f)
|
||||||
(kill-safe-test #t)))
|
(kill-safe-test #t)))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user