raco setup: add a layer of db write locking, db read fallback
Change `raco setup' to guard database writes in different places by an explicit lock that is implemented by place channels. Change corss-reference reading to fall back to just loading ".sxref" files if the database seems to be too contended at that point. These changes are aimed at avoiding distaerous performance when SQLite seems not to behave well. Also, fix break and other exception handling near the "fast abort" path for both reads and writes.
This commit is contained in:
Matthew Flatt
parent
9062d27d31
commit
31e644e5e1
|
|
@ -35,6 +35,7 @@
|
|||
'prepare-tables
|
||||
db
|
||||
#f
|
||||
+inf.0
|
||||
(lambda ()
|
||||
(prepare-tables db))))
|
||||
db)
|
||||
|
|
@ -60,6 +61,7 @@
|
|||
|
||||
(define (call-with-database who db-file proc
|
||||
#:fail [fail #f]
|
||||
#:delay-limit [pause-limit +inf.0]
|
||||
#:setup [setup void]
|
||||
#:teardown [teardown void])
|
||||
(let loop ([pause (doc-db-init-pause)])
|
||||
|
|
@ -73,12 +75,19 @@
|
|||
who
|
||||
db
|
||||
(if (connection? db-file)
|
||||
(lambda () (esc fail))
|
||||
(lambda ()
|
||||
(esc (lambda ()
|
||||
(disconnect db)
|
||||
(when fail (fail))
|
||||
(loop (doc-db-pause who pause))))))
|
||||
(and fail
|
||||
(lambda (should-retry?)
|
||||
(if should-retry?
|
||||
(esc (lambda () (fail #t)))
|
||||
(fail #f))))
|
||||
(lambda (should-retry?)
|
||||
(if should-retry?
|
||||
(esc (lambda ()
|
||||
(disconnect db)
|
||||
(when fail (fail))
|
||||
(loop (doc-db-pause who pause))))
|
||||
(disconnect db))))
|
||||
pause-limit
|
||||
(lambda ()
|
||||
(define results (call-with-values (lambda () (proc db)) list))
|
||||
(lambda () (apply values results))))
|
||||
|
|
@ -88,11 +97,13 @@
|
|||
|
||||
(define (doc-db-key->path db-file key
|
||||
#:fail [fail #f]
|
||||
#:delay-limit [pause-limit +inf.0]
|
||||
#:main-doc-relative-ok? [main-doc-relative-ok? #f])
|
||||
(call-with-database
|
||||
'doc-db-key->path
|
||||
db-file
|
||||
#:fail fail
|
||||
#:delay-limit pause-limit
|
||||
(lambda (db)
|
||||
(define row (query-maybe-row db select-pathid-vq
|
||||
(~s key)))
|
||||
|
|
@ -447,51 +458,51 @@
|
|||
(regexp-match #rx"the database file is locked$"
|
||||
(exn-message v))))
|
||||
|
||||
;; Call in a transation and handle Sqlite-level lock failures. By
|
||||
;; default, failure uses rollbacks, but `fast-abort' can be provided
|
||||
;; for a faster abort by dropping the connection. Don't try to use a
|
||||
;; connection provided here in any other way on an abort.
|
||||
(define (call-with-transaction/retry who db fast-abort thunk)
|
||||
(let ([old-break-paramz (current-break-parameterization)]
|
||||
[can-break? (break-enabled)])
|
||||
(let loop ([pause (doc-db-init-pause)])
|
||||
(define (call-with-lock-handler handler thunk)
|
||||
;; By default, failure uses rollbacks, but `fast-abort' can be
|
||||
;; provided for a faster abort by dropping the connection. Don't try
|
||||
;; to use a connection provided here in any other way on an abort. The
|
||||
;; argument to `fast-abort' is `should-retry?': on #t, perhaps escape
|
||||
;; to retry, but on #f, just clean up without escaping.
|
||||
(define (call-with-transaction/retry who db fast-abort pause-limit thunk)
|
||||
(let loop ([pause (doc-db-init-pause)])
|
||||
(define (call-with-lock-handler handler thunk)
|
||||
(with-handlers* ([exn:fail:database-locked?
|
||||
(lambda (exn) (handler pause))])
|
||||
(thunk)))
|
||||
((let/ec esc
|
||||
(define success? #f)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(if (and fast-abort
|
||||
(pause . > . pause-limit))
|
||||
(fast-abort #t)
|
||||
(loop (doc-db-pause `(start ,who) pause))))))
|
||||
(lambda () (start-transaction db))))
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(rollback db fast-abort #t 1)
|
||||
(loop (doc-db-pause `(rollback ,who) pause)))))
|
||||
(lambda ()
|
||||
(define l (call-with-values thunk list))
|
||||
(commit-transaction db)
|
||||
(set! success? #t)
|
||||
(lambda () (apply values l)))))
|
||||
(lambda ()
|
||||
(unless success?
|
||||
(rollback db fast-abort #f 1))))))))
|
||||
|
||||
(define (rollback db fast-abort should-retry? count)
|
||||
(if fast-abort
|
||||
(fast-abort should-retry?)
|
||||
(when (in-transaction? db)
|
||||
(with-handlers* ([exn:fail:database-locked?
|
||||
(lambda (exn)
|
||||
;; Try again:
|
||||
(loop (doc-db-pause who pause)))])
|
||||
(thunk)))
|
||||
((let/ec esc
|
||||
(define success? #f)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(loop (doc-db-pause `(start ,who) pause)))))
|
||||
(lambda () (start-transaction db))))
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(rollback db fast-abort 1)
|
||||
(loop (doc-db-pause `(rollback ,who) pause)))))
|
||||
(lambda ()
|
||||
(define l (call-with-values thunk list))
|
||||
(commit-transaction db)
|
||||
(set! success? #t)
|
||||
(lambda () (apply values l)))))
|
||||
(lambda ()
|
||||
(unless success?
|
||||
(rollback db fast-abort 1)))))))))
|
||||
|
||||
(define (rollback db fast-abort count)
|
||||
(when (in-transaction? db)
|
||||
(when fast-abort
|
||||
(fast-abort))
|
||||
(with-handlers* ([exn:fail:database-locked?
|
||||
(lambda (exn)
|
||||
(when (zero? (modulo count 100))
|
||||
(when (= count 10000) (error "fail"))
|
||||
(log-doc-db-info "database locked on rollback for ~a; tried ~a times so far"
|
||||
count))
|
||||
(rollback db #f (add1 count)))])
|
||||
(rollback-transaction db))))
|
||||
(when (zero? (modulo count 100))
|
||||
(when (= count 10000) (error "fail"))
|
||||
(log-doc-db-info "database locked on rollback; tried ~a times so far"
|
||||
count))
|
||||
(rollback db #f should-retry? (add1 count)))])
|
||||
(rollback-transaction db)))))
|
||||
|
|
|
|||
|
|
@ -70,6 +70,40 @@
|
|||
(setup-printf "error running" (module-path-prefix->string (doc-src-spec doc)))
|
||||
(eprintf errstr))
|
||||
|
||||
;; We use a lock to control writing to the database, because
|
||||
;; the database or binding doesn't seem to deal well with concurrent
|
||||
;; writers within a process.
|
||||
(define no-lock void)
|
||||
(define (lock-via-channel lock-ch)
|
||||
(let ([saved-ch #f])
|
||||
(lambda (mode)
|
||||
(case mode
|
||||
[(lock)
|
||||
(define ch (sync lock-ch))
|
||||
(place-channel-put ch 'lock)
|
||||
(set! saved-ch ch)]
|
||||
[(unlock)
|
||||
(place-channel-put saved-ch 'done)
|
||||
(set! saved-ch #f)]))))
|
||||
(define lock-ch #f)
|
||||
(define lock-ch-in #f)
|
||||
(define (init-lock-ch!)
|
||||
(unless lock-ch
|
||||
(set!-values (lock-ch lock-ch-in) (place-channel))
|
||||
(thread (lambda ()
|
||||
(define-values (ch ch-in) (place-channel))
|
||||
(let loop ()
|
||||
(place-channel-put lock-ch-in ch)
|
||||
(place-channel-get ch-in)
|
||||
(place-channel-get ch-in)
|
||||
(loop))))))
|
||||
(define (call-with-lock lock thunk)
|
||||
(lock 'lock)
|
||||
(dynamic-wind
|
||||
void
|
||||
thunk
|
||||
(lambda () (lock 'unlock))))
|
||||
|
||||
(define (setup-scribblings
|
||||
worker-count ; number of cores to use to create documentation
|
||||
program-name ; name of program that calls setup-scribblings
|
||||
|
|
@ -162,7 +196,8 @@
|
|||
;; non-parallel version:
|
||||
(map (get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf #f
|
||||
#f force-out-of-date?)
|
||||
#f force-out-of-date?
|
||||
no-lock)
|
||||
docs)
|
||||
;; maybe parallel...
|
||||
(or
|
||||
|
|
@ -170,7 +205,8 @@
|
|||
with-record-error setup-printf #f
|
||||
;; only-fast:
|
||||
#t
|
||||
force-out-of-date?)
|
||||
force-out-of-date?
|
||||
no-lock)
|
||||
docs)])
|
||||
;; check fast result
|
||||
(and (andmap values infos)
|
||||
|
|
@ -179,8 +215,9 @@
|
|||
(parallel-do
|
||||
(min worker-count (length docs))
|
||||
(lambda (workerid)
|
||||
(init-lock-ch!)
|
||||
(list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?))
|
||||
force-out-of-date? lock-ch))
|
||||
(list-queue
|
||||
docs
|
||||
(lambda (x workerid) (s-exp->fasl (serialize x)))
|
||||
|
|
@ -191,9 +228,9 @@
|
|||
(lambda (work errmsg outstr errstr)
|
||||
(parallel-do-error-handler setup-printf work errmsg outstr errstr)))
|
||||
(define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest
|
||||
auto-main? auto-user? force-out-of-date?)
|
||||
auto-main? auto-user? force-out-of-date? lock-ch)
|
||||
(define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?
|
||||
force-out-of-date? lock
|
||||
send/report)
|
||||
doc)
|
||||
(define (setup-printf subpart formatstr . rest)
|
||||
|
|
@ -211,14 +248,14 @@
|
|||
(s-exp->fasl (serialize
|
||||
((get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf workerid
|
||||
#f force-out-of-date?)
|
||||
#f force-out-of-date? lock)
|
||||
(deserialize (fasl->s-exp doc))))))
|
||||
|
||||
(verbose verbosev)
|
||||
(match-message-loop
|
||||
[doc (send/success
|
||||
((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?
|
||||
force-out-of-date? (lock-via-channel lock-ch)
|
||||
send/report)
|
||||
doc))]))))))))
|
||||
|
||||
|
|
@ -392,7 +429,7 @@
|
|||
(and (info-need-run? i)
|
||||
(begin
|
||||
(when (info-need-in-write? i)
|
||||
(write-in/info latex-dest i)
|
||||
(write-in/info latex-dest i no-lock)
|
||||
(set-info-need-in-write?! i #f))
|
||||
(set-info-deps! i (filter info? (info-deps i)))
|
||||
(set-info-need-run?! i #f)
|
||||
|
|
@ -421,12 +458,13 @@
|
|||
(if ((min worker-count (length need-rerun)) . < . 2)
|
||||
(map (lambda (i)
|
||||
(say-rendering i #f)
|
||||
(update-info i (build-again! latex-dest i with-record-error)))
|
||||
(update-info i (build-again! latex-dest i with-record-error no-lock)))
|
||||
need-rerun)
|
||||
(parallel-do
|
||||
(min worker-count (length need-rerun))
|
||||
(lambda (workerid)
|
||||
(list workerid (verbose) latex-dest))
|
||||
(init-lock-ch!)
|
||||
(list workerid (verbose) latex-dest lock-ch))
|
||||
(list-queue
|
||||
need-rerun
|
||||
(lambda (i workerid)
|
||||
|
|
@ -438,7 +476,7 @@
|
|||
(update-info i (deserialize (fasl->s-exp r))))
|
||||
(lambda (i errmsg outstr errstr)
|
||||
(parallel-do-error-handler setup-printf (info-doc i) errmsg outstr errstr)))
|
||||
(define-worker (build-again!-worker2 workerid verbosev latex-dest)
|
||||
(define-worker (build-again!-worker2 workerid verbosev latex-dest lock-ch)
|
||||
(define (with-record-error cc go fail-k)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
|
|
@ -451,7 +489,8 @@
|
|||
(send/success
|
||||
(s-exp->fasl (serialize (build-again! latex-dest
|
||||
(deserialize (fasl->s-exp info))
|
||||
with-record-error))))])))))
|
||||
with-record-error
|
||||
(lock-via-channel lock-ch)))))])))))
|
||||
;; If we only build 1, then it reaches it own fixpoint
|
||||
;; even if the info doesn't seem to converge immediately.
|
||||
;; This is a useful shortcut when re-building a single
|
||||
|
|
@ -464,7 +503,7 @@
|
|||
(when infos
|
||||
(make-loop #t 0)
|
||||
;; cache info to disk
|
||||
(for ([i infos] #:when (info-need-in-write? i)) (write-in/info latex-dest i))))
|
||||
(for ([i infos] #:when (info-need-in-write? i)) (write-in/info latex-dest i no-lock))))
|
||||
|
||||
(define (make-renderer latex-dest doc)
|
||||
(if latex-dest
|
||||
|
|
@ -614,7 +653,7 @@
|
|||
|
||||
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf workerid
|
||||
only-fast? force-out-of-date?)
|
||||
only-fast? force-out-of-date? lock)
|
||||
doc)
|
||||
(let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
|
||||
(sxref-path latex-dest doc (format "out~a.sxref" i)))]
|
||||
|
|
@ -710,7 +749,7 @@
|
|||
(delete-file info-in-file)
|
||||
((get-doc-info only-dirs latex-dest auto-main?
|
||||
auto-user? with-record-error
|
||||
setup-printf workerid #f #f)
|
||||
setup-printf workerid #f #f lock)
|
||||
doc))])
|
||||
(let ([v-in (load-sxref info-in-file)])
|
||||
(unless (equal? (car v-in) (list vers (doc-flags doc)))
|
||||
|
|
@ -784,10 +823,10 @@
|
|||
#f
|
||||
#f)])
|
||||
(when need-out-write?
|
||||
(render-time "xref-out" (write-out/info latex-dest info scis defss db-file))
|
||||
(render-time "xref-out" (write-out/info latex-dest info scis defss db-file lock))
|
||||
(set-info-need-out-write?! info #f))
|
||||
(when (info-need-in-write? info)
|
||||
(render-time "xref-in" (write-in/info latex-dest info))
|
||||
(render-time "xref-in" (write-in/info latex-dest info lock))
|
||||
(set-info-need-in-write?! info #f))
|
||||
|
||||
(when (or (stamp-time . < . aux-time)
|
||||
|
|
@ -871,7 +910,7 @@
|
|||
searches
|
||||
scis))])]))
|
||||
|
||||
(define (build-again! latex-dest info with-record-error)
|
||||
(define (build-again! latex-dest info with-record-error lock)
|
||||
(define (cleanup-dest-dir doc)
|
||||
(unless latex-dest
|
||||
(let ([dir (doc-dest-dir doc)])
|
||||
|
|
@ -933,9 +972,9 @@
|
|||
(doc-src-file doc)))
|
||||
|
||||
(when in-delta?
|
||||
(render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel searches db-file)))
|
||||
(render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel searches db-file lock)))
|
||||
(when out-delta?
|
||||
(render-time "xref-out" (write-out latex-dest vers doc scis defss db-file)))
|
||||
(render-time "xref-out" (write-out latex-dest vers doc scis defss db-file lock)))
|
||||
|
||||
(cleanup-dest-dir doc)
|
||||
(render-time
|
||||
|
|
@ -993,31 +1032,37 @@
|
|||
data))
|
||||
out))))))
|
||||
|
||||
(define (write-out latex-dest vers doc scis providess db-file)
|
||||
(define (write-out latex-dest vers doc scis providess db-file lock)
|
||||
(for ([i (add1 (doc-out-count doc))]
|
||||
[sci scis]
|
||||
[provides providess])
|
||||
(write- latex-dest vers doc (format "out~a.sxref" i)
|
||||
(list (list sci))
|
||||
(lambda (filename)
|
||||
(doc-db-clear-provides db-file filename)
|
||||
(doc-db-add-provides db-file provides filename)))))
|
||||
(write- latex-dest vers doc (format "out~a.sxref" i)
|
||||
(list (list sci))
|
||||
(lambda (filename)
|
||||
(call-with-lock
|
||||
lock
|
||||
(lambda ()
|
||||
(doc-db-clear-provides db-file filename)
|
||||
(doc-db-add-provides db-file provides filename)))))))
|
||||
|
||||
(define (write-out/info latex-dest info scis providess db-file)
|
||||
(write-out latex-dest (info-vers info) (info-doc info) scis providess db-file))
|
||||
(define (write-out/info latex-dest info scis providess db-file lock)
|
||||
(write-out latex-dest (info-vers info) (info-doc info) scis providess db-file lock))
|
||||
|
||||
(define (write-in latex-dest vers doc undef rels searches db-file)
|
||||
(define (write-in latex-dest vers doc undef rels searches db-file lock)
|
||||
(write- latex-dest vers doc "in.sxref"
|
||||
(list (list rels)
|
||||
(list (serialize (list undef
|
||||
searches))))
|
||||
(lambda (filename)
|
||||
(doc-db-clear-dependencies db-file filename)
|
||||
(doc-db-clear-searches db-file filename)
|
||||
(doc-db-add-dependencies db-file undef filename)
|
||||
(doc-db-add-searches db-file searches filename))))
|
||||
(call-with-lock
|
||||
lock
|
||||
(lambda ()
|
||||
(doc-db-clear-dependencies db-file filename)
|
||||
(doc-db-clear-searches db-file filename)
|
||||
(doc-db-add-dependencies db-file undef filename)
|
||||
(doc-db-add-searches db-file searches filename))))))
|
||||
|
||||
(define (write-in/info latex-dest info)
|
||||
(define (write-in/info latex-dest info lock)
|
||||
(when (eq? 'delayed (info-undef info))
|
||||
(read-delayed-in! info latex-dest))
|
||||
(write-in latex-dest
|
||||
|
|
@ -1026,7 +1071,8 @@
|
|||
(info-undef info)
|
||||
(info-deps->rel-doc-src-file info)
|
||||
(info-searches info)
|
||||
(find-db-file (info-doc info) latex-dest)))
|
||||
(find-db-file (info-doc info) latex-dest)
|
||||
lock))
|
||||
|
||||
(define (rel->path r)
|
||||
(if (bytes? r)
|
||||
|
|
|
|||
|
|
@ -75,47 +75,63 @@
|
|||
;; cache for a connection:
|
||||
(box #f))))
|
||||
(define done-ht (make-hash)) ; tracks already-loaded documents
|
||||
(define forced-all? #f)
|
||||
(define (force-all)
|
||||
;; force all documents
|
||||
(define thunks (get-reader-thunks no-user? done-ht))
|
||||
(set! forced-all? #t)
|
||||
(lambda ()
|
||||
;; return a procedure so we can produce a list of results:
|
||||
(lambda ()
|
||||
(for/list ([thunk (in-list thunks)])
|
||||
(thunk)))))
|
||||
(define pause-limit 1.0)
|
||||
(lambda (key)
|
||||
(cond
|
||||
[forced-all? #f]
|
||||
[key
|
||||
(define (try p)
|
||||
(let loop ([pause (doc-db-init-pause)])
|
||||
(and p
|
||||
(let* ([maybe-db (unbox (cdr p))]
|
||||
[db
|
||||
;; Use a cached connection, or...
|
||||
(or (and (box-cas! (cdr p) maybe-db #f)
|
||||
maybe-db)
|
||||
;; ... create a new one
|
||||
(and (file-exists? (car p))
|
||||
(doc-db-file->connection (car p))))])
|
||||
(and
|
||||
db
|
||||
((let/ec esc
|
||||
;; The db query:
|
||||
(define result
|
||||
(doc-db-key->path db key
|
||||
#:fail (lambda ()
|
||||
;; Rollback within a connection can be slow,
|
||||
;; so abandon the connection and try again:
|
||||
(doc-db-disconnect db)
|
||||
(esc (lambda ()
|
||||
(loop (doc-db-pause 'xref-lookup pause)))))))
|
||||
;; cache the connection, if none is already cached:
|
||||
(or (box-cas! (cdr p) #f db)
|
||||
(doc-db-disconnect db))
|
||||
(lambda () result))))))))
|
||||
(cond
|
||||
[(pause . >= . pause-limit)
|
||||
;; Too much database contention? Give up on the database.
|
||||
#t]
|
||||
[else
|
||||
(and p
|
||||
(let* ([maybe-db (unbox (cdr p))]
|
||||
[db
|
||||
;; Use a cached connection, or...
|
||||
(or (and (box-cas! (cdr p) maybe-db #f)
|
||||
maybe-db)
|
||||
;; ... create a new one
|
||||
(and (file-exists? (car p))
|
||||
(doc-db-file->connection (car p))))])
|
||||
(and
|
||||
db
|
||||
((let/ec esc
|
||||
;; The db query:
|
||||
(define result
|
||||
(doc-db-key->path db key
|
||||
#:delay-limit pause-limit
|
||||
#:fail (lambda (should-retry?)
|
||||
;; Rollback within a connection can be slow,
|
||||
;; so abandon the connection and try again:
|
||||
(doc-db-disconnect db)
|
||||
(when should-retry?
|
||||
(esc (lambda ()
|
||||
(loop (doc-db-pause 'xref-lookup pause))))))))
|
||||
;; cache the connection, if none is already cached:
|
||||
(or (box-cas! (cdr p) #f db)
|
||||
(doc-db-disconnect db))
|
||||
(lambda () result))))))])))
|
||||
(define dest (or (try main-db) (try user-db)))
|
||||
(and dest
|
||||
((dest->source done-ht) dest))]
|
||||
(if (eq? dest #t)
|
||||
(force-all)
|
||||
((dest->source done-ht) dest)))]
|
||||
[else
|
||||
;; force all documents
|
||||
(define thunks (get-reader-thunks no-user? done-ht))
|
||||
(lambda ()
|
||||
;; return a procedure so we can produce a list of results:
|
||||
(lambda ()
|
||||
(for/list ([thunk (in-list thunks)])
|
||||
(thunk))))])))
|
||||
(unless forced-all?
|
||||
(force-all))])))
|
||||
|
||||
(define (get-reader-thunks no-user? done-ht)
|
||||
(map (dest->source done-ht)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user