raco setup: move doc dependency and duplicate checking to database
This change makes document building --- and specially incremental document building --- more scalable. The global duplicate-definition check is handled by a database query, for example.
This commit is contained in:
Matthew Flatt
parent
a73dc50224
commit
9888fac99e
|
|
@ -746,7 +746,10 @@
|
|||
(let ([parent (collected-info-parent (part-collected-info sec ri))])
|
||||
(if parent
|
||||
(collected-info-info (part-collected-info parent ri))
|
||||
(collect-info-ext-ht (resolve-info-ci ri))))
|
||||
(let ([ci (resolve-info-ci ri)])
|
||||
;; Force all xref info:
|
||||
((collect-info-ext-demand ci) #f ci)
|
||||
(collect-info-ext-ht ci))))
|
||||
(lambda (k v)
|
||||
(when (and (pair? k) (eq? 'index-entry (car k)))
|
||||
(set! l (cons (cons (cadr k) v) l)))))
|
||||
|
|
|
|||
|
|
@ -42,8 +42,9 @@
|
|||
[load-source (lambda (src ci)
|
||||
(parameterize ([current-namespace
|
||||
(namespace-anchor->empty-namespace here)])
|
||||
(let ([v (src)])
|
||||
(when v (send renderer deserialize-info v ci #:root root-path)))))]
|
||||
(let ([vs (src)])
|
||||
(for ([v (in-list (if (procedure? vs) (vs) (list vs)))])
|
||||
(when v (send renderer deserialize-info v ci #:root root-path))))))]
|
||||
[ci (send renderer collect null null fp
|
||||
(lambda (key ci)
|
||||
(define src (demand-source key))
|
||||
|
|
@ -57,14 +58,15 @@
|
|||
;; Xref reading
|
||||
|
||||
(define (xref-index xrefs)
|
||||
(filter
|
||||
values
|
||||
(hash-map
|
||||
(collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
|
||||
(lambda (k v)
|
||||
(define ci (resolve-info-ci (xrefs-ri xrefs)))
|
||||
;; Force all xref info:
|
||||
((collect-info-ext-demand ci) #f ci)
|
||||
;; look for `index-entry' keys:
|
||||
(for/list ([(k v) (in-hash (collect-info-ext-ht ci))]
|
||||
#:when
|
||||
(and (pair? k)
|
||||
(eq? (car k) 'index-entry)
|
||||
(make-entry (car v) (cadr v) (cadr k) (caddr v)))))))
|
||||
(eq? (car k) 'index-entry)))
|
||||
(make-entry (car v) (cadr v) (cadr k) (caddr v))))
|
||||
|
||||
;; dest-file can be #f, which will make it return a string holding the
|
||||
;; resulting html
|
||||
|
|
|
|||
|
|
@ -4,88 +4,369 @@
|
|||
"main-doc.rkt")
|
||||
|
||||
(provide doc-db-available?
|
||||
doc-db-record-provides
|
||||
doc-db-clear-provides
|
||||
doc-db-add-provides
|
||||
doc-db-clear-dependencies
|
||||
doc-db-add-dependencies
|
||||
doc-db-clear-searches
|
||||
doc-db-add-searches
|
||||
doc-db-key->path
|
||||
doc-db-file->connection)
|
||||
doc-db-check-duplicates
|
||||
doc-db-check-unsatisfied
|
||||
doc-db-get-dependencies
|
||||
doc-db-file->connection
|
||||
doc-db-disconnect
|
||||
doc-db-clean-files)
|
||||
|
||||
(define-logger doc-db)
|
||||
|
||||
(define (doc-db-available?)
|
||||
(sqlite3-available?))
|
||||
|
||||
(define (doc-db-file->connection db-file)
|
||||
(sqlite3-connect #:database db-file))
|
||||
(define exists? (file-exists? db-file))
|
||||
(define db (sqlite3-connect #:database db-file
|
||||
#:mode 'create
|
||||
#:busy-retry-limit 0))
|
||||
(unless exists?
|
||||
(call-with-transaction/retry
|
||||
void
|
||||
db
|
||||
#f
|
||||
(lambda ()
|
||||
(prepare-tables db))))
|
||||
db)
|
||||
|
||||
(define (doc-db-disconnect db)
|
||||
(disconnect db))
|
||||
|
||||
(define select-pathid-vq
|
||||
(virtual-statement "SELECT pathid FROM documented WHERE stag=$1"))
|
||||
(define select-path-vq
|
||||
(virtual-statement "SELECT atmain, path FROM pathids WHERE pathid=$1"))
|
||||
(define select-other-path-vq
|
||||
(virtual-statement "SELECT atmain, path FROM other.pathids WHERE pathid=$1"))
|
||||
|
||||
(define (doc-db-key->path db-file key)
|
||||
(define (call-with-database lock db-file proc
|
||||
#:fail [fail #f]
|
||||
#:setup [setup void]
|
||||
#:teardown [teardown void])
|
||||
(let loop ([pause 0.0])
|
||||
(unless (zero? pause) (sleep pause))
|
||||
((let/ec esc
|
||||
(define db (if (connection? db-file)
|
||||
db-file
|
||||
(doc-db-file->connection db-file)))
|
||||
|
||||
(define pathid
|
||||
(call-with-transaction/retry
|
||||
db
|
||||
(lambda ()
|
||||
(define row (query-maybe-row db
|
||||
select-pathid-vq
|
||||
(~s key)))
|
||||
(and row
|
||||
(vector-ref row 0)))))
|
||||
|
||||
(setup db)
|
||||
(begin0
|
||||
(and pathid
|
||||
(call-with-transaction/retry
|
||||
lock
|
||||
db
|
||||
(if (connection? db-file)
|
||||
(lambda () (esc fail))
|
||||
(lambda ()
|
||||
(define row (query-maybe-row db
|
||||
select-path-vq
|
||||
pathid))
|
||||
(and row
|
||||
(let ([path (read (open-input-bytes (vector-ref row 1)))])
|
||||
(if (equal? "y" (vector-ref row 0))
|
||||
(main-doc-relative->path (cons 'doc path))
|
||||
(bytes->path path)))))))
|
||||
(esc (lambda ()
|
||||
(disconnect db)
|
||||
(when fail (fail))
|
||||
(loop (max 0.01 (min 2 (* 2 pause))))))))
|
||||
(lambda ()
|
||||
(define results (call-with-values (lambda () (proc db)) list))
|
||||
(lambda () (apply values results))))
|
||||
(teardown db)
|
||||
(unless (connection? db-file)
|
||||
(disconnect db))))
|
||||
(disconnect db)))))))
|
||||
|
||||
(define (doc-db-key->path db-file key
|
||||
#:fail [fail #f]
|
||||
#:main-doc-relative-ok? [main-doc-relative-ok? #f])
|
||||
(call-with-database
|
||||
void
|
||||
db-file
|
||||
#:fail fail
|
||||
(lambda (db)
|
||||
(define row (query-maybe-row db select-pathid-vq
|
||||
(~s key)))
|
||||
(define pathid (and row
|
||||
(vector-ref row 0)))
|
||||
(and pathid
|
||||
(pathid->filename db pathid #f main-doc-relative-ok?)))))
|
||||
|
||||
|
||||
(define (doc-db-record-provides db-file provides filename)
|
||||
(define (add lock db-file elems filename callback)
|
||||
(call-with-database
|
||||
lock
|
||||
db-file
|
||||
(lambda (db)
|
||||
(prepare-tables db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
(for ([p (in-list elems)])
|
||||
(define stag (~s p))
|
||||
(callback db stag pathid)))))
|
||||
|
||||
(define (clear lock db-file filename statement)
|
||||
(call-with-database
|
||||
lock
|
||||
db-file
|
||||
(lambda (db)
|
||||
(prepare-tables db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
(query-exec db statement
|
||||
pathid))))
|
||||
|
||||
(define (doc-db-add-provides db-file provides filename
|
||||
#:lock [lock void])
|
||||
(add lock db-file provides filename
|
||||
(lambda (db stag pathid)
|
||||
(query-exec db "INSERT INTO documented VALUES ($1, $2)"
|
||||
stag
|
||||
pathid))))
|
||||
|
||||
|
||||
(define (doc-db-clear-provides db-file filename
|
||||
#:lock [lock void])
|
||||
(clear lock db-file filename
|
||||
"DELETE FROM documented WHERE pathid=$1"))
|
||||
|
||||
(define (doc-db-add-dependencies db-file depends filename
|
||||
#:lock [lock void])
|
||||
(add lock db-file depends filename
|
||||
(lambda (db stag pathid)
|
||||
(query-exec db "INSERT INTO dependencies VALUES ($1, $2)"
|
||||
pathid
|
||||
stag))))
|
||||
|
||||
|
||||
(define (doc-db-clear-dependencies db-file filename
|
||||
#:lock [lock void])
|
||||
(clear lock db-file filename
|
||||
"DELETE FROM dependencies WHERE pathid=$1"))
|
||||
|
||||
(define (doc-db-add-searches db-file searches filename
|
||||
#:lock [lock void])
|
||||
(call-with-database
|
||||
lock
|
||||
db-file
|
||||
(lambda (db)
|
||||
(prepare-tables db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
(for ([(sk s) (in-hash searches)]
|
||||
[setid (in-naturals)])
|
||||
(query-exec db "INSERT INTO searchSets VALUES ($1, $2, $3)"
|
||||
pathid
|
||||
setid
|
||||
(~s sk))
|
||||
(for ([k (in-hash-keys s)])
|
||||
(define stag (~s k))
|
||||
(query-exec db "INSERT INTO searches VALUES ($1, $2, $3)"
|
||||
pathid
|
||||
setid
|
||||
stag))))))
|
||||
|
||||
(define (doc-db-clear-searches db-file filename
|
||||
#:lock [lock void])
|
||||
(call-with-database
|
||||
lock
|
||||
db-file
|
||||
(lambda (db)
|
||||
(prepare-tables db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
(query-exec db "DELETE FROM searchSets WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "DELETE FROM searches WHERE pathid=$1"
|
||||
pathid))))
|
||||
|
||||
(define (maybe-attach attach-db-path)
|
||||
(lambda (db)
|
||||
(when attach-db-path
|
||||
(attach-db db attach-db-path))))
|
||||
(define (maybe-detach attach-db-path)
|
||||
(lambda (db)
|
||||
(when attach-db-path
|
||||
(detach-db db attach-db-path))))
|
||||
|
||||
(define (doc-db-check-duplicates db-file
|
||||
#:attach [attach-db-path #f]
|
||||
#:main-doc-relative-ok? [main-doc-relative-ok? #f])
|
||||
(call-with-database
|
||||
void
|
||||
db-file
|
||||
#:setup (maybe-attach attach-db-path)
|
||||
#:teardown (maybe-detach attach-db-path)
|
||||
(lambda (db)
|
||||
(define rows
|
||||
(append
|
||||
(query-rows db (~a "SELECT stag"
|
||||
" FROM documented"
|
||||
" GROUP BY stag"
|
||||
" HAVING COUNT(pathid) > 1"))
|
||||
(if attach-db-path
|
||||
;; duplicates across tables:
|
||||
(query-rows db (~a "SELECT D.stag"
|
||||
" FROM documented D, other.documented OD"
|
||||
" WHERE D.stag = OD.stag"
|
||||
" GROUP BY D.stag"))
|
||||
null)))
|
||||
(for/list ([row (in-list rows)])
|
||||
(define stag (vector-ref row 0))
|
||||
(define pathid-rows (query-rows db (~a "SELECT pathid"
|
||||
" FROM documented"
|
||||
" WHERE stag=$1")
|
||||
stag))
|
||||
(define other-pathid-rows
|
||||
(if attach-db-path
|
||||
(query-rows db (~a "SELECT pathid"
|
||||
" FROM other.documented"
|
||||
" WHERE stag=$1")
|
||||
stag)
|
||||
null))
|
||||
(cons (read (if (bytes? stag)
|
||||
(open-input-bytes stag)
|
||||
(open-input-string stag)))
|
||||
(append
|
||||
(for/list ([pathid-row (in-list pathid-rows)])
|
||||
(pathid->filename db (vector-ref pathid-row 0) #f main-doc-relative-ok?))
|
||||
(for/list ([pathid-row (in-list other-pathid-rows)])
|
||||
(pathid->filename db (vector-ref pathid-row 0) #t main-doc-relative-ok?))))))))
|
||||
|
||||
(define (doc-db-check-unsatisfied filename db-file
|
||||
#:attach [attach-db-path #f])
|
||||
(call-with-database
|
||||
void
|
||||
db-file
|
||||
#:setup (maybe-attach attach-db-path)
|
||||
#:teardown (maybe-detach attach-db-path)
|
||||
(lambda (db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
;; Items with no `searches' entries:
|
||||
(define rows
|
||||
(query-rows db (~a "SELECT P.stag "
|
||||
" FROM dependencies P"
|
||||
" LEFT OUTER JOIN documented D ON D.stag = P.stag"
|
||||
" LEFT OUTER JOIN searches S ON S.stag = P.stag"
|
||||
(if attach-db-path
|
||||
(~a " LEFT OUTER JOIN other.documented OD ON OD.stag = P.stag"
|
||||
" LEFT OUTER JOIN other.searches OS ON OS.stag = P.stag")
|
||||
"")
|
||||
" WHERE P.pathid = $1"
|
||||
" AND D.stag IS NULL"
|
||||
" AND S.stag is NULL"
|
||||
(if attach-db-path
|
||||
(~a " AND OD.stag IS NULL"
|
||||
" AND OS.stag is NULL")
|
||||
""))
|
||||
pathid))
|
||||
;; Items with `searches' entries, but no documentation:
|
||||
(define more-rows
|
||||
(query-rows db (~a "SELECT SS.stag "
|
||||
" FROM searchSets SS"
|
||||
" WHERE SS.pathid = $1"
|
||||
" AND NOT EXISTS"
|
||||
" (SELECT S.stag"
|
||||
" FROM documented D, searches S"
|
||||
" WHERE D.stag = S.stag"
|
||||
" AND S.setid = SS.setid"
|
||||
" AND S.pathid = SS.pathid)"
|
||||
(if attach-db-path
|
||||
(~a " AND NOT EXISTS"
|
||||
" (SELECT S.stag"
|
||||
" FROM other.documented OD, searches S"
|
||||
" WHERE OD.stag = S.stag"
|
||||
" AND S.setid = SS.setid"
|
||||
" AND S.pathid = SS.pathid)")
|
||||
"")
|
||||
" GROUP BY SS.stag")
|
||||
pathid))
|
||||
(map (lambda (s)
|
||||
(read (open-input-string (vector-ref s 0))))
|
||||
(append
|
||||
rows
|
||||
more-rows)))))
|
||||
|
||||
(define (attach-db db attach-db-path)
|
||||
(query-exec db "ATTACH $1 AS other"
|
||||
(path->bytes (cleanse-path
|
||||
(path->complete-path attach-db-path)))))
|
||||
(define (detach-db db attach-db-path)
|
||||
(query-exec db "DETACH other"))
|
||||
|
||||
|
||||
(define (doc-db-get-dependencies filename db-file
|
||||
#:attach [attach-db-path #f]
|
||||
#:main-doc-relative-ok? [main-doc-relative-ok? #f])
|
||||
(call-with-database
|
||||
void
|
||||
db-file
|
||||
#:setup (maybe-attach attach-db-path)
|
||||
#:teardown (maybe-detach attach-db-path)
|
||||
(lambda (db)
|
||||
(define pathid (filename->pathid db filename))
|
||||
(define ((rows->paths in-other?) rows)
|
||||
(for/list ([row (in-list rows)])
|
||||
(pathid->filename db (vector-ref row 0) in-other? main-doc-relative-ok?)))
|
||||
(append
|
||||
((rows->paths #f)
|
||||
(query-rows db (~a "SELECT D.pathid "
|
||||
" FROM dependencies P, documented D"
|
||||
" WHERE P.pathid = $1"
|
||||
" AND D.stag = P.stag"
|
||||
" GROUP BY D.pathid")
|
||||
pathid)))
|
||||
(if attach-db-path
|
||||
((rows->paths #t)
|
||||
(query-rows db (~a "SELECT D.pathid "
|
||||
" FROM dependencies P, other.documented D"
|
||||
" WHERE P.pathid = $1"
|
||||
" AND D.stag = P.stag"
|
||||
" GROUP BY D.pathid")
|
||||
pathid))
|
||||
null))))
|
||||
|
||||
(define (doc-db-clean-files db-file ok-files
|
||||
#:lock [lock void])
|
||||
(call-with-database
|
||||
lock
|
||||
db-file
|
||||
(lambda (db)
|
||||
(prepare-tables db)
|
||||
(define rows (query-rows db "SELECT atmain, path, pathid FROM pathids"))
|
||||
(for ([row (in-list rows)])
|
||||
(define bstr (vector-ref row 1))
|
||||
(define path (cond
|
||||
[(equal? "y" (vector-ref row 0))
|
||||
(main-doc-relative->path
|
||||
(cons 'doc (or (hash-ref reader-cache bstr #f)
|
||||
(let ([v (read (open-input-bytes bstr))])
|
||||
(hash-set! reader-cache bstr v)
|
||||
v))))]
|
||||
[(bytes? bstr)
|
||||
(bytes->path bstr)]
|
||||
[else ; "placeholder"
|
||||
#f]))
|
||||
(unless (or (not path)
|
||||
(hash-ref ok-files path #f))
|
||||
(define pathid (vector-ref row 2))
|
||||
(query-exec db "DELETE FROM documented WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "DELETE FROM searches WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "DELETE FROM searchSets WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "DELETE FROM dependencies WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "DELETE FROM pathids WHERE pathid=$1"
|
||||
pathid)
|
||||
(query-exec db "INSERT INTO pathids VALUES ($1, 'n', 'placeholder')"
|
||||
pathid))))))
|
||||
|
||||
|
||||
(define (filename->pathid db filename)
|
||||
(define filename* (path->main-doc-relative filename))
|
||||
(define filename-bytes (if (pair? filename*)
|
||||
(string->bytes/utf-8 (~s (cdr filename*)))
|
||||
(path->bytes filename*)))
|
||||
|
||||
(define db (sqlite3-connect #:database db-file #:mode 'create))
|
||||
|
||||
;; Make sure tables are present:
|
||||
(call-with-transaction/retry
|
||||
db
|
||||
(lambda ()
|
||||
(when (null?
|
||||
(query-rows db (~a "SELECT name FROM sqlite_master"
|
||||
" WHERE type='table' AND name='documented'")))
|
||||
(query-exec db (~a "CREATE TABLE documented "
|
||||
"(stag VARCHAR(256),"
|
||||
" pathid SMALLINT,"
|
||||
" PRIMARY KEY (stag))")))))
|
||||
(call-with-transaction/retry
|
||||
db
|
||||
(lambda ()
|
||||
(when (null?
|
||||
(query-rows db (~a "SELECT name FROM sqlite_master"
|
||||
" WHERE type='table' AND name='pathids'")))
|
||||
(query-exec db (~a "CREATE TABLE pathids "
|
||||
"(pathid SMALLINT,"
|
||||
" atmain CHAR(1),"
|
||||
" path VARCHAR(1024),"
|
||||
" PRIMARY KEY (pathid))")))))
|
||||
|
||||
(define pathid
|
||||
(call-with-transaction/retry
|
||||
db
|
||||
(lambda ()
|
||||
(define filename-bytes (cond
|
||||
[(pair? filename*)
|
||||
(string->bytes/utf-8 (~s (cdr filename*)))]
|
||||
[(path? filename*)
|
||||
(path->bytes filename*)]
|
||||
[else (path->bytes (string->path filename*))]))
|
||||
(define id (query-maybe-row db (~a "SELECT pathid FROM pathids"
|
||||
" WHERE atmain=$1 AND path=$2")
|
||||
(if (pair? filename*) "y" "n")
|
||||
|
|
@ -98,32 +379,134 @@
|
|||
(if (pair? filename*) "y" "n")
|
||||
filename-bytes)
|
||||
(add1 num)]
|
||||
[else (vector-ref id 0)]))))
|
||||
[else (vector-ref id 0)]))
|
||||
|
||||
(call-with-transaction/retry
|
||||
db
|
||||
(lambda ()
|
||||
(for ([p (in-list provides)])
|
||||
(define stag (~s p))
|
||||
(query-exec db "DELETE FROM documented WHERE stag=$1"
|
||||
stag)
|
||||
(query-exec db "INSERT INTO documented VALUES ($1, $2)"
|
||||
stag
|
||||
pathid))))
|
||||
(define reader-cache (make-weak-hash))
|
||||
|
||||
(disconnect db))
|
||||
(define (pathid->filename db pathid in-other? main-doc-relative-ok?)
|
||||
(define row (query-maybe-row db
|
||||
(if in-other?
|
||||
select-other-path-vq
|
||||
select-path-vq)
|
||||
pathid))
|
||||
(and row
|
||||
(let ([path (vector-ref row 1)])
|
||||
(if (equal? "y" (vector-ref row 0))
|
||||
((if main-doc-relative-ok? values main-doc-relative->path)
|
||||
(cons 'doc (or (hash-ref reader-cache path #f)
|
||||
(let ([v (read (open-input-bytes path))])
|
||||
(hash-set! reader-cache path v)
|
||||
v))))
|
||||
(bytes->path path)))))
|
||||
|
||||
(define (call-with-transaction/retry db thunk)
|
||||
(let loop ([tries 0])
|
||||
(with-handlers ([(lambda (v)
|
||||
(and (tries . < . 100)
|
||||
(exn:fail? v)
|
||||
(regexp-match #rx"the database file is locked"
|
||||
(define (prepare-tables db)
|
||||
(when (null?
|
||||
(query-rows db (~a "SELECT name FROM sqlite_master"
|
||||
" WHERE type='table' AND name='documented'")))
|
||||
(query-exec db (~a "CREATE TABLE documented "
|
||||
"(stag VARCHAR(256),"
|
||||
" pathid SMALLINT,"
|
||||
" UNIQUE (stag, pathid))"))
|
||||
(query-exec db (~a "CREATE INDEX documentedStags "
|
||||
"on documented (stag)"))
|
||||
(query-exec db (~a "CREATE TABLE dependencies "
|
||||
"(pathid SMALLINT,"
|
||||
" stag VARCHAR(256))"))
|
||||
(query-exec db (~a "CREATE TABLE searchSets "
|
||||
"(pathid SMALLINT, "
|
||||
" setid SMALLINT, "
|
||||
" stag VARCHAR(256),"
|
||||
" PRIMARY KEY (pathid, setid))"))
|
||||
(query-exec db (~a "CREATE TABLE searches "
|
||||
"(pathid SMALLINT,"
|
||||
" setid SMALLINT, "
|
||||
" stag VARCHAR(256))"))
|
||||
(query-exec db (~a "CREATE TABLE pathids "
|
||||
"(pathid SMALLINT,"
|
||||
" atmain CHAR(1),"
|
||||
" path VARCHAR(1024),"
|
||||
" PRIMARY KEY (pathid))"))
|
||||
(query-exec db (~a "CREATE INDEX dependenciesPath "
|
||||
"on dependencies (pathid)"))
|
||||
(query-exec db (~a "CREATE INDEX searchSetsPath "
|
||||
"on searchSets (pathid)"))
|
||||
(query-exec db (~a "CREATE INDEX searchesTag "
|
||||
"on searches (stag)"))
|
||||
(query-exec db (~a "CREATE INDEX searchesPathId "
|
||||
"on searches (pathid, setid)"))))
|
||||
|
||||
(define (exn:fail:database-locked? v)
|
||||
(and (exn:fail? v)
|
||||
(regexp-match #rx"the database file is locked$"
|
||||
(exn-message v))))
|
||||
|
||||
;; Call in a transation, and also with a lock if `lock'
|
||||
;; implements one. (Even though the database can
|
||||
;; handle locking, it deosn't handle contention all that
|
||||
;; well, so we offer the option of manual locking.)
|
||||
;; If `lock' implements a lock, it should expect arguments: 'lock or
|
||||
;; 'unlock, and a boolean to indicate wheter breaks should be enabled
|
||||
;; while waiting.
|
||||
;;
|
||||
;; Handle Sqlite-level lock failures, too. 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 lock db fast-abort thunk)
|
||||
(let ([old-break-paramz (current-break-parameterization)]
|
||||
[can-break? (break-enabled)])
|
||||
(parameterize-break
|
||||
#f
|
||||
(lock 'lock can-break?)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(call-with-break-parameterization
|
||||
old-break-paramz
|
||||
(lambda ()
|
||||
(let loop ([pause 0.01])
|
||||
(define (call-with-lock-handler handler thunk)
|
||||
(with-handlers* ([exn:fail:database-locked?
|
||||
(lambda (exn)
|
||||
;; Try again:
|
||||
(sleep)
|
||||
(loop (add1 tries)))])
|
||||
(call-with-transaction
|
||||
db
|
||||
thunk))))
|
||||
(log-doc-db-info "database locked; now waiting ~a seconds" pause)
|
||||
(handler (min 10 (* pause 2))))])
|
||||
(thunk)))
|
||||
((let/ec esc
|
||||
(define success? #f)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(sleep pause)
|
||||
(loop pause))))
|
||||
(lambda () (start-transaction db))))
|
||||
(lambda ()
|
||||
(call-with-lock-handler
|
||||
(lambda (pause) (esc (lambda ()
|
||||
(rollback db fast-abort 1)
|
||||
(sleep pause)
|
||||
(loop 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))))))))))
|
||||
(lambda () (lock 'unlock #f))))))
|
||||
|
||||
(define (rollback db fast-abort count)
|
||||
(when (in-transaction? db)
|
||||
(when fast-abort
|
||||
(log-doc-db-info "fast rollback 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))))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
racket/match
|
||||
racket/path
|
||||
racket/class
|
||||
racket/serialize
|
||||
racket/stxparam
|
||||
(for-syntax syntax/parse
|
||||
racket/base))
|
||||
|
|
@ -82,7 +81,7 @@
|
|||
(set! in _in)
|
||||
(set! err _err)
|
||||
(send/msg dynamic-require-cmd)
|
||||
(when initialmsg (send/msg (s-exp->fasl (serialize (initialmsg id)))))))
|
||||
(when initialmsg (send/msg (initialmsg id)))))
|
||||
(define/public (send/msg msg)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
|
|
@ -121,7 +120,7 @@
|
|||
(define/public (spawn _id module-path funcname [initialmsg #f])
|
||||
(set! id _id)
|
||||
(set! pl (dynamic-place (string->path module-path) funcname))
|
||||
(when initialmsg (send/msg (s-exp->fasl (serialize (initialmsg id))))))
|
||||
(when initialmsg (send/msg (initialmsg id))))
|
||||
(define/public (send/msg msg)
|
||||
(DEBUG_COMM (eprintf "CSENDING ~v ~v\n" pl msg))
|
||||
(place-channel-put pl msg))
|
||||
|
|
@ -409,7 +408,7 @@
|
|||
(DEBUG_COMM (fprintf orig-err "WRECVEIVED ~v\n" r))
|
||||
r))
|
||||
|
||||
(setup-proc (deserialize (fasl->s-exp (pdo-recv)))
|
||||
(setup-proc (pdo-recv)
|
||||
(lambda (set-proc)
|
||||
(let/ec die-k
|
||||
(define (recv/reqp) (pdo-recv))
|
||||
|
|
|
|||
|
|
@ -17,4 +17,6 @@
|
|||
[(memq 'user-doc flags) (user-doc name)]
|
||||
[(or under-main? (memq 'main-doc flags) (pair? (path->main-collects-relative dir)))
|
||||
(build-path (find-doc-dir) name)]
|
||||
[else (build-path dir "doc" name)]))
|
||||
[else
|
||||
(and (not (eq? 'never user-doc-mode))
|
||||
(build-path dir "doc" name))]))
|
||||
|
|
|
|||
|
|
@ -21,7 +21,10 @@
|
|||
scribble/html-properties
|
||||
scribble/manual ; really shouldn't be here... see dynamic-require-doc
|
||||
scribble/private/run-pdflatex
|
||||
setup/xref
|
||||
scribble/xref
|
||||
unstable/file
|
||||
racket/place
|
||||
(prefix-in html: scribble/html-render)
|
||||
(prefix-in latex: scribble/latex-render)
|
||||
(prefix-in contract: scribble/contract-render))
|
||||
|
|
@ -32,10 +35,11 @@
|
|||
|
||||
(define verbose (make-parameter #t))
|
||||
|
||||
(define-logger setup)
|
||||
|
||||
(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category out-count)
|
||||
#:transparent)
|
||||
(define-serializable-struct info (doc ; doc structure above
|
||||
providess ; list of list of provide
|
||||
undef ; unresolved requires
|
||||
searches
|
||||
deps
|
||||
|
|
@ -76,6 +80,10 @@
|
|||
make-user? ; are we making user stuff?
|
||||
with-record-error ; catch & record exceptions
|
||||
setup-printf)
|
||||
(unless (doc-db-available?)
|
||||
(error 'setup "install SQLite to build documentation"))
|
||||
(when latex-dest
|
||||
(log-setup-info "latex working directory: ~a" latex-dest))
|
||||
(define (scribblings-flag? sym)
|
||||
(memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
|
||||
depends-all depends-all-main no-depend-on always-run)))
|
||||
|
|
@ -131,6 +139,7 @@
|
|||
"WARNING"
|
||||
"bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir)
|
||||
null))))
|
||||
(log-setup-info "getting documents")
|
||||
(define docs
|
||||
(let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
|
||||
[main-dirs (parameterize ([current-library-collection-paths
|
||||
|
|
@ -143,17 +152,35 @@
|
|||
(define (can-build*? docs) (can-build? only-dirs docs))
|
||||
(define auto-main? (and auto-start-doc? (ormap can-build*? main-docs)))
|
||||
(define auto-user? (and auto-start-doc? (ormap can-build*? user-docs)))
|
||||
(define force-out-of-date? (not (file-exists? (find-doc-db-path latex-dest #f))))
|
||||
(log-setup-info "getting document information")
|
||||
(define infos
|
||||
(and (ormap can-build*? docs)
|
||||
(filter values
|
||||
(if (not (worker-count . > . 1))
|
||||
(filter
|
||||
values
|
||||
(if ((min worker-count (length docs)) . < . 2)
|
||||
;; non-parallel version:
|
||||
(map (get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf #f)
|
||||
with-record-error setup-printf #f
|
||||
force-out-of-date? force-out-of-date?)
|
||||
docs)
|
||||
;; maybe parallel...
|
||||
(or
|
||||
(let ([infos (map (get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf #f
|
||||
;; only-fast:
|
||||
#t
|
||||
force-out-of-date?)
|
||||
docs)])
|
||||
;; check fast result
|
||||
(and (andmap values infos)
|
||||
infos))
|
||||
;; parallel:
|
||||
(parallel-do
|
||||
worker-count
|
||||
(min worker-count (length docs))
|
||||
(lambda (workerid)
|
||||
(list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?))
|
||||
(list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?))
|
||||
(list-queue
|
||||
docs
|
||||
(lambda (x workerid) (s-exp->fasl (serialize x)))
|
||||
|
|
@ -164,8 +191,10 @@
|
|||
(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?)
|
||||
(define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user? send/report)
|
||||
auto-main? auto-user? force-out-of-date?)
|
||||
(define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?
|
||||
send/report)
|
||||
doc)
|
||||
(define (setup-printf subpart formatstr . rest)
|
||||
(let ([task (if subpart
|
||||
|
|
@ -181,30 +210,71 @@
|
|||
(go)))
|
||||
(s-exp->fasl (serialize
|
||||
((get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf workerid)
|
||||
with-record-error setup-printf workerid
|
||||
#f force-out-of-date?)
|
||||
(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? send/report)
|
||||
doc))])))))))
|
||||
((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
|
||||
force-out-of-date?
|
||||
send/report)
|
||||
doc))]))))))))
|
||||
|
||||
(define (out-path->info path infos out-path->info-cache)
|
||||
(or (hash-ref out-path->info-cache path #f)
|
||||
(let ([filename (main-doc-relative->path path)])
|
||||
(for*/or ([i (in-list infos)]
|
||||
[c (in-range (add1 (doc-out-count (info-doc i))))])
|
||||
(and (equal? (sxref-path latex-dest (info-doc i) (format "out~a.sxref" c))
|
||||
filename)
|
||||
(hash-set! out-path->info-cache path i)
|
||||
i)))))
|
||||
|
||||
(define (make-loop first? iter)
|
||||
(let ([ht (make-hash)]
|
||||
[infos (filter-not info-failed? infos)]
|
||||
[src->info (make-hash)])
|
||||
;; Collect definitions
|
||||
(for* ([info infos]
|
||||
[ks (info-providess info)]
|
||||
[k ks])
|
||||
(let ([prev (hash-ref ht k #f)])
|
||||
(when (and first? prev)
|
||||
(let ([infos (filter-not info-failed? infos)]
|
||||
[src->info (make-hash)]
|
||||
[out-path->info-cache (make-hash)]
|
||||
[main-db (find-doc-db-path latex-dest #f)]
|
||||
[user-db (find-doc-db-path latex-dest #t)])
|
||||
(unless only-dirs
|
||||
(log-setup-info "cleaning database")
|
||||
(define files (make-hash))
|
||||
(define (get-files! main?)
|
||||
(for ([i (in-list infos)]
|
||||
#:when (eq? main? (main-doc? (info-doc i))))
|
||||
(define doc (info-doc i))
|
||||
(hash-set! files (sxref-path latex-dest doc "in.sxref") #t)
|
||||
(for ([c (in-range (add1 (doc-out-count doc)))])
|
||||
(hash-set! files (sxref-path latex-dest doc (format "out~a.sxref" c)) #t))))
|
||||
(get-files! #t)
|
||||
(doc-db-clean-files main-db files)
|
||||
(when (and (file-exists? user-db)
|
||||
(not (equal? main-db user-db)))
|
||||
(get-files! #f)
|
||||
(doc-db-clean-files user-db files)))
|
||||
;; Check for duplicate definitions
|
||||
(when first?
|
||||
(log-setup-info "checking for duplicates")
|
||||
(let ([dups (append
|
||||
(doc-db-check-duplicates main-db #:main-doc-relative-ok? #t)
|
||||
(if (and make-user?
|
||||
(file-exists? user-db)
|
||||
(not (equal? main-db user-db)))
|
||||
(doc-db-check-duplicates user-db #:attach main-db #:main-doc-relative-ok? #t)
|
||||
null))])
|
||||
(for ([dup dups])
|
||||
(let ([k (car dup)]
|
||||
[paths (cdr dup)])
|
||||
(setup-printf "WARNING" "duplicate tag: ~s" k)
|
||||
(setup-printf #f " in: ~a" (doc-src-file (info-doc prev)))
|
||||
(setup-printf #f " and: ~a" (doc-src-file (info-doc info))))
|
||||
(hash-set! ht k info)))
|
||||
(for ([path paths])
|
||||
(define i (out-path->info path infos out-path->info-cache))
|
||||
(setup-printf #f " in: ~a" (if i
|
||||
(doc-src-file (info-doc i))
|
||||
"<unknown>")))))))
|
||||
;; Build deps:
|
||||
(log-setup-info "determining dependencies")
|
||||
(for ([i infos])
|
||||
(hash-set! src->info (doc-src-file (info-doc i)) i))
|
||||
(for ([info infos] #:when (info-build? info))
|
||||
|
|
@ -251,7 +321,7 @@
|
|||
(not (memq 'no-depend-on (doc-flags (info-doc i)))))
|
||||
(set! added? #t)
|
||||
(hash-set! deps i #t))))
|
||||
;; Add defeinite dependencies based on referenced keys
|
||||
;; Add definite dependencies based on referenced keys
|
||||
(let ([not-found
|
||||
(lambda (k)
|
||||
(unless (or (memq 'depends-all (doc-flags (info-doc info)))
|
||||
|
|
@ -263,11 +333,21 @@
|
|||
(doc-src-file (info-doc info))))
|
||||
(set! one? #t))
|
||||
(setup-printf #f " ~s" k)))])
|
||||
(for ([k (info-undef info)])
|
||||
(let ([i (hash-ref ht k #f)])
|
||||
(if i
|
||||
(begin
|
||||
(let* ([filename (sxref-path latex-dest (info-doc info) "in.sxref")]
|
||||
[as-user? (and (not (main-doc? (info-doc info)))
|
||||
(not (equal? main-db user-db)))]
|
||||
[found-deps (doc-db-get-dependencies filename
|
||||
(if as-user? user-db main-db)
|
||||
#:attach (if as-user? main-db #f)
|
||||
#:main-doc-relative-ok? #t)]
|
||||
[missing (if first?
|
||||
(doc-db-check-unsatisfied filename
|
||||
(if as-user? user-db main-db)
|
||||
#:attach (if as-user? main-db #f))
|
||||
null)])
|
||||
(for ([found-dep (in-list found-deps)])
|
||||
;; Record a definite dependency:
|
||||
(define i (out-path->info found-dep infos out-path->info-cache))
|
||||
(when (not (hash-ref known-deps i #f))
|
||||
(hash-set! known-deps i #t))
|
||||
;; Record also in the expected-dependency list:
|
||||
|
|
@ -277,16 +357,8 @@
|
|||
(printf " [Adding... ~a]\n"
|
||||
(doc-src-file (info-doc i))))
|
||||
(hash-set! deps i #t)))
|
||||
(when first?
|
||||
;; FIXME: instead of special-casing 'dep, we should
|
||||
;; skip any key that is covered by `(info-searches info)'.
|
||||
(unless (eq? (car k) 'dep)
|
||||
(not-found k))))))
|
||||
(when first?
|
||||
(for ([(s-key s-ht) (info-searches info)])
|
||||
(unless (ormap (lambda (k) (hash-ref ht k #f))
|
||||
(hash-map s-ht (lambda (k v) k)))
|
||||
(not-found s-key)))))
|
||||
(for ([s-key (in-list missing)])
|
||||
(not-found s-key))))
|
||||
;; If we added anything (expected or known), then mark as needed to run
|
||||
(when added?
|
||||
(when (verbose)
|
||||
|
|
@ -314,6 +386,7 @@
|
|||
(set-info-need-run?! i #t))))
|
||||
;; Iterate, if any need to run:
|
||||
(when (and (ormap info-need-run? infos) (iter . < . 30))
|
||||
(log-setup-info "building")
|
||||
;; Build again, using dependencies
|
||||
(let ([need-rerun (filter-map (lambda (i)
|
||||
(and (info-need-run? i)
|
||||
|
|
@ -334,10 +407,10 @@
|
|||
(define (update-info info response)
|
||||
(match response
|
||||
[#f (set-info-failed?! info #t)]
|
||||
[(list in-delta? out-delta? defss undef)
|
||||
[(list in-delta? out-delta? undef searches)
|
||||
(set-info-rendered?! info #t)
|
||||
(set-info-providess! info defss)
|
||||
(set-info-undef! info undef)
|
||||
(set-info-searches! info searches)
|
||||
(when out-delta?
|
||||
(set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
|
||||
(when in-delta?
|
||||
|
|
@ -345,13 +418,15 @@
|
|||
(set-info-deps! info (info-known-deps info))
|
||||
(set-info-need-in-write?! info #t))
|
||||
(set-info-time! info (/ (current-inexact-milliseconds) 1000))]))
|
||||
(if (not (worker-count . > . 1))
|
||||
(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))) need-rerun)
|
||||
(update-info i (build-again! latex-dest i with-record-error)))
|
||||
need-rerun)
|
||||
(parallel-do
|
||||
worker-count
|
||||
(lambda (workerid) (list workerid (verbose) latex-dest))
|
||||
(min worker-count (length need-rerun))
|
||||
(lambda (workerid)
|
||||
(list workerid (verbose) latex-dest))
|
||||
(list-queue
|
||||
need-rerun
|
||||
(lambda (i workerid)
|
||||
|
|
@ -374,7 +449,9 @@
|
|||
(match-message-loop
|
||||
[info
|
||||
(send/success
|
||||
(s-exp->fasl (serialize (build-again! latex-dest (deserialize (fasl->s-exp info)) with-record-error))))])))))
|
||||
(s-exp->fasl (serialize (build-again! latex-dest
|
||||
(deserialize (fasl->s-exp info))
|
||||
with-record-error))))])))))
|
||||
;; 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
|
||||
|
|
@ -450,6 +527,13 @@
|
|||
(build-path latex-dest (path-replace-suffix name (string-append "." file))))]
|
||||
[(not latex-dest) (build-path (doc-dest-dir doc) file)]))
|
||||
|
||||
(define (find-doc-db-path latex-dest user?)
|
||||
(cond
|
||||
[latex-dest
|
||||
(build-path latex-dest "docindex.sqlite")]
|
||||
[else
|
||||
(build-path (if user? (find-user-doc-dir) (find-doc-dir)) "docindex.sqlite")]))
|
||||
|
||||
(define (can-build? only-dirs doc)
|
||||
(or (not only-dirs)
|
||||
(ormap (lambda (d)
|
||||
|
|
@ -506,8 +590,11 @@
|
|||
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
||||
ht))
|
||||
|
||||
(define (load-sxref filename)
|
||||
(call-with-input-file filename (lambda (x) (fasl->s-exp x))))
|
||||
(define (load-sxref filename #:skip [skip 0])
|
||||
(call-with-input-file* filename
|
||||
(lambda (x)
|
||||
(for ([i skip]) (fasl->s-exp x))
|
||||
(fasl->s-exp x))))
|
||||
|
||||
(define (file-or-directory-modify-seconds/stamp file
|
||||
stamp-time stamp-data pos
|
||||
|
|
@ -518,19 +605,21 @@
|
|||
[(equal? (list-ref stamp-data pos) (get-sha1 file)) stamp-time]
|
||||
[else t])))
|
||||
|
||||
(define (find-db-file doc)
|
||||
(build-path (if (main-doc? doc)
|
||||
(find-doc-dir)
|
||||
(find-user-doc-dir))
|
||||
"docindex.sqlite"))
|
||||
(define (find-db-file doc latex-dest)
|
||||
(define p (find-doc-db-path latex-dest (not (main-doc? doc))))
|
||||
(define-values (base name dir?) (split-path p))
|
||||
(unless (directory-exists? base)
|
||||
(make-directory* base))
|
||||
p)
|
||||
|
||||
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error setup-printf workerid)
|
||||
with-record-error setup-printf workerid
|
||||
only-fast? force-out-of-date?)
|
||||
doc)
|
||||
(let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
|
||||
(sxref-path latex-dest doc (format "out~a.sxref" i)))]
|
||||
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
||||
[db-file (find-db-file doc)]
|
||||
[db-file (find-db-file doc latex-dest)]
|
||||
[stamp-file (sxref-path latex-dest doc "stamp.sxref")]
|
||||
[out-file (build-path (doc-dest-dir doc) "index.html")]
|
||||
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
||||
|
|
@ -574,7 +663,8 @@
|
|||
stamp-time stamp-data 0
|
||||
get-compiled-file-sha1)]
|
||||
[up-to-date?
|
||||
(and info-out-time
|
||||
(and (not force-out-of-date?)
|
||||
info-out-time
|
||||
info-in-time
|
||||
(or (not can-run?)
|
||||
;; Need to rebuild if output file is older than input:
|
||||
|
|
@ -590,14 +680,25 @@
|
|||
(memq 'depends-all-main (doc-flags doc)))
|
||||
(and auto-user?
|
||||
(memq 'depends-all (doc-flags doc)))))])
|
||||
(when (or (not up-to-date?) (verbose))
|
||||
(when (or (and (not up-to-date?) (not only-fast?))
|
||||
(verbose))
|
||||
(setup-printf
|
||||
(string-append
|
||||
(if workerid (format "~a " workerid) "")
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"]))
|
||||
(cond
|
||||
[up-to-date? "using"]
|
||||
[can-run? (if only-fast?
|
||||
"checking"
|
||||
"running")]
|
||||
[else "skipping"]))
|
||||
"~a"
|
||||
(path->relative-string/setup (doc-src-file doc))))
|
||||
|
||||
(when force-out-of-date?
|
||||
(for ([p (in-list info-out-files)])
|
||||
(when (file-exists? p)
|
||||
(delete-file p))))
|
||||
|
||||
(if up-to-date?
|
||||
;; Load previously calculated info:
|
||||
(render-time
|
||||
|
|
@ -609,30 +710,16 @@
|
|||
(delete-file info-in-file)
|
||||
((get-doc-info only-dirs latex-dest auto-main?
|
||||
auto-user? with-record-error
|
||||
setup-printf workerid)
|
||||
setup-printf workerid #f #f)
|
||||
doc))])
|
||||
(let* ([v-in (load-sxref info-in-file)]
|
||||
[v-outs (map load-sxref info-out-files)])
|
||||
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
||||
(for/and ([v-out v-outs])
|
||||
(equal? (car v-out) (list vers (doc-flags doc)))))
|
||||
(let ([v-in (load-sxref info-in-file)])
|
||||
(unless (equal? (car v-in) (list vers (doc-flags doc)))
|
||||
(error "old info has wrong version or flags"))
|
||||
(make-info
|
||||
doc
|
||||
(for/list ([v-out v-outs]) ; providess
|
||||
(let ([v (list-ref v-out 2)])
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v)))))
|
||||
(let ([v (list-ref v-in 1)]) ; undef
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(let ([v (list-ref v-in 3)]) ; searches
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))
|
||||
(map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
|
||||
'delayed
|
||||
'delayed
|
||||
(map rel->path (list-ref v-in 1)) ; expected deps, in case we don't need to build...
|
||||
null ; known deps (none at this point)
|
||||
can-run?
|
||||
my-time info-out-time
|
||||
|
|
@ -642,7 +729,8 @@
|
|||
vers
|
||||
#f
|
||||
#f))))
|
||||
(if can-run?
|
||||
(if (and can-run?
|
||||
(not only-fast?))
|
||||
;; Run the doc once:
|
||||
(with-record-error
|
||||
(doc-src-file doc)
|
||||
|
|
@ -666,23 +754,20 @@
|
|||
[undef (send renderer get-external ri)]
|
||||
[searches (resolve-info-searches ri)]
|
||||
[need-out-write?
|
||||
(or (not out-vs)
|
||||
(or force-out-of-date?
|
||||
(not out-vs)
|
||||
(not (for/and ([out-v out-vs])
|
||||
(equal? (list vers (doc-flags doc))
|
||||
(car out-v))))
|
||||
(not (for/and ([sci scis]
|
||||
[out-v out-vs])
|
||||
(serialized=? sci (cadr out-v))))
|
||||
(not (for/and ([defs defss]
|
||||
[out-v out-vs])
|
||||
(equal? (any-order defs) (any-order (deserialize (caddr out-v))))))
|
||||
(info-out-time . > . (current-seconds)))])
|
||||
(when (and (verbose) need-out-write?)
|
||||
(eprintf " [New out ~a]\n" (doc-src-file doc)))
|
||||
(gc-point)
|
||||
(let ([info
|
||||
(make-info doc
|
||||
defss ; providess
|
||||
undef
|
||||
searches
|
||||
null ; no deps, yet
|
||||
|
|
@ -699,7 +784,7 @@
|
|||
#f
|
||||
#f)])
|
||||
(when need-out-write?
|
||||
(render-time "xref-out" (write-out/info latex-dest info scis db-file))
|
||||
(render-time "xref-out" (write-out/info latex-dest info scis defss db-file))
|
||||
(set-info-need-out-write?! info #f))
|
||||
(when (info-need-in-write? info)
|
||||
(render-time "xref-in" (write-in/info latex-dest info))
|
||||
|
|
@ -718,6 +803,24 @@
|
|||
(lambda () #f))
|
||||
#f))))
|
||||
|
||||
(define (read-delayed-in! info latex-dest)
|
||||
(let* ([doc (info-doc info)]
|
||||
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
||||
[v-in (load-sxref info-in-file #:skip 1)])
|
||||
(if (and (equal? (car v-in) (list (info-vers info) (doc-flags doc))))
|
||||
;; version is ok:
|
||||
(let ([undef+searches
|
||||
(let ([v (list-ref v-in 1)])
|
||||
(with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize v))))])
|
||||
(set-info-undef! info (car undef+searches))
|
||||
(set-info-searches! info (cadr undef+searches)))
|
||||
;; version was bad:
|
||||
(begin
|
||||
(set-info-undef! info null)
|
||||
(set-info-searches! info #hash())))))
|
||||
|
||||
(define (make-prod-thread)
|
||||
;; periodically dumps a stack trace, which can give us some idea of
|
||||
;; what the main thread is doing; usually used in `render-time'.
|
||||
|
|
@ -732,36 +835,41 @@
|
|||
(loop))))))
|
||||
|
||||
(define-syntax-rule (render-time what expr)
|
||||
expr
|
||||
#;
|
||||
(begin
|
||||
(printf "For ~a\n" what)
|
||||
(time expr))
|
||||
#;
|
||||
(begin
|
||||
(collect-garbage) (collect-garbage) (printf "pre: ~a ~s\n" what (current-memory-use))
|
||||
(do-render-time
|
||||
what
|
||||
(lambda () expr)))
|
||||
|
||||
(define (do-render-time what thunk)
|
||||
(define start (current-process-milliseconds))
|
||||
(begin0
|
||||
(time expr)
|
||||
(collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use)))))
|
||||
(thunk)
|
||||
(let ([end (current-process-milliseconds)])
|
||||
(log-setup-debug "~a: ~a msec" what (- end start)))))
|
||||
|
||||
(define (load-sxrefs latex-dest doc vers)
|
||||
(match (list (load-sxref (sxref-path latex-dest doc "in.sxref"))
|
||||
(define in-filename (sxref-path latex-dest doc "in.sxref"))
|
||||
(match (list (load-sxref in-filename)
|
||||
(load-sxref in-filename #:skip 1)
|
||||
(for/list ([i (add1 (doc-out-count doc))])
|
||||
(load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i)))))
|
||||
[(list (list in-version undef deps-rel searches dep-docs)
|
||||
(list (list out-versions scis providess) ...))
|
||||
[(list (list in-version deps-rel)
|
||||
(list in-version2 undef+searches)
|
||||
(list (list out-versions scis) ...))
|
||||
(define expected (list vers (doc-flags doc)))
|
||||
(unless (and (equal? in-version expected)
|
||||
(equal? in-version2 expected)
|
||||
(for/and ([out-version out-versions])
|
||||
(equal? out-version expected)))
|
||||
(error "old info has wrong version or flags"))
|
||||
(match (with-my-namespace
|
||||
(lambda ()
|
||||
(deserialize undef+searches)))
|
||||
[(list undef searches)
|
||||
(with-my-namespace*
|
||||
(values (deserialize undef)
|
||||
(values undef
|
||||
deps-rel
|
||||
(deserialize searches)
|
||||
(map rel-doc->doc (deserialize dep-docs))
|
||||
scis
|
||||
(map deserialize providess)))]))
|
||||
searches
|
||||
scis))])]))
|
||||
|
||||
(define (build-again! latex-dest info with-record-error)
|
||||
(define (cleanup-dest-dir doc)
|
||||
|
|
@ -784,14 +892,15 @@
|
|||
(doc-src-file doc)
|
||||
(lambda ()
|
||||
(define vers (send renderer get-serialize-version))
|
||||
(define-values (ff-undef ff-deps-rel ff-searches ff-dep-docs ff-scis ff-providess)
|
||||
(define-values (ff-undef ff-deps-rel ff-searches ff-scis)
|
||||
(if (info? info)
|
||||
(begin
|
||||
(when (eq? 'delayed (info-undef info))
|
||||
(read-delayed-in! info latex-dest))
|
||||
(values (info-undef info)
|
||||
(info-deps->rel-doc-src-file info)
|
||||
(info-searches info)
|
||||
(info-deps->doc info)
|
||||
(load-doc-scis doc)
|
||||
(info-providess info))
|
||||
(load-doc-scis doc)))
|
||||
(load-sxrefs latex-dest doc vers)))
|
||||
|
||||
(parameterize ([current-directory (doc-src-dir doc)])
|
||||
|
|
@ -800,23 +909,21 @@
|
|||
[fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))]
|
||||
[ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))]
|
||||
[ri (begin
|
||||
(render-time "deserialize"
|
||||
(with-my-namespace*
|
||||
(for* ([dep-doc ff-dep-docs]
|
||||
[sci (load-doc-scis dep-doc)])
|
||||
(send renderer deserialize-info sci ci))))
|
||||
(xref-transfer-info renderer ci (make-collections-xref
|
||||
#:no-user? (main-doc? doc)
|
||||
#:doc-db (and latex-dest
|
||||
(find-doc-db-path latex-dest #t))))
|
||||
(render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))]
|
||||
[scis (render-time "serialize" (send renderer serialize-infos ri (add1 (doc-out-count doc)) v))]
|
||||
[defss (render-time "defined" (send renderer get-defineds ci (add1 (doc-out-count doc)) v))]
|
||||
[undef (render-time "undefined" (send renderer get-external ri))]
|
||||
[in-delta? (not (equal? (any-order undef) (any-order ff-undef)))]
|
||||
[out-delta? (or (not (for/and ([sci scis]
|
||||
[searches (render-time "searches" (resolve-info-searches ri))]
|
||||
[in-delta? (not (and (equal? (any-order undef) (any-order ff-undef))
|
||||
(equal? searches ff-searches)))]
|
||||
[out-delta? (not (for/and ([sci scis]
|
||||
[ff-sci ff-scis])
|
||||
(serialized=? sci ff-sci)))
|
||||
(not (for/and ([defs defss]
|
||||
[ff-provides ff-providess])
|
||||
(equal? (any-order defs) (any-order ff-provides)))))]
|
||||
[db-file (find-db-file doc)])
|
||||
(serialized=? sci ff-sci)))]
|
||||
[db-file (find-db-file doc latex-dest)])
|
||||
(when (verbose)
|
||||
(printf " [~a~afor ~a]\n"
|
||||
(if in-delta? "New in " "")
|
||||
|
|
@ -826,7 +933,7 @@
|
|||
(doc-src-file doc)))
|
||||
|
||||
(when in-delta?
|
||||
(render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel ff-searches ff-dep-docs)))
|
||||
(render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel searches db-file)))
|
||||
(when out-delta?
|
||||
(render-time "xref-out" (write-out latex-dest vers doc scis defss db-file)))
|
||||
|
||||
|
|
@ -838,7 +945,7 @@
|
|||
(lambda () (send renderer render (list v) (list dest-dir) ri))
|
||||
void))
|
||||
(gc-point)
|
||||
(list in-delta? out-delta? defss undef))))
|
||||
(list in-delta? out-delta? undef searches))))
|
||||
(lambda () #f)))
|
||||
|
||||
(define (gc-point)
|
||||
|
|
@ -873,52 +980,53 @@
|
|||
(parameterize ([current-namespace p])
|
||||
(call-in-nested-thread (lambda () (dynamic-require mod-path 'doc)))))))
|
||||
|
||||
(define (write- latex-dest vers doc name data prep!)
|
||||
(define (write- latex-dest vers doc name datas prep!)
|
||||
(let* ([filename (sxref-path latex-dest doc name)])
|
||||
(prep! filename)
|
||||
(when (verbose) (printf " [Caching to disk ~a]\n" filename))
|
||||
(make-directory*/ignore-exists-exn (doc-dest-dir doc))
|
||||
(with-compile-output filename
|
||||
(with-compile-output
|
||||
filename
|
||||
(lambda (out tmp-filename)
|
||||
(write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out)))))
|
||||
(for ([data (in-list datas)])
|
||||
(write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc)))
|
||||
data))
|
||||
out))))))
|
||||
|
||||
(define (write-out latex-dest vers doc scis providess db-file)
|
||||
(for ([i (add1 (doc-out-count doc))]
|
||||
[sci scis]
|
||||
[provides providess])
|
||||
(write- latex-dest vers doc (format "out~a.sxref" i)
|
||||
(list sci
|
||||
(serialize provides))
|
||||
(list (list sci))
|
||||
(lambda (filename)
|
||||
(unless latex-dest
|
||||
(doc-db-record-provides db-file provides filename))))))
|
||||
(doc-db-clear-provides db-file filename)
|
||||
(doc-db-add-provides db-file provides filename)))))
|
||||
|
||||
(define (write-out/info latex-dest info scis db-file)
|
||||
(write-out latex-dest (info-vers info) (info-doc info) scis (info-providess info) db-file))
|
||||
(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-in latex-dest vers doc undef rels searches dep-docs)
|
||||
(define (write-in latex-dest vers doc undef rels searches db-file)
|
||||
(write- latex-dest vers doc "in.sxref"
|
||||
(list (serialize undef)
|
||||
rels
|
||||
(serialize searches)
|
||||
;; The following last element is used only by the parallel build.
|
||||
;; It's redundant in the sense that the same information
|
||||
;; is in `rels' --- the docs that this one depends on ---
|
||||
;; but putting the whole `doc' record here makes it easier
|
||||
;; for a place to reconstruct a suitable `doc' record.
|
||||
;; It probably would be better to reconstruct the `doc'
|
||||
;; record in a place from the path.
|
||||
(serialize (map doc->rel-doc dep-docs)))
|
||||
void))
|
||||
(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))))
|
||||
|
||||
(define (write-in/info latex-dest info)
|
||||
(when (eq? 'delayed (info-undef info))
|
||||
(read-delayed-in! info latex-dest))
|
||||
(write-in latex-dest
|
||||
(info-vers info)
|
||||
(info-doc info)
|
||||
(info-undef info)
|
||||
(info-deps->rel-doc-src-file info)
|
||||
(info-searches info)
|
||||
(info-deps->doc info)))
|
||||
(find-db-file (info-doc info) latex-dest)))
|
||||
|
||||
(define (rel->path r)
|
||||
(if (bytes? r)
|
||||
|
|
|
|||
|
|
@ -998,9 +998,7 @@
|
|||
(set-doc:verbose)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(setup-printf #f "docs failure: ~a" (exn->string exn))
|
||||
(for ([x (in-list (continuation-mark-set->context (exn-continuation-marks exn)))])
|
||||
(setup-printf #f "~s" x)))])
|
||||
(setup-printf #f "docs failure: ~a" (exn->string exn)))])
|
||||
(define auto-start-doc?
|
||||
(and (not (null? (archives)))
|
||||
(archive-implies-reindex)))
|
||||
|
|
|
|||
|
|
@ -9,11 +9,12 @@
|
|||
"private/path-utils.rkt"
|
||||
"doc-db.rkt")
|
||||
|
||||
(provide load-collections-xref)
|
||||
(provide load-collections-xref
|
||||
make-collections-xref)
|
||||
|
||||
(define cached-xref #f)
|
||||
|
||||
(define (get-dests)
|
||||
(define (get-dests no-user?)
|
||||
(define main-dirs
|
||||
(parameterize ([current-library-collection-paths
|
||||
(let ([d (find-collects-dir)])
|
||||
|
|
@ -40,7 +41,8 @@
|
|||
(list-ref d 4)
|
||||
1)])
|
||||
(if (not (and (len . >= . 3) (memq 'omit (caddr d))))
|
||||
(let ([d (doc-path dir name flags (hash-ref main-dirs dir #f) 'false-if-missing)])
|
||||
(let ([d (doc-path dir name flags (hash-ref main-dirs dir #f)
|
||||
(if no-user? 'never 'false-if-missing))])
|
||||
(if d
|
||||
(for*/list ([i (in-range (add1 out-count))]
|
||||
[p (in-value (build-path d (format "out~a.sxref" i)))]
|
||||
|
|
@ -49,44 +51,81 @@
|
|||
null))
|
||||
null)))))
|
||||
|
||||
(define (dest->source dest)
|
||||
(define ((dest->source done-ht) dest)
|
||||
(if (hash-ref done-ht dest #f)
|
||||
(lambda () #f)
|
||||
(lambda ()
|
||||
(hash-set! done-ht dest #t)
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(log-error
|
||||
(log-warning
|
||||
"warning: ~a"
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "~e" exn)))
|
||||
#f)])
|
||||
(cadr (call-with-input-file* dest fasl->s-exp)))))
|
||||
(cadr (call-with-input-file* dest fasl->s-exp))))))
|
||||
|
||||
(define (dir->connection dir)
|
||||
(define p (build-path dir "docindex.sqlite"))
|
||||
(and (file-exists? p)
|
||||
(doc-db-file->connection p)))
|
||||
|
||||
(define main-db (delay (dir->connection (find-doc-dir))))
|
||||
(define user-db (delay (dir->connection (find-user-doc-dir))))
|
||||
|
||||
(define (key->source key)
|
||||
(define (make-key->source db-path no-user?)
|
||||
(define main-db (cons (or db-path
|
||||
(build-path (find-doc-dir) "docindex.sqlite"))
|
||||
;; cache for a connection:
|
||||
(box #f)))
|
||||
(define user-db (and (not no-user?)
|
||||
(cons (build-path (find-user-doc-dir) "docindex.sqlite")
|
||||
;; cache for a connection:
|
||||
(box #f))))
|
||||
(define done-ht (make-hash)) ; tracks already-loaded documents
|
||||
(lambda (key)
|
||||
(cond
|
||||
[key
|
||||
(define (try p)
|
||||
(and p
|
||||
(doc-db-key->path p key)))
|
||||
(define dest (or (try (force main-db))
|
||||
(try (force user-db))))
|
||||
(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
|
||||
(doc-db-file->connection (car p)))])
|
||||
((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 () (try p))))))
|
||||
;; 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 dest)))
|
||||
((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))))])))
|
||||
|
||||
(define (get-reader-thunks)
|
||||
(map dest->source
|
||||
(filter values (get-dests))))
|
||||
(define (get-reader-thunks no-user? done-ht)
|
||||
(map (dest->source done-ht)
|
||||
(filter values (get-dests no-user?))))
|
||||
|
||||
(define (load-collections-xref [report-loading void])
|
||||
(or cached-xref
|
||||
(begin (report-loading)
|
||||
(set! cached-xref
|
||||
(make-collections-xref))
|
||||
cached-xref)))
|
||||
|
||||
(define (make-collections-xref #:no-user? [no-user? #f]
|
||||
#:doc-db [db-path #f])
|
||||
(if (doc-db-available?)
|
||||
(load-xref null
|
||||
#:demand-source key->source)
|
||||
(load-xref (get-reader-thunks))))
|
||||
cached-xref)))
|
||||
#:demand-source (make-key->source db-path no-user?))
|
||||
(load-xref (get-reader-thunks no-user? (make-hash)))))
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.3.1.8"
|
||||
#define MZSCHEME_VERSION "5.3.1.9"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 3
|
||||
#define MZSCHEME_VERSION_Z 1
|
||||
#define MZSCHEME_VERSION_W 8
|
||||
#define MZSCHEME_VERSION_W 9
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user