diff options
| -rw-r--r-- | guix-qa-frontpage/database.scm | 51 | ||||
| -rw-r--r-- | guix-qa-frontpage/manage-patch-branches.scm | 4 | ||||
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 38 |
3 files changed, 29 insertions, 64 deletions
diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm index 3bab909..4e42c52 100644 --- a/guix-qa-frontpage/database.scm +++ b/guix-qa-frontpage/database.scm @@ -29,7 +29,7 @@ #:use-module (fibers) #:use-module (prometheus) #:use-module (knots queue) - #:use-module (knots worker-threads) + #:use-module (knots thread-pool) #:use-module (guix narinfo) #:use-module (guix derivations) #:use-module ((guix-build-coordinator utils) @@ -146,23 +146,23 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( (sqlite-close db)) - (let ((reader-thread-set - (make-worker-thread-set + (let ((reader-thread-pool + (make-thread-pool + (min (max (current-processor-count) + 32) + 128) + #:thread-initializer (lambda () (let ((db (db-open database-file #:write? #f))) (sqlite-exec db "PRAGMA busy_timeout = 5000;") (list db))) - #:destructor + #:thread-destructor (lambda (db) (sqlite-close db)) - #:lifetime 50000 + #:thread-lifetime 50000 #:name "db read" - #:parallelism - (min (max (current-processor-count) - 32) - 128) #:delay-logger (let ((delay-metric (make-histogram-metric metrics-registry @@ -183,25 +183,26 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( #:log-exception? (lambda (exn) (not (guix-data-service-error? exn))))) - (writer-thread-set - (make-worker-thread-set + (writer-thread-pool + (make-thread-pool + ;; SQLite doesn't support parallel writes + 1 + #:thread-initializer (lambda () (let ((db (db-open database-file))) (sqlite-exec db "PRAGMA busy_timeout = 5000;") (sqlite-exec db "PRAGMA foreign_keys = ON;") (list db))) - #:destructor + #:thread-destructor (lambda (db) (db-optimize db database-file) (sqlite-close db)) - #:lifetime 500 + #:thread-lifetime 500 #:name "db write" - ;; SQLite doesn't support parallel writes - #:parallelism 1 #:delay-logger (let ((delay-metric (make-histogram-metric metrics-registry @@ -221,9 +222,9 @@ CREATE TABLE IF NOT EXISTS create_branch_for_issue_logs ( seconds-delayed))))))) (make-database database-file - reader-thread-set - writer-thread-set - (worker-thread-set-channel writer-thread-set) + reader-thread-pool + writer-thread-pool + (thread-pool-channel writer-thread-pool) metrics-registry))) (define (db-optimize db db-filename) @@ -248,7 +249,7 @@ PRAGMA optimize;"))) (define (database-optimize database) (retry-on-error (lambda () - (call-with-worker-thread + (call-with-thread (database-writer-thread-set database) (lambda (db) (db-optimize @@ -263,7 +264,7 @@ PRAGMA optimize;"))) (set-database-writer-thread-set-channel! database (spawn-queueing-fiber - (worker-thread-set-channel + (thread-pool-channel (database-writer-thread-set database)))) (spawn-fiber @@ -325,7 +326,7 @@ PRAGMA optimize;"))) (apply values vals)))) #:unwind? #t)))) - (match (call-with-worker-thread + (match (call-with-thread ((if readonly? database-reader-thread-set database-writer-thread-set) @@ -437,7 +438,7 @@ DELETE FROM cache WHERE key = :key" (error "must specify a ttl")) (let ((cached-values - (call-with-worker-thread + (call-with-thread (database-reader-thread-set database) (lambda (db) (let ((statement @@ -471,7 +472,7 @@ SELECT data, timestamp FROM cache WHERE key = :key" (if (eq? cached-values 'noval) (call-with-values (lambda () - (call-with-worker-thread + (call-with-thread (database-reader-thread-set database) (lambda (db) (with-throw-handler #t @@ -569,7 +570,7 @@ WHERE category_name = :name AND category_value = :value" #t) (define (select-from-builds-to-cancel-later database category-name) - (call-with-worker-thread + (call-with-thread (database-reader-thread-set database) (lambda (db) (let ((statement @@ -625,7 +626,7 @@ VALUES (:issue, :log)" (sqlite-reset insert-statement))))) (define (select-create-branch-for-issue-log database issue) - (call-with-worker-thread + (call-with-thread (database-reader-thread-set database) (lambda (db) (let ((statement diff --git a/guix-qa-frontpage/manage-patch-branches.scm b/guix-qa-frontpage/manage-patch-branches.scm index 682b183..b92e8a8 100644 --- a/guix-qa-frontpage/manage-patch-branches.scm +++ b/guix-qa-frontpage/manage-patch-branches.scm @@ -19,7 +19,7 @@ #:use-module (guix build utils) #:use-module ((guix build download) #:select (http-fetch)) #:use-module ((guix build utils) #:select (with-directory-excursion)) - #:use-module (knots worker-threads) + #:use-module (knots thread-pool) #:use-module (guix-qa-frontpage mumi) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage git-repository) @@ -523,7 +523,7 @@ (current-error-port) "exception in manage patch branches thread: ~A\n" exn) - (unless (worker-thread-timeout-error? exn) + (unless (thread-pool-timeout-error? exn) (sleep 240))) (lambda () (with-throw-handler #t diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index 8009b59..63b741c 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -25,45 +25,9 @@ #:use-module (fibers channels) #:use-module (knots) #:use-module (zlib) - #:export (fiberize - non-blocking + #:export (non-blocking call-with-zlib-input-port*)) -(define* (fiberize proc #:key (parallelism 1)) - (let ((channel (make-channel))) - (for-each - (lambda _ - (spawn-fiber - (lambda () - (while #t - (let ((reply-channel args (car+cdr - (get-message channel)))) - (put-message - reply-channel - (with-exception-handler - (lambda (exn) - (cons 'exception exn)) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - (apply proc args)) - (lambda vals - (cons 'result vals)))) - (lambda _ - (backtrace)))) - #:unwind? #t))))) - #:parallel? #t)) - (iota parallelism)) - - (lambda args - (let ((reply-channel (make-channel))) - (put-message channel (cons reply-channel args)) - (match (get-message reply-channel) - (('result . vals) (apply values vals)) - (('exception . exn) (raise-exception exn))))))) - (define (non-blocking thunk) (let ((channel (make-channel))) (call-with-default-io-waiters |