use `filesystem-change-evt' and static roots to speed library search

Use `filesystem-change-evt' (where supported) to detect changes to
collection link files.

Add "static root" as a new kind of collection root directory in links
files. A static root directory is assumed to not change (in terms of
its collection subdirectories) as long as the links file itself does
not change.

Propagate the notion of static roots through `raco link' and `raco pkg
install'.

Change the `pkg-links' makefile target to install static links
instead of plain links.

The result of all of these changes is to cut 25%-33% of the
time for `racket -l racket', bringing it back in line with
the pre-package-reorganization time.
This commit is contained in:
Matthew Flatt 2013-07-06 21:10:45 -06:00
parent 3b0566ea0a
commit b8e20f5a3e
14 changed files with 1101 additions and 921 deletions

View File

@ -234,7 +234,9 @@
(send install-button enable (and (pair? sels)
(or (and all-installed?
(not (for/or ([p (in-list sels)])
(eq? 'link (car (pkg-info-orig-pkg (cdr p)))))))
(define kind (car (pkg-info-orig-pkg (cdr p))))
(or (eq? 'link kind)
(eq? 'static-link kind)))))
none-installed?)))
(send install-button set-label (if all-installed?
(string-constant install-pkg-update)
@ -462,6 +464,7 @@
(case (car (pkg-info-orig-pkg info))
[(catalog) ""]
[(link) "="]
[(static-link) "="]
[(url) "@"]))]))
(for/list ([p list-pkgs]) (->label-string (db:pkg-name p)))
(for/list ([p list-pkgs]) (->label-string (db:pkg-author p)))

View File

@ -70,7 +70,8 @@ catalogs}.}
@defstruct[pkg-info ([orig-pkg (or/c (list/c 'catalog string?)
(list/c 'url string?)
(list/c 'link string?))]
(list/c 'link string?)
(list/c 'static-link string?))]
[checksum (or/c #f string?)]
[auto? boolean?])
#:prefab]{
@ -117,7 +118,8 @@ scope}.}
@deftogether[(
@defproc[(pkg-desc? [v any/c]) boolean?]
@defproc[(pkg-desc [name string?]
[type (or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)]
[type (or/c #f 'file 'dir 'link 'static-link
'file-url 'dir-url 'github 'name)]
[checksum (or/c string? #f)]
[auto? boolean?])
pkg-desc?]

View File

@ -311,6 +311,13 @@ sub-sub-commands:
definition in @filepath{info.rkt} is changed (i.e., he package must be removed and re-installed
for the change to take effect).}
@item{@DFlag{static-link} --- Implies @DFlag{link}, and also indicates that subdirectories
of the given directory will not change for each given directory that implements a
@tech{multi-collection package}.}
@item{@DFlag{skip-installed} --- Ignore any @nonterm{pkg-source}
whose name corresponds to an already-installed package.}
@item{@DFlag{scope} @nonterm{scope} --- Selects the @tech{package scope} for installation, where @nonterm{scope} is one of
@itemlist[
@item{@exec{installation} --- Install packages for all users of a Racket installation, rather than user-specific.}
@ -925,12 +932,13 @@ requires reinstallation of all packages every version change.)
@subsection{Where and how are packages installed?}
User-specific and Racket-version-specific packages are in @racket[(build-path
(find-system-path 'addon-dir) (version) "pkgs")], user-specific and
all-version packages are in @racket[(build-path (find-system-path
'addon-dir) "pkgs")], and installation-wide packages are in
@racket[(build-path (find-lib-dir) "pkgs")]. They are linked as
collection roots with @exec{raco link}.
User-specific and Racket-version-specific packages are in
@racket[(build-path (find-system-path 'addon-dir) (version) "pkgs")],
user-specific and all-version packages are in @racket[(build-path
(find-system-path 'addon-dir) "pkgs")], and installation-wide packages
are in @racket[(build-path (find-lib-dir) "pkgs")]. They are linked as
collections (for single-collection packages) collection roots (for
multi-collection packages) with @exec{raco link}.
@subsection{How are user-specific and installation-wide @tech{package scopes}
related for conflict checking?}

View File

@ -77,6 +77,11 @@ Full command-line options:
that match a directory are removed. This flag is mutually
exclusive with @Flag{n} and @DFlag{name}.}
@item{@Flag{D} or @DFlag{static-root} --- Like @Flag{d} or
@DFlag{root}, but each directory is assumed to have a constant
set of subdirectories (to improve the use of collection-search
caches) as long as the links file itself does not change.}
@item{@Flag{x} @nonterm{regexp} or @DFlag{version-regexp}
@nonterm{regexp} --- Sets a version regexp that limits the link
to use only by Racket versions (as reported by
@ -133,6 +138,7 @@ Full command-line options:
[#:file file (or/c path-string? #f) #f]
[#:name name (or/c string? #f) #f]
[#:root? root? any/c #f]
[#:static-root? static-root? any/c #f]
[#:version-regexp version-regexp (or/c regexp? #f) #f]
[#:error error-proc (symbol? string? any/c ... . -> . any) error]
[#:remove? remove? any/c #f]
@ -149,6 +155,10 @@ user-specific, all-version @tech[#:doc reference-doc]{collection links file} if
@racket[shared?] is true, or the installation-wide @tech[#:doc
reference-doc]{collection links file} otherwise.
The @racket[static-root?] flag value is ignored unless @racket[root?]
is true and @racket[remove?] is false, in which case each given
@racket[dir] is added as a static root if @racket[static-root?] is true.
The @racket[error-proc] argument is called to raise exceptions that
would be fatal to the @exec{raco link} command.

View File

@ -217,12 +217,16 @@ A @tech{collection links file} is @racket[read] with default reader
parameter settings to obtain a list. Every element of the list must be
a link specification with one of the forms @racket[(list _string
_path)], @racket[(list _string _path _regexp)], @racket[(list 'root
_path)], or @racket[(list 'root _regexp)]. A @racket[_string] names a
_path)], @racket[(list 'root _path _regexp)], @racket[(list 'static-root
_path)], @racket[(list 'static-root _path _regexp)]. A @racket[_string] names a
top-level @tech{collection}, in which case @racket[_path] is a path
that can be used as the collection's path (directly, as opposed to a
subdirectory of @racket[_path] named by @racket[_string]). A
@racket['root] entry, in contrast, acts like an path in
@racket[(current-library-collection-paths)]. If @racket[_path] is a
@racket[(current-library-collection-paths)]. A
@racket['static-root] entry is like a @racket['root] entry, but
where the immediate content of the directory is assumed not to change unless the
@tech{collection links file} changes. If @racket[_path] is a
relative path, it is relative to the directory containing the
@tech{collection links file}. If @racket[_regexp] is specified in a
link, then the link is used only if @racket[(regexp-match? _regexp

View File

@ -613,7 +613,7 @@
(let ()
(match-define (pkg-info orig-pkg checksum _) info)
(match orig-pkg
[`(link ,orig-pkg-dir)
[`(,(or 'link 'static-link) ,orig-pkg-dir)
orig-pkg-dir]
[_
(build-path (pkg-installed-dir) pkg-name)]))))
@ -662,7 +662,7 @@
(for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db/cached))]
#:when (not pkg))
(match (pkg-info-orig-pkg v)
[`(link ,orig-pkg-dir)
[`(,(or 'link 'static-link) ,orig-pkg-dir)
(define e (explode orig-pkg-dir))
(if (sub-path? <= p e)
(values k (build-path* (list-tail p (length e))))
@ -687,7 +687,7 @@
(define shared? (and user?
(eq? (current-pkg-scope) 'shared)))
(match orig-pkg
[`(link ,_)
[`(,(or 'link 'static-link) ,_)
(links pkg-dir
#:remove? #t
#:user? user?
@ -1040,14 +1040,16 @@
(unless staged?
(delete-directory/files pkg-dir))))]
[(or (eq? type 'dir)
(eq? type 'link))
(eq? type 'link)
(eq? type 'static-link))
(unless (directory-exists? pkg)
(pkg-error "no such directory\n path: ~a" pkg))
(let ([pkg (directory-path-no-slash pkg)])
(cond
[(eq? type 'link)
[(or (eq? type 'link)
(eq? type 'static-link))
(install-info pkg-name
`(link ,(simple-form-path* pkg))
`(,type ,(simple-form-path* pkg))
pkg
#f #f
(directory->module-paths pkg pkg-name metadata-ns))]
@ -1363,7 +1365,9 @@
(path? scope)))
#:shared? (eq? 'shared scope)
#:file (scope->links-file scope)
#:root? (not single-collect))
#:root? (not single-collect)
#:static-root? (and (pair? orig-pkg)
(eq? 'static-link (car orig-pkg))))
(define this-pkg-info
(if single-collect
(sc-pkg-info orig-pkg checksum auto? single-collect)
@ -1503,13 +1507,13 @@
(match-define (pkg-info orig-pkg checksum _)
(package-info pkg-name))
(define ty (first orig-pkg))
(not (member ty '(link dir file))))
(not (member ty '(link static-link dir file))))
(define ((update-package download-printf) pkg-name)
(match-define (pkg-info orig-pkg checksum auto?)
(package-info pkg-name))
(match orig-pkg
[`(link ,_)
[`(,(or 'link 'static-link) ,_)
(pkg-error (~a "cannot update linked packages\n"
" package name: ~a\n"
" package source: ~a")
@ -2258,7 +2262,7 @@
(values (or/c #f string?) (or/c #f 'same path?)))]
[pkg-desc
(-> string?
(or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)
(or/c #f 'file 'dir 'link 'static-link 'file-url 'dir-url 'github 'name)
(or/c string? #f)
boolean?
pkg-desc?)]

View File

@ -74,7 +74,10 @@
" search-auto: like 'search-ask' but does not ask for permission to install")]
[#:bool force () "Ignores conflicts"]
[#:bool ignore-checksums () "Ignores checksums"]
#:once-any
[#:bool link () ("Link a directory package source in place")]
[#:bool static-link () ("Link in place, promising collections do not change")]
#:once-each
[#:bool skip-installed () ("Skip a <pkg-source> if already installed")]
#:once-any
[(#:sym scope [installation user shared] #f) scope ()
@ -107,7 +110,10 @@
#:ignore-checksums? ignore-checksums
#:skip-installed? skip-installed
(for/list ([p (in-list pkg-source)])
(pkg-desc p (or (and link 'link) type) name #f))))))
(define a-type (or (and link 'link)
(and static-link 'static-link)
type))
(pkg-desc p a-type name #f))))))
(setup no-setup setup-collects jobs)))]
[update
"Update packages"

View File

@ -95,7 +95,9 @@
(define name (extract-archive-name name+ext))
(values name 'file)]
[(if type
(or (eq? type 'dir) (eq? type 'link))
(or (eq? type 'dir)
(eq? type 'link)
(eq? type 'static-link))
(path-string? s))
(define-values (base name dir?) (split-path s))
(define dir-name (and (path? name) (path->string name)))

View File

@ -7,6 +7,7 @@
(define link-file (make-parameter #f))
(define link-name (make-parameter #f))
(define root-mode (make-parameter #f))
(define static-root-mode (make-parameter #f))
(define link-version (make-parameter #f))
(define remove-mode (make-parameter #f))
(define repair-mode (make-parameter #f))
@ -28,6 +29,9 @@
(link-name name)]
[("-d" "--root") "Treat <dir> as a collection root"
(root-mode #t)]
[("-D" "--static-root") "Treat <dir> as a static collection root"
(root-mode #t)
(static-root-mode #t)]
#:once-each
[("-x" "--version-regexp") regexp "Set the version pregexp"
(with-handlers ([exn:fail:contract? (lambda (exn)
@ -74,6 +78,7 @@
(apply links
dirs
#:root? (root-mode)
#:static-root? (static-root-mode)
#:user? user?
#:shared? shared?
#:file (link-file)

View File

@ -12,6 +12,7 @@
#:version-regexp [version-regexp #f]
#:shared? [shared? #f]
#:root? [root? #f]
#:static-root? [static-root? #f]
#:remove? [remove? #f]
#:show? [show? #f]
#:repair? [repair? #f]
@ -67,8 +68,9 @@
(content-error "entry is a not a 2- or 3-element list: " e))
#:when
(or (or (string? (car e))
(eq? 'root (car e)))
(content-error "entry's first element is not a string or 'root: " e))
(eq? 'root (car e))
(eq? 'static-root (car e)))
(content-error "entry's first element is not a string, 'root, or 'static-root: " e))
#:when
(or (path-string? (cadr e))
(content-error "entry's second element is not a path string: " e))
@ -115,7 +117,9 @@
(path->complete-path d))
#:more-than-root? #t))]
[a-name (if root?
'root
(if static-root?
'static-root
'root)
(and d
(or name
(let-values ([(base name dir?) (split-path dp)])
@ -136,7 +140,8 @@
(and name
(not (equal? (car e) name)))
(and root?
(not (eq? (car e) 'root)))
(not (or (eq? (car e) 'root)
(eq? (car e) 'static-root))))
(and version-regexp
(pair? (cddr e))
(not (equal? (caddr e) version-regexp)))))
@ -181,7 +186,8 @@
(when show?
(for ([e (in-list new-table)])
(printf " ~a~s path: ~s~a\n"
(if (eq? (car e) 'root)
(if (or (eq? (car e) 'root)
(eq? (car e) 'static-root))
""
"collection: ")
(car e)
@ -197,7 +203,8 @@
(if root?
;; Return root paths:
(for/list ([e (in-list new-table)]
#:when (eq? 'root (car e))
#:when (or (eq? 'root (car e))
(eq? 'static-root (car e)))
#:when (or (null? (cddr e))
(regexp-match? (caddr e) (version))))
(simplify (cadr e)))

View File

@ -174,7 +174,7 @@
(define auto? (is-auto? name))
(printf "Adding ~a~a as ~a\n" name (if auto? "*" "") dir)
(pkg-desc (path->string dir)
'link
'static-link
#f
auto?)))))

File diff suppressed because it is too large Load Diff

View File

@ -424,7 +424,13 @@
"(define-values(links-stamps)(make-vector(vector-length links-paths) #f))"
"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))"
"(define-values(file->stamp)"
"(lambda(path)"
"(lambda(path old-stamp)"
"(cond"
"((and old-stamp"
"(cdr old-stamp)"
"(not(sync/timeout 0(cdr old-stamp))))"
" old-stamp)"
"(else"
"(call-with-continuation-prompt"
"(lambda()"
"(with-continuation-mark"
@ -435,6 +441,18 @@
"(if(exn:fail:filesystem? exn)"
"(lambda() #f)"
"(lambda()(raise exn)))))"
"(let((dir-evt"
"(let loop((path path))"
"(let-values(((base name dir?)(split-path path)))"
"(and(path? base)"
"(if(directory-exists? base)"
"(filesystem-change-evt base(lambda() #f))"
"(loop base)))))))"
"(if(not(file-exists? path))"
"(cons #f dir-evt)"
"(let((evt(filesystem-change-evt path(lambda() #f))))"
"(when dir-evt(filesystem-change-evt-cancel dir-evt))"
"(cons"
"(let((p(open-input-file path)))"
"(dynamic-wind"
" void"
@ -452,8 +470,18 @@
" null"
"(cons bstr(loop)))))))"
" bstr)))"
"(lambda()(close-input-port p))))))"
" stamp-prompt-tag)))"
"(lambda()(close-input-port p))))"
" evt))))))"
" stamp-prompt-tag)))))"
"(define-values(stamp=?)"
"(lambda(a b)"
"(if(and(pair? a)(pair? b))"
"(equal?(car a)(car b))"
"(equal? a b))))"
"(define-values(no-file-stamp?)"
"(lambda(a)"
"(or(not a)"
"(not(car a)))))"
"(define-values(get-linked-collections)"
"(lambda(user? shared? ii)"
"(call/ec(lambda(esc)"
@ -494,11 +522,12 @@
"(user? user-links-path)"
"(shared? shared-links-path)"
"(else(vector-ref links-paths ii))))"
"(ts(file->stamp a-links-path)))"
"(if(not(equal? ts(cond"
"(a-links-stamp(cond"
"(user? user-links-stamp)"
"(shared? shared-links-stamp)"
"(else(vector-ref links-stamps ii)))))"
"(else(vector-ref links-stamps ii))))"
"(ts(file->stamp a-links-path a-links-stamp)))"
"(if(not(stamp=? ts a-links-stamp))"
"(with-continuation-mark"
" exception-handler-key"
"(make-handler ts)"
@ -516,7 +545,9 @@
"(read-accept-reader #t)"
"(read-accept-lang #f)"
"(current-readtable #f))"
"(let((v(let((p(open-input-file a-links-path 'binary)))"
"(let((v(if(no-file-stamp? ts)"
" null"
"(let((p(open-input-file a-links-path 'binary)))"
"(dynamic-wind"
" void"
"(lambda() "
@ -524,14 +555,15 @@
"(read p)"
"(unless(eof-object?(read p))"
" (error \"expected a single S-expression\"))))"
"(lambda()(close-input-port p))))))"
"(lambda()(close-input-port p)))))))"
"(unless(and(list? v)"
"(andmap(lambda(p)"
"(and(list? p)"
"(or(= 2(length p))"
"(= 3(length p)))"
"(or(string?(car p))"
"(eq? 'root(car p)))"
"(eq? 'root(car p))"
"(eq? 'static-root(car p)))"
"(path-string?(cadr p))"
"(or(null?(cddr p))"
"(regexp?(caddr p)))))"
@ -546,17 +578,25 @@
"(regexp-match?(caddr p)(version)))"
"(let((dir(simplify-path"
"(path->complete-path(cadr p) dir))))"
"(if(symbol?(car p))"
"(begin"
"(cond"
"((eq?(car p) 'static-root)"
"(for-each"
"(lambda(sub)"
"(when(directory-exists?(build-path dir sub))"
"(let((k(string->symbol(path->string sub))))"
"(hash-set! ht k(cons dir(hash-ref ht k null))))))"
"(directory-list dir)))"
"((eq?(car p) 'root)"
"(unless(hash-ref ht #f #f)"
"(hash-set! ht #f null))"
"(hash-for-each"
" ht"
"(lambda(k v)"
"(hash-set! ht k(cons dir v)))))"
"(else"
"(let((s(string->symbol(car p))))"
"(hash-set! ht s(cons(box dir)"
"(hash-ref ht s null))))))))"
"(hash-ref ht s null)))))))))"
" v)"
"(hash-for-each"
" ht"

View File

@ -505,42 +505,72 @@
(define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp))
(define-values (file->stamp)
(lambda (path)
;; We'd prefer to do something lighter than read the file every time!
;; Using just the file's modification date almost works, but 1-second
;; granularity isn't fine enough. To do this right, probably Racket needs
;; to provide more support from the OS's filesystem (along the lines of
;; inotify, but the interface varies among platforms).
(call-with-continuation-prompt
(lambda ()
(with-continuation-mark
exception-handler-key
(lambda (exn)
(abort-current-continuation
stamp-prompt-tag
(if (exn:fail:filesystem? exn)
(lambda () #f)
(lambda () (raise exn)))))
(let ([p (open-input-file path)])
(dynamic-wind
void
(lambda ()
(let ([bstr (read-bytes 8192 p)])
(if (and (bytes? bstr)
((bytes-length bstr) . >= . 8192))
(apply
bytes-append
(cons
bstr
(let loop ()
(let ([bstr (read-bytes 8192 p)])
(if (eof-object? bstr)
null
(cons bstr (loop)))))))
bstr)))
(lambda () (close-input-port p))))))
stamp-prompt-tag)))
(lambda (path old-stamp)
;; Using just the file's modification date almost works as a stamp,
;; but 1-second granularity isn't fine enough. A stamp is therefore
;; the file content paired with a filesystem-change event (where
;; supported), and the event lets us recycle the old stamp almost
;; always.
(cond
[(and old-stamp
(cdr old-stamp)
(not (sync/timeout 0 (cdr old-stamp))))
old-stamp]
[else
(call-with-continuation-prompt
(lambda ()
(with-continuation-mark
exception-handler-key
(lambda (exn)
(abort-current-continuation
stamp-prompt-tag
(if (exn:fail:filesystem? exn)
(lambda () #f)
(lambda () (raise exn)))))
(let ([dir-evt
(let loop ([path path])
(let-values ([(base name dir?) (split-path path)])
(and (path? base)
(if (directory-exists? base)
(filesystem-change-evt base (lambda () #f))
(loop base)))))])
(if (not (file-exists? path))
(cons #f dir-evt)
(let ([evt (filesystem-change-evt path (lambda () #f))])
(when dir-evt (filesystem-change-evt-cancel dir-evt))
(cons
(let ([p (open-input-file path)])
(dynamic-wind
void
(lambda ()
(let ([bstr (read-bytes 8192 p)])
(if (and (bytes? bstr)
((bytes-length bstr) . >= . 8192))
(apply
bytes-append
(cons
bstr
(let loop ()
(let ([bstr (read-bytes 8192 p)])
(if (eof-object? bstr)
null
(cons bstr (loop)))))))
bstr)))
(lambda () (close-input-port p))))
evt))))))
stamp-prompt-tag)])))
(define-values (stamp=?)
(lambda (a b)
(if (and (pair? a) (pair? b))
(equal? (car a) (car b))
(equal? a b))))
(define-values (no-file-stamp?)
(lambda (a)
(or (not a)
(not (car a)))))
(define-values (get-linked-collections)
(lambda (user? shared? ii)
(call/ec (lambda (esc)
@ -582,11 +612,12 @@
[user? user-links-path]
[shared? shared-links-path]
[else (vector-ref links-paths ii)])]
[ts (file->stamp a-links-path)])
(if (not (equal? ts (cond
[a-links-stamp (cond
[user? user-links-stamp]
[shared? shared-links-stamp]
[else (vector-ref links-stamps ii)])))
[else (vector-ref links-stamps ii)])]
[ts (file->stamp a-links-path a-links-stamp)])
(if (not (stamp=? ts a-links-stamp))
(with-continuation-mark
exception-handler-key
(make-handler ts)
@ -604,22 +635,25 @@
[read-accept-reader #t]
[read-accept-lang #f]
[current-readtable #f])
(let ([v (let ([p (open-input-file a-links-path 'binary)])
(dynamic-wind
void
(lambda ()
(begin0
(read p)
(unless (eof-object? (read p))
(error "expected a single S-expression"))))
(lambda () (close-input-port p))))])
(let ([v (if (no-file-stamp? ts)
null
(let ([p (open-input-file a-links-path 'binary)])
(dynamic-wind
void
(lambda ()
(begin0
(read p)
(unless (eof-object? (read p))
(error "expected a single S-expression"))))
(lambda () (close-input-port p)))))])
(unless (and (list? v)
(andmap (lambda (p)
(and (list? p)
(or (= 2 (length p))
(= 3 (length p)))
(or (string? (car p))
(eq? 'root (car p)))
(eq? 'root (car p))
(eq? 'static-root (car p)))
(path-string? (cadr p))
(or (null? (cddr p))
(regexp? (caddr p)))))
@ -634,21 +668,31 @@
(regexp-match? (caddr p) (version)))
(let ([dir (simplify-path
(path->complete-path (cadr p) dir))])
(if (symbol? (car p))
;; add to every table element (to keep
;; the choices in order); need a better
;; data structure
(begin
(unless (hash-ref ht #f #f)
(hash-set! ht #f null))
(hash-for-each
ht
(lambda (k v)
(hash-set! ht k (cons dir v)))))
;; single collection:
(let ([s (string->symbol (car p))])
(hash-set! ht s (cons (box dir)
(hash-ref ht s null))))))))
(cond
[(eq? (car p) 'static-root)
;; multi-collection, constant content:
(for-each
(lambda (sub)
(when (directory-exists? (build-path dir sub))
(let ([k (string->symbol (path->string sub))])
(hash-set! ht k (cons dir (hash-ref ht k null))))))
(directory-list dir))]
[(eq? (car p) 'root)
;; multi-collection, dynamic content:
;; Add directory to the #f mapping, and also
;; add to every existing table element (to keep
;; the choices in order)
(unless (hash-ref ht #f #f)
(hash-set! ht #f null))
(hash-for-each
ht
(lambda (k v)
(hash-set! ht k (cons dir v))))]
[else
;; single collection:
(let ([s (string->symbol (car p))])
(hash-set! ht s (cons (box dir)
(hash-ref ht s null))))]))))
v)
;; reverse all lists:
(hash-for-each