suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: move doc dependency and duplicate checking to database

Browse Source 
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 2012-11-21 16:15:17 -07:00
parent a73dc50224
commit 9888fac99e
9 changed files with 884 additions and 350 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scribble/base.rkt
View File

@ -746,7 +746,10 @@
(let ([parent (collected-info-parent (part-collected-info sec ri))]) (let ([parent (collected-info-parent (part-collected-info sec ri))])
(if parent (if parent
(collected-info-info (part-collected-info parent ri)) (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) (lambda (k v)
(when (and (pair? k) (eq? 'index-entry (car k))) (when (and (pair? k) (eq? 'index-entry (car k)))
(set! l (cons (cons (cadr k) v) l))))) (set! l (cons (cons (cadr k) v) l)))))

20
collects/scribble/xref.rkt
View File

@ -42,8 +42,9 @@
[load-source (lambda (src ci) [load-source (lambda (src ci)
(parameterize ([current-namespace (parameterize ([current-namespace
(namespace-anchor->empty-namespace here)]) (namespace-anchor->empty-namespace here)])
(let ([v (src)]) (let ([vs (src)])
(when v (send renderer deserialize-info v ci #:root root-path)))))] (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 [ci (send renderer collect null null fp
(lambda (key ci) (lambda (key ci)
(define src (demand-source key)) (define src (demand-source key))
@ -57,14 +58,15 @@
;; Xref reading ;; Xref reading
(define (xref-index xrefs) (define (xref-index xrefs)
(filter (define ci (resolve-info-ci (xrefs-ri xrefs)))
values ;; Force all xref info:
(hash-map ((collect-info-ext-demand ci) #f ci)
(collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs))) ;; look for `index-entry' keys:
(lambda (k v) (for/list ([(k v) (in-hash (collect-info-ext-ht ci))]
#:when
(and (pair? k) (and (pair? k)
(eq? (car k) 'index-entry) (eq? (car k) 'index-entry)))
(make-entry (car v) (cadr v) (cadr k) (caddr v))))))) (make-entry (car v) (cadr v) (cadr k) (caddr v))))
;; dest-file can be #f, which will make it return a string holding the ;; dest-file can be #f, which will make it return a string holding the
;; resulting html ;; resulting html

547
collects/setup/doc-db.rkt
View File

@ -4,88 +4,369 @@
"main-doc.rkt") "main-doc.rkt")
(provide doc-db-available? (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-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?) (define (doc-db-available?)
(sqlite3-available?)) (sqlite3-available?))
(define (doc-db-file->connection db-file) (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 (define select-pathid-vq
(virtual-statement "SELECT pathid FROM documented WHERE stag=$1")) (virtual-statement "SELECT pathid FROM documented WHERE stag=$1"))
(define select-path-vq (define select-path-vq
(virtual-statement "SELECT atmain, path FROM pathids WHERE pathid=$1")) (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) (define db (if (connection? db-file)
db-file db-file
(doc-db-file->connection db-file))) (doc-db-file->connection db-file)))
(setup db)
(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)))))
(begin0 (begin0
(and pathid
(call-with-transaction/retry (call-with-transaction/retry
lock
db db
(if (connection? db-file)
(lambda () (esc fail))
(lambda () (lambda ()
(define row (query-maybe-row db (esc (lambda ()
select-path-vq (disconnect db)
pathid)) (when fail (fail))
(and row (loop (max 0.01 (min 2 (* 2 pause))))))))
(let ([path (read (open-input-bytes (vector-ref row 1)))]) (lambda ()
(if (equal? "y" (vector-ref row 0)) (define results (call-with-values (lambda () (proc db)) list))
(main-doc-relative->path (cons 'doc path)) (lambda () (apply values results))))
(bytes->path path))))))) (teardown db)
(unless (connection? db-file) (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* (path->main-doc-relative filename))
(define filename-bytes (if (pair? filename*) (define filename-bytes (cond
(string->bytes/utf-8 (~s (cdr filename*))) [(pair? filename*)
(path->bytes filename*))) (string->bytes/utf-8 (~s (cdr filename*)))]
[(path? filename*)
(define db (sqlite3-connect #:database db-file #:mode 'create)) (path->bytes filename*)]
[else (path->bytes (string->path filename*))]))
;; 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 id (query-maybe-row db (~a "SELECT pathid FROM pathids" (define id (query-maybe-row db (~a "SELECT pathid FROM pathids"
" WHERE atmain=$1 AND path=$2") " WHERE atmain=$1 AND path=$2")
(if (pair? filename*) "y" "n") (if (pair? filename*) "y" "n")
@ -98,32 +379,134 @@
(if (pair? filename*) "y" "n") (if (pair? filename*) "y" "n")
filename-bytes) filename-bytes)
(add1 num)] (add1 num)]
[else (vector-ref id 0)])))) [else (vector-ref id 0)]))
(call-with-transaction/retry (define reader-cache (make-weak-hash))
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))))
(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) (define (prepare-tables db)
(let loop ([tries 0]) (when (null?
(with-handlers ([(lambda (v) (query-rows db (~a "SELECT name FROM sqlite_master"
(and (tries . < . 100) " WHERE type='table' AND name='documented'")))
(exn:fail? v) (query-exec db (~a "CREATE TABLE documented "
(regexp-match #rx"the database file is locked" "(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)))) (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) (lambda (exn)
;; Try again: ;; Try again:
(sleep) (log-doc-db-info "database locked; now waiting ~a seconds" pause)
(loop (add1 tries)))]) (handler (min 10 (* pause 2))))])
(call-with-transaction (thunk)))
db ((let/ec esc
thunk)))) (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))))

7
collects/setup/parallel-do.rkt
View File

@ -8,7 +8,6 @@
racket/match racket/match
racket/path racket/path
racket/class racket/class
racket/serialize
racket/stxparam racket/stxparam
(for-syntax syntax/parse (for-syntax syntax/parse
racket/base)) racket/base))
@ -82,7 +81,7 @@
(set! in _in) (set! in _in)
(set! err _err) (set! err _err)
(send/msg dynamic-require-cmd) (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) (define/public (send/msg msg)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
@ -121,7 +120,7 @@
(define/public (spawn _id module-path funcname [initialmsg #f]) (define/public (spawn _id module-path funcname [initialmsg #f])
(set! id _id) (set! id _id)
(set! pl (dynamic-place (string->path module-path) funcname)) (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) (define/public (send/msg msg)
(DEBUG_COMM (eprintf "CSENDING ~v ~v\n" pl msg)) (DEBUG_COMM (eprintf "CSENDING ~v ~v\n" pl msg))
(place-channel-put pl msg)) (place-channel-put pl msg))
@ -409,7 +408,7 @@
(DEBUG_COMM (fprintf orig-err "WRECVEIVED ~v\n" r)) (DEBUG_COMM (fprintf orig-err "WRECVEIVED ~v\n" r))
r)) r))
(setup-proc (deserialize (fasl->s-exp (pdo-recv))) (setup-proc (pdo-recv)
(lambda (set-proc) (lambda (set-proc)
(let/ec die-k (let/ec die-k
(define (recv/reqp) (pdo-recv)) (define (recv/reqp) (pdo-recv))

4
collects/setup/private/path-utils.rkt
View File

@ -17,4 +17,6 @@
[(memq 'user-doc flags) (user-doc name)] [(memq 'user-doc flags) (user-doc name)]
[(or under-main? (memq 'main-doc flags) (pair? (path->main-collects-relative dir))) [(or under-main? (memq 'main-doc flags) (pair? (path->main-collects-relative dir)))
(build-path (find-doc-dir) name)] (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))]))

394
collects/setup/scribble.rkt
View File

@ -21,7 +21,10 @@
scribble/html-properties scribble/html-properties
scribble/manual ; really shouldn't be here... see dynamic-require-doc scribble/manual ; really shouldn't be here... see dynamic-require-doc
scribble/private/run-pdflatex scribble/private/run-pdflatex
setup/xref
scribble/xref
unstable/file unstable/file
racket/place
(prefix-in html: scribble/html-render) (prefix-in html: scribble/html-render)
(prefix-in latex: scribble/latex-render) (prefix-in latex: scribble/latex-render)
(prefix-in contract: scribble/contract-render)) (prefix-in contract: scribble/contract-render))
@ -32,10 +35,11 @@
(define verbose (make-parameter #t)) (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) (define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category out-count)
#:transparent) #:transparent)
(define-serializable-struct info (doc ; doc structure above (define-serializable-struct info (doc ; doc structure above
providess ; list of list of provide
undef ; unresolved requires undef ; unresolved requires
searches searches
deps deps
@ -76,6 +80,10 @@
make-user? ; are we making user stuff? make-user? ; are we making user stuff?
with-record-error ; catch & record exceptions with-record-error ; catch & record exceptions
setup-printf) 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) (define (scribblings-flag? sym)
(memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page (memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
depends-all depends-all-main no-depend-on always-run))) depends-all depends-all-main no-depend-on always-run)))
@ -131,6 +139,7 @@
"WARNING" "WARNING"
"bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir) "bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir)
null)))) null))))
(log-setup-info "getting documents")
(define docs (define docs
(let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)] (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
[main-dirs (parameterize ([current-library-collection-paths [main-dirs (parameterize ([current-library-collection-paths
@ -143,17 +152,35 @@
(define (can-build*? docs) (can-build? only-dirs docs)) (define (can-build*? docs) (can-build? only-dirs docs))
(define auto-main? (and auto-start-doc? (ormap can-build*? main-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 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 (define infos
(and (ormap can-build*? docs) (and (ormap can-build*? docs)
(filter values (filter
(if (not (worker-count . > . 1)) values
(if ((min worker-count (length docs)) . < . 2)
;; non-parallel version:
(map (get-doc-info only-dirs latex-dest auto-main? auto-user? (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) 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 (parallel-do
worker-count (min worker-count (length docs))
(lambda (workerid) (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 (list-queue
docs docs
(lambda (x workerid) (s-exp->fasl (serialize x))) (lambda (x workerid) (s-exp->fasl (serialize x)))
@ -164,8 +191,10 @@
(lambda (work errmsg outstr errstr) (lambda (work errmsg outstr errstr)
(parallel-do-error-handler setup-printf 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 (define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest
auto-main? auto-user?) auto-main? auto-user? force-out-of-date?)
(define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user? send/report) (define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
force-out-of-date?
send/report)
doc) doc)
(define (setup-printf subpart formatstr . rest) (define (setup-printf subpart formatstr . rest)
(let ([task (if subpart (let ([task (if subpart
@ -181,30 +210,71 @@
(go))) (go)))
(s-exp->fasl (serialize (s-exp->fasl (serialize
((get-doc-info only-dirs latex-dest auto-main? auto-user? ((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)))))) (deserialize (fasl->s-exp doc))))))
(verbose verbosev) (verbose verbosev)
(match-message-loop (match-message-loop
[doc (send/success [doc (send/success
((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user? send/report) ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?
doc))]))))))) 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) (define (make-loop first? iter)
(let ([ht (make-hash)] (let ([infos (filter-not info-failed? infos)]
[infos (filter-not info-failed? infos)] [src->info (make-hash)]
[src->info (make-hash)]) [out-path->info-cache (make-hash)]
;; Collect definitions [main-db (find-doc-db-path latex-dest #f)]
(for* ([info infos] [user-db (find-doc-db-path latex-dest #t)])
[ks (info-providess info)] (unless only-dirs
[k ks]) (log-setup-info "cleaning database")
(let ([prev (hash-ref ht k #f)]) (define files (make-hash))
(when (and first? prev) (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 "WARNING" "duplicate tag: ~s" k)
(setup-printf #f " in: ~a" (doc-src-file (info-doc prev))) (for ([path paths])
(setup-printf #f " and: ~a" (doc-src-file (info-doc info)))) (define i (out-path->info path infos out-path->info-cache))
(hash-set! ht k info))) (setup-printf #f " in: ~a" (if i
(doc-src-file (info-doc i))
"<unknown>")))))))
;; Build deps: ;; Build deps:
(log-setup-info "determining dependencies")
(for ([i infos]) (for ([i infos])
(hash-set! src->info (doc-src-file (info-doc i)) i)) (hash-set! src->info (doc-src-file (info-doc i)) i))
(for ([info infos] #:when (info-build? info)) (for ([info infos] #:when (info-build? info))
@ -251,7 +321,7 @@
(not (memq 'no-depend-on (doc-flags (info-doc i))))) (not (memq 'no-depend-on (doc-flags (info-doc i)))))
(set! added? #t) (set! added? #t)
(hash-set! deps i #t)))) (hash-set! deps i #t))))
;; Add defeinite dependencies based on referenced keys ;; Add definite dependencies based on referenced keys
(let ([not-found (let ([not-found
(lambda (k) (lambda (k)
(unless (or (memq 'depends-all (doc-flags (info-doc info))) (unless (or (memq 'depends-all (doc-flags (info-doc info)))
@ -263,11 +333,21 @@
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(set! one? #t)) (set! one? #t))
(setup-printf #f " ~s" k)))]) (setup-printf #f " ~s" k)))])
(for ([k (info-undef info)]) (let* ([filename (sxref-path latex-dest (info-doc info) "in.sxref")]
(let ([i (hash-ref ht k #f)]) [as-user? (and (not (main-doc? (info-doc info)))
(if i (not (equal? main-db user-db)))]
(begin [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: ;; Record a definite dependency:
(define i (out-path->info found-dep infos out-path->info-cache))
(when (not (hash-ref known-deps i #f)) (when (not (hash-ref known-deps i #f))
(hash-set! known-deps i #t)) (hash-set! known-deps i #t))
;; Record also in the expected-dependency list: ;; Record also in the expected-dependency list:
@ -277,16 +357,8 @@
(printf " [Adding... ~a]\n" (printf " [Adding... ~a]\n"
(doc-src-file (info-doc i)))) (doc-src-file (info-doc i))))
(hash-set! deps i #t))) (hash-set! deps i #t)))
(when first? (for ([s-key (in-list missing)])
;; FIXME: instead of special-casing 'dep, we should (not-found s-key))))
;; 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)))))
;; If we added anything (expected or known), then mark as needed to run ;; If we added anything (expected or known), then mark as needed to run
(when added? (when added?
(when (verbose) (when (verbose)
@ -314,6 +386,7 @@
(set-info-need-run?! i #t)))) (set-info-need-run?! i #t))))
;; Iterate, if any need to run: ;; Iterate, if any need to run:
(when (and (ormap info-need-run? infos) (iter . < . 30)) (when (and (ormap info-need-run? infos) (iter . < . 30))
(log-setup-info "building")
;; Build again, using dependencies ;; Build again, using dependencies
(let ([need-rerun (filter-map (lambda (i) (let ([need-rerun (filter-map (lambda (i)
(and (info-need-run? i) (and (info-need-run? i)
@ -334,10 +407,10 @@
(define (update-info info response) (define (update-info info response)
(match response (match response
[#f (set-info-failed?! info #t)] [#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-rendered?! info #t)
(set-info-providess! info defss)
(set-info-undef! info undef) (set-info-undef! info undef)
(set-info-searches! info searches)
(when out-delta? (when out-delta?
(set-info-out-time! info (/ (current-inexact-milliseconds) 1000))) (set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
(when in-delta? (when in-delta?
@ -345,13 +418,15 @@
(set-info-deps! info (info-known-deps info)) (set-info-deps! info (info-known-deps info))
(set-info-need-in-write?! info #t)) (set-info-need-in-write?! info #t))
(set-info-time! info (/ (current-inexact-milliseconds) 1000))])) (set-info-time! info (/ (current-inexact-milliseconds) 1000))]))
(if (not (worker-count . > . 1)) (if ((min worker-count (length need-rerun)) . < . 2)
(map (lambda (i) (map (lambda (i)
(say-rendering i #f) (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 (parallel-do
worker-count (min worker-count (length need-rerun))
(lambda (workerid) (list workerid (verbose) latex-dest)) (lambda (workerid)
(list workerid (verbose) latex-dest))
(list-queue (list-queue
need-rerun need-rerun
(lambda (i workerid) (lambda (i workerid)
@ -374,7 +449,9 @@
(match-message-loop (match-message-loop
[info [info
(send/success (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 ;; If we only build 1, then it reaches it own fixpoint
;; even if the info doesn't seem to converge immediately. ;; even if the info doesn't seem to converge immediately.
;; This is a useful shortcut when re-building a single ;; 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))))] (build-path latex-dest (path-replace-suffix name (string-append "." file))))]
[(not latex-dest) (build-path (doc-dest-dir doc) 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) (define (can-build? only-dirs doc)
(or (not only-dirs) (or (not only-dirs)
(ormap (lambda (d) (ormap (lambda (d)
@ -506,8 +590,11 @@
(for-each (lambda (k) (hash-set! ht k #t)) keys) (for-each (lambda (k) (hash-set! ht k #t)) keys)
ht)) ht))
(define (load-sxref filename) (define (load-sxref filename #:skip [skip 0])
(call-with-input-file filename (lambda (x) (fasl->s-exp x)))) (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 (define (file-or-directory-modify-seconds/stamp file
stamp-time stamp-data pos stamp-time stamp-data pos
@ -518,19 +605,21 @@
[(equal? (list-ref stamp-data pos) (get-sha1 file)) stamp-time] [(equal? (list-ref stamp-data pos) (get-sha1 file)) stamp-time]
[else t]))) [else t])))
(define (find-db-file doc) (define (find-db-file doc latex-dest)
(build-path (if (main-doc? doc) (define p (find-doc-db-path latex-dest (not (main-doc? doc))))
(find-doc-dir) (define-values (base name dir?) (split-path p))
(find-user-doc-dir)) (unless (directory-exists? base)
"docindex.sqlite")) (make-directory* base))
p)
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user? (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) doc)
(let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))]) (let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
(sxref-path latex-dest doc (format "out~a.sxref" i)))] (sxref-path latex-dest doc (format "out~a.sxref" i)))]
[info-in-file (sxref-path latex-dest doc "in.sxref")] [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")] [stamp-file (sxref-path latex-dest doc "stamp.sxref")]
[out-file (build-path (doc-dest-dir doc) "index.html")] [out-file (build-path (doc-dest-dir doc) "index.html")]
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))]) [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
@ -574,7 +663,8 @@
stamp-time stamp-data 0 stamp-time stamp-data 0
get-compiled-file-sha1)] get-compiled-file-sha1)]
[up-to-date? [up-to-date?
(and info-out-time (and (not force-out-of-date?)
info-out-time
info-in-time info-in-time
(or (not can-run?) (or (not can-run?)
;; Need to rebuild if output file is older than input: ;; Need to rebuild if output file is older than input:
@ -590,14 +680,25 @@
(memq 'depends-all-main (doc-flags doc))) (memq 'depends-all-main (doc-flags doc)))
(and auto-user? (and auto-user?
(memq 'depends-all (doc-flags doc)))))]) (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 (setup-printf
(string-append (string-append
(if workerid (format "~a " workerid) "") (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" "~a"
(path->relative-string/setup (doc-src-file doc)))) (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? (if up-to-date?
;; Load previously calculated info: ;; Load previously calculated info:
(render-time (render-time
@ -609,30 +710,16 @@
(delete-file info-in-file) (delete-file info-in-file)
((get-doc-info only-dirs latex-dest auto-main? ((get-doc-info only-dirs latex-dest auto-main?
auto-user? with-record-error auto-user? with-record-error
setup-printf workerid) setup-printf workerid #f #f)
doc))]) doc))])
(let* ([v-in (load-sxref info-in-file)] (let ([v-in (load-sxref info-in-file)])
[v-outs (map load-sxref info-out-files)]) (unless (equal? (car v-in) (list vers (doc-flags doc)))
(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)))))
(error "old info has wrong version or flags")) (error "old info has wrong version or flags"))
(make-info (make-info
doc doc
(for/list ([v-out v-outs]) ; providess 'delayed
(let ([v (list-ref v-out 2)]) 'delayed
(with-my-namespace (map rel->path (list-ref v-in 1)) ; expected deps, in case we don't need to build...
(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...
null ; known deps (none at this point) null ; known deps (none at this point)
can-run? can-run?
my-time info-out-time my-time info-out-time
@ -642,7 +729,8 @@
vers vers
#f #f
#f)))) #f))))
(if can-run? (if (and can-run?
(not only-fast?))
;; Run the doc once: ;; Run the doc once:
(with-record-error (with-record-error
(doc-src-file doc) (doc-src-file doc)
@ -666,23 +754,20 @@
[undef (send renderer get-external ri)] [undef (send renderer get-external ri)]
[searches (resolve-info-searches ri)] [searches (resolve-info-searches ri)]
[need-out-write? [need-out-write?
(or (not out-vs) (or force-out-of-date?
(not out-vs)
(not (for/and ([out-v out-vs]) (not (for/and ([out-v out-vs])
(equal? (list vers (doc-flags doc)) (equal? (list vers (doc-flags doc))
(car out-v)))) (car out-v))))
(not (for/and ([sci scis] (not (for/and ([sci scis]
[out-v out-vs]) [out-v out-vs])
(serialized=? sci (cadr out-v)))) (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)))]) (info-out-time . > . (current-seconds)))])
(when (and (verbose) need-out-write?) (when (and (verbose) need-out-write?)
(eprintf " [New out ~a]\n" (doc-src-file doc))) (eprintf " [New out ~a]\n" (doc-src-file doc)))
(gc-point) (gc-point)
(let ([info (let ([info
(make-info doc (make-info doc
defss ; providess
undef undef
searches searches
null ; no deps, yet null ; no deps, yet
@ -699,7 +784,7 @@
#f #f
#f)]) #f)])
(when need-out-write? (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)) (set-info-need-out-write?! info #f))
(when (info-need-in-write? info) (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))
@ -718,6 +803,24 @@
(lambda () #f)) (lambda () #f))
#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) (define (make-prod-thread)
;; periodically dumps a stack trace, which can give us some idea of ;; periodically dumps a stack trace, which can give us some idea of
;; what the main thread is doing; usually used in `render-time'. ;; what the main thread is doing; usually used in `render-time'.
@ -732,36 +835,41 @@
(loop)))))) (loop))))))
(define-syntax-rule (render-time what expr) (define-syntax-rule (render-time what expr)
expr (do-render-time
#; what
(begin (lambda () expr)))
(printf "For ~a\n" what)
(time expr)) (define (do-render-time what thunk)
#; (define start (current-process-milliseconds))
(begin
(collect-garbage) (collect-garbage) (printf "pre: ~a ~s\n" what (current-memory-use))
(begin0 (begin0
(time expr) (thunk)
(collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use))))) (let ([end (current-process-milliseconds)])
(log-setup-debug "~a: ~a msec" what (- end start)))))
(define (load-sxrefs latex-dest doc vers) (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))]) (for/list ([i (add1 (doc-out-count doc))])
(load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i))))) (load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i)))))
[(list (list in-version undef deps-rel searches dep-docs) [(list (list in-version deps-rel)
(list (list out-versions scis providess) ...)) (list in-version2 undef+searches)
(list (list out-versions scis) ...))
(define expected (list vers (doc-flags doc))) (define expected (list vers (doc-flags doc)))
(unless (and (equal? in-version expected) (unless (and (equal? in-version expected)
(equal? in-version2 expected)
(for/and ([out-version out-versions]) (for/and ([out-version out-versions])
(equal? out-version expected))) (equal? out-version expected)))
(error "old info has wrong version or flags")) (error "old info has wrong version or flags"))
(match (with-my-namespace
(lambda ()
(deserialize undef+searches)))
[(list undef searches)
(with-my-namespace* (with-my-namespace*
(values (deserialize undef) (values undef
deps-rel deps-rel
(deserialize searches) searches
(map rel-doc->doc (deserialize dep-docs)) scis))])]))
scis
(map deserialize providess)))]))
(define (build-again! latex-dest info with-record-error) (define (build-again! latex-dest info with-record-error)
(define (cleanup-dest-dir doc) (define (cleanup-dest-dir doc)
@ -784,14 +892,15 @@
(doc-src-file doc) (doc-src-file doc)
(lambda () (lambda ()
(define vers (send renderer get-serialize-version)) (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) (if (info? info)
(begin
(when (eq? 'delayed (info-undef info))
(read-delayed-in! info latex-dest))
(values (info-undef info) (values (info-undef info)
(info-deps->rel-doc-src-file info) (info-deps->rel-doc-src-file info)
(info-searches info) (info-searches info)
(info-deps->doc info) (load-doc-scis doc)))
(load-doc-scis doc)
(info-providess info))
(load-sxrefs latex-dest doc vers))) (load-sxrefs latex-dest doc vers)))
(parameterize ([current-directory (doc-src-dir doc)]) (parameterize ([current-directory (doc-src-dir doc)])
@ -800,23 +909,21 @@
[fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))] [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))] [ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))]
[ri (begin [ri (begin
(render-time "deserialize" (xref-transfer-info renderer ci (make-collections-xref
(with-my-namespace* #:no-user? (main-doc? doc)
(for* ([dep-doc ff-dep-docs] #:doc-db (and latex-dest
[sci (load-doc-scis dep-doc)]) (find-doc-db-path latex-dest #t))))
(send renderer deserialize-info sci ci))))
(render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))] (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))] [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))] [defss (render-time "defined" (send renderer get-defineds ci (add1 (doc-out-count doc)) v))]
[undef (render-time "undefined" (send renderer get-external ri))] [undef (render-time "undefined" (send renderer get-external ri))]
[in-delta? (not (equal? (any-order undef) (any-order ff-undef)))] [searches (render-time "searches" (resolve-info-searches ri))]
[out-delta? (or (not (for/and ([sci scis] [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]) [ff-sci ff-scis])
(serialized=? sci ff-sci))) (serialized=? sci ff-sci)))]
(not (for/and ([defs defss] [db-file (find-db-file doc latex-dest)])
[ff-provides ff-providess])
(equal? (any-order defs) (any-order ff-provides)))))]
[db-file (find-db-file doc)])
(when (verbose) (when (verbose)
(printf " [~a~afor ~a]\n" (printf " [~a~afor ~a]\n"
(if in-delta? "New in " "") (if in-delta? "New in " "")
@ -826,7 +933,7 @@
(doc-src-file doc))) (doc-src-file doc)))
(when in-delta? (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? (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)))
@ -838,7 +945,7 @@
(lambda () (send renderer render (list v) (list dest-dir) ri)) (lambda () (send renderer render (list v) (list dest-dir) ri))
void)) void))
(gc-point) (gc-point)
(list in-delta? out-delta? defss undef)))) (list in-delta? out-delta? undef searches))))
(lambda () #f))) (lambda () #f)))
(define (gc-point) (define (gc-point)
@ -873,52 +980,53 @@
(parameterize ([current-namespace p]) (parameterize ([current-namespace p])
(call-in-nested-thread (lambda () (dynamic-require mod-path 'doc))))))) (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)]) (let* ([filename (sxref-path latex-dest doc name)])
(prep! filename) (prep! filename)
(when (verbose) (printf " [Caching to disk ~a]\n" filename)) (when (verbose) (printf " [Caching to disk ~a]\n" filename))
(make-directory*/ignore-exists-exn (doc-dest-dir doc)) (make-directory*/ignore-exists-exn (doc-dest-dir doc))
(with-compile-output filename (with-compile-output
filename
(lambda (out tmp-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) (define (write-out latex-dest vers doc scis providess db-file)
(for ([i (add1 (doc-out-count doc))] (for ([i (add1 (doc-out-count doc))]
[sci scis] [sci scis]
[provides providess]) [provides providess])
(write- latex-dest vers doc (format "out~a.sxref" i) (write- latex-dest vers doc (format "out~a.sxref" i)
(list sci (list (list sci))
(serialize provides))
(lambda (filename) (lambda (filename)
(unless latex-dest (doc-db-clear-provides db-file filename)
(doc-db-record-provides db-file provides filename)))))) (doc-db-add-provides db-file provides filename)))))
(define (write-out/info latex-dest info scis db-file) (define (write-out/info latex-dest info scis providess db-file)
(write-out latex-dest (info-vers info) (info-doc info) scis (info-providess info) 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" (write- latex-dest vers doc "in.sxref"
(list (serialize undef) (list (list rels)
rels (list (serialize (list undef
(serialize searches) searches))))
;; The following last element is used only by the parallel build. (lambda (filename)
;; It's redundant in the sense that the same information (doc-db-clear-dependencies db-file filename)
;; is in `rels' --- the docs that this one depends on --- (doc-db-clear-searches db-file filename)
;; but putting the whole `doc' record here makes it easier (doc-db-add-dependencies db-file undef filename)
;; for a place to reconstruct a suitable `doc' record. (doc-db-add-searches db-file searches filename))))
;; It probably would be better to reconstruct the `doc'
;; record in a place from the path.
(serialize (map doc->rel-doc dep-docs)))
void))
(define (write-in/info latex-dest info) (define (write-in/info latex-dest info)
(when (eq? 'delayed (info-undef info))
(read-delayed-in! info latex-dest))
(write-in latex-dest (write-in latex-dest
(info-vers info) (info-vers info)
(info-doc info) (info-doc info)
(info-undef info) (info-undef info)
(info-deps->rel-doc-src-file info) (info-deps->rel-doc-src-file info)
(info-searches info) (info-searches info)
(info-deps->doc info))) (find-db-file (info-doc info) latex-dest)))
(define (rel->path r) (define (rel->path r)
(if (bytes? r) (if (bytes? r)

4
collects/setup/setup-unit.rkt
View File

@ -998,9 +998,7 @@
(set-doc:verbose) (set-doc:verbose)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(setup-printf #f "docs failure: ~a" (exn->string 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)))])
(define auto-start-doc? (define auto-start-doc?
(and (not (null? (archives))) (and (not (null? (archives)))
(archive-implies-reindex))) (archive-implies-reindex)))

89
collects/setup/xref.rkt
View File

@ -9,11 +9,12 @@
"private/path-utils.rkt" "private/path-utils.rkt"
"doc-db.rkt") "doc-db.rkt")
(provide load-collections-xref) (provide load-collections-xref
make-collections-xref)
(define cached-xref #f) (define cached-xref #f)
(define (get-dests) (define (get-dests no-user?)
(define main-dirs (define main-dirs
(parameterize ([current-library-collection-paths (parameterize ([current-library-collection-paths
(let ([d (find-collects-dir)]) (let ([d (find-collects-dir)])
@ -40,7 +41,8 @@
(list-ref d 4) (list-ref d 4)
1)]) 1)])
(if (not (and (len . >= . 3) (memq 'omit (caddr d)))) (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 (if d
(for*/list ([i (in-range (add1 out-count))] (for*/list ([i (in-range (add1 out-count))]
[p (in-value (build-path d (format "out~a.sxref" i)))] [p (in-value (build-path d (format "out~a.sxref" i)))]
@ -49,44 +51,81 @@
null)) null))
null))))) null)))))
(define (dest->source dest) (define ((dest->source done-ht) dest)
(if (hash-ref done-ht dest #f)
(lambda () #f)
(lambda () (lambda ()
(hash-set! done-ht dest #t)
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
(log-error (log-warning
"warning: ~a" "warning: ~a"
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "~e" exn))) (format "~e" exn)))
#f)]) #f)])
(cadr (call-with-input-file* dest fasl->s-exp))))) (cadr (call-with-input-file* dest fasl->s-exp))))))
(define (dir->connection dir) (define (make-key->source db-path no-user?)
(define p (build-path dir "docindex.sqlite")) (define main-db (cons (or db-path
(and (file-exists? p) (build-path (find-doc-dir) "docindex.sqlite"))
(doc-db-file->connection p))) ;; cache for a connection:
(box #f)))
(define main-db (delay (dir->connection (find-doc-dir)))) (define user-db (and (not no-user?)
(define user-db (delay (dir->connection (find-user-doc-dir)))) (cons (build-path (find-user-doc-dir) "docindex.sqlite")
;; cache for a connection:
(define (key->source key) (box #f))))
(define done-ht (make-hash)) ; tracks already-loaded documents
(lambda (key)
(cond
[key
(define (try p) (define (try p)
(and p (and p
(doc-db-key->path p key))) (let* ([maybe-db (unbox (cdr p))]
(define dest (or (try (force main-db)) [db
(try (force user-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 (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) (define (get-reader-thunks no-user? done-ht)
(map dest->source (map (dest->source done-ht)
(filter values (get-dests)))) (filter values (get-dests no-user?))))
(define (load-collections-xref [report-loading void]) (define (load-collections-xref [report-loading void])
(or cached-xref (or cached-xref
(begin (report-loading) (begin (report-loading)
(set! cached-xref (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?) (if (doc-db-available?)
(load-xref null (load-xref null
#:demand-source key->source) #:demand-source (make-key->source db-path no-user?))
(load-xref (get-reader-thunks)))) (load-xref (get-reader-thunks no-user? (make-hash)))))
cached-xref)))

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.3.1.8" #define MZSCHEME_VERSION "5.3.1.9"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 1 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)