raco pkg install: more parallelism for catalog lookups
The layer to handle Git repo clones triggers an early catalog lookup, so add prefetching there, too.
This commit is contained in:
Matthew Flatt
parent
24eb509d15
commit
bc929d4876
|
|
@ -7,7 +7,8 @@
|
|||
"../name.rkt"
|
||||
"params.rkt"
|
||||
"config.rkt"
|
||||
"print.rkt")
|
||||
"print.rkt"
|
||||
"prefetch.rkt")
|
||||
|
||||
(provide select-info-version
|
||||
source->relative-source
|
||||
|
|
@ -127,58 +128,86 @@
|
|||
;; No further adjustments:
|
||||
new-ht)))
|
||||
|
||||
(define (package-catalog-lookup pkg details? cache download-printf)
|
||||
(define (package-catalog-lookup pkg details? cache download-printf
|
||||
#:prefetch? [prefetch? #f]
|
||||
#:prefetch-group [prefetch-group #f])
|
||||
(define (lookup-normally download-printf)
|
||||
(or (add-to-cache
|
||||
pkg cache
|
||||
(for/or ([i (in-list (pkg-catalogs))])
|
||||
(define (consulting-catalog suffix)
|
||||
(if download-printf
|
||||
(download-printf "Resolv~a ~s via ~a\n" suffix pkg (url->string i))
|
||||
(log-pkg-debug "consult~a catalog ~a" suffix (url->string i))))
|
||||
(source->absolute-source
|
||||
i
|
||||
(select-info-version
|
||||
(catalog-dispatch
|
||||
i
|
||||
;; Server:
|
||||
(lambda (i)
|
||||
(consulting-catalog "ing")
|
||||
(define addr (add-version-query
|
||||
(combine-url/relative i (format "pkg/~a" pkg))))
|
||||
(log-pkg-debug "resolving via ~a" (url->string addr))
|
||||
(read-from-server
|
||||
'package-catalog-lookup
|
||||
addr
|
||||
(lambda (v) (and (hash? v)
|
||||
(for/and ([k (in-hash-keys v)])
|
||||
(symbol? k))))
|
||||
(lambda (s) #f)))
|
||||
;; Local database:
|
||||
(lambda ()
|
||||
(define pkgs (db:get-pkgs #:name pkg))
|
||||
(and (pair? pkgs)
|
||||
(begin
|
||||
(consulting-catalog "ed")
|
||||
(db-pkg-info (car pkgs) details?))))
|
||||
;; Local directory:
|
||||
(lambda (path)
|
||||
(define pkg-path (build-path path "pkg" pkg))
|
||||
(and (file-exists? pkg-path)
|
||||
(begin
|
||||
(consulting-catalog "ed")
|
||||
(call-with-input-file* pkg-path read)))))))))
|
||||
(pkg-error (~a "cannot find package on catalogs\n"
|
||||
" package: ~a")
|
||||
pkg)))
|
||||
|
||||
(when (and details? cache)
|
||||
(error "internal error: catalog-lookup cache doesn't keep details"))
|
||||
|
||||
(or
|
||||
(and cache
|
||||
(hash-ref cache pkg #f))
|
||||
(add-to-cache
|
||||
pkg cache
|
||||
(for/or ([i (in-list (pkg-catalogs))])
|
||||
(define (consulting-catalog suffix)
|
||||
(if download-printf
|
||||
(download-printf "Resolv~a ~s via ~a\n" suffix pkg (url->string i))
|
||||
(log-pkg-debug "consult~a catalog ~a" suffix (url->string i))))
|
||||
(source->absolute-source
|
||||
i
|
||||
(select-info-version
|
||||
(catalog-dispatch
|
||||
i
|
||||
;; Server:
|
||||
(lambda (i)
|
||||
(consulting-catalog "ing")
|
||||
(define addr (add-version-query
|
||||
(combine-url/relative i (format "pkg/~a" pkg))))
|
||||
(log-pkg-debug "resolving via ~a" (url->string addr))
|
||||
(read-from-server
|
||||
'package-catalog-lookup
|
||||
addr
|
||||
(lambda (v) (and (hash? v)
|
||||
(for/and ([k (in-hash-keys v)])
|
||||
(symbol? k))))
|
||||
(lambda (s) #f)))
|
||||
;; Local database:
|
||||
(lambda ()
|
||||
(define pkgs (db:get-pkgs #:name pkg))
|
||||
(and (pair? pkgs)
|
||||
(begin
|
||||
(consulting-catalog "ed")
|
||||
(db-pkg-info (car pkgs) details?))))
|
||||
;; Local directory:
|
||||
(lambda (path)
|
||||
(define pkg-path (build-path path "pkg" pkg))
|
||||
(and (file-exists? pkg-path)
|
||||
(begin
|
||||
(consulting-catalog "ed")
|
||||
(call-with-input-file* pkg-path read)))))))))
|
||||
(pkg-error (~a "cannot find package on catalogs\n"
|
||||
" package: ~a")
|
||||
pkg)))
|
||||
(let ([v (hash-ref cache pkg #f)])
|
||||
(if (and (prefetch-future? v)
|
||||
(not prefetch?))
|
||||
(prefetch-touch v prefetch-group download-printf)
|
||||
v)))
|
||||
(cond
|
||||
[prefetch?
|
||||
(make-prefetch-future/hash cache
|
||||
pkg
|
||||
lookup-normally
|
||||
prefetch-group
|
||||
download-printf)]
|
||||
[else (lookup-normally download-printf)])))
|
||||
|
||||
(define (package-catalog-lookup-source pkg cache download-printf)
|
||||
(hash-ref (package-catalog-lookup pkg #f cache download-printf)
|
||||
'source))
|
||||
;; Beware that this function produces `#f` in prefetch mode when a
|
||||
;; prefetch future is created or hasn't been touched.
|
||||
(define (package-catalog-lookup-source pkg cache download-printf
|
||||
#:prefetch? [prefetch? #f]
|
||||
#:prefetch-group [prefetch-group #f])
|
||||
(define info (package-catalog-lookup pkg #f cache download-printf
|
||||
#:prefetch? prefetch?
|
||||
#:prefetch-group prefetch-group))
|
||||
(cond
|
||||
[(and (prefetch-future? info)
|
||||
(not prefetch?))
|
||||
(hash-ref (prefetch-touch info prefetch-group download-printf) 'source)]
|
||||
[(prefetch-future? info) #f]
|
||||
[else (hash-ref info 'source)]))
|
||||
|
||||
(define (add-to-cache pkg cache v)
|
||||
(when (and cache v)
|
||||
|
|
|
|||
|
|
@ -51,7 +51,8 @@
|
|||
catalog-lookup-cache
|
||||
download-printf
|
||||
from-command-line?
|
||||
convert-to-non-clone?)
|
||||
convert-to-non-clone?
|
||||
prefetch-group)
|
||||
;; A `repo-descs` is (hash repo (hash pkg-name desc) ...)
|
||||
(define (add-repo repo-descs repo name desc)
|
||||
(hash-set repo-descs repo
|
||||
|
|
@ -60,18 +61,27 @@
|
|||
desc)))
|
||||
|
||||
;; Filter `descs` to get get repo mappings
|
||||
(define (add-repo-desc desc ht #:prefetch? [prefetch? #f])
|
||||
(cond
|
||||
[(desc->name desc)
|
||||
=> (lambda (name)
|
||||
(cond
|
||||
[(desc->repo desc catalog-lookup-cache download-printf
|
||||
#:prefetch? prefetch?
|
||||
#:prefetch-group prefetch-group)
|
||||
=> (lambda (repo)
|
||||
(if prefetch?
|
||||
ht
|
||||
(add-repo ht repo name desc)))]
|
||||
[else ht]))]
|
||||
[else ht]))
|
||||
(when prefetch-group
|
||||
(for ([desc (in-list descs)])
|
||||
(add-repo-desc desc (hash) #:prefetch? #t)))
|
||||
(define new-repo-descs
|
||||
(for/fold ([ht (hash)]) ([desc (in-list descs)])
|
||||
(cond
|
||||
[(desc->name desc)
|
||||
=> (lambda (name)
|
||||
(cond
|
||||
[(desc->repo desc catalog-lookup-cache download-printf)
|
||||
=> (lambda (repo)
|
||||
(add-repo ht repo name desc))]
|
||||
[else ht]))]
|
||||
[else ht])))
|
||||
|
||||
(add-repo-desc desc ht)))
|
||||
|
||||
;; If updating, we don't want to complain about repos
|
||||
;; whose repo status isn't changing.
|
||||
(define check-repo-descs
|
||||
|
|
@ -353,8 +363,13 @@
|
|||
;; If `catalog-lookup-cache` is given, then check the catalog
|
||||
;; if necessary to see whether the name resolves to a repository
|
||||
;; (where the catalog will be used, anyway, so it's fine to
|
||||
;; lookup now and cache the result)
|
||||
(define (desc->repo d catalog-lookup-cache download-printf)
|
||||
;; lookup now and cache the result).
|
||||
;; In prefetch mode, the result is not useful (even as a prefetch
|
||||
;; future), because no prefetch is set up for a recursive
|
||||
;; resolution.
|
||||
(define (desc->repo d catalog-lookup-cache download-printf
|
||||
#:prefetch? [prefetch? #f]
|
||||
#:prefetch-group [prefetch-group #f])
|
||||
(define-values (name type) (package-source->name+type
|
||||
(pkg-desc-source d)
|
||||
(pkg-desc-type d)))
|
||||
|
|
@ -365,10 +380,17 @@
|
|||
[catalog-lookup-cache
|
||||
(define src (package-catalog-lookup-source name
|
||||
catalog-lookup-cache
|
||||
download-printf))
|
||||
(desc->repo (pkg-desc src #f name #f #f #f)
|
||||
catalog-lookup-cache
|
||||
download-printf)]
|
||||
download-printf
|
||||
#:prefetch? prefetch?
|
||||
#:prefetch-group prefetch-group))
|
||||
;; Might be a prefetch future in prefetch mode, so continue
|
||||
;; only if possible:
|
||||
(and (string? src)
|
||||
(desc->repo (pkg-desc src #f name #f #f #f)
|
||||
catalog-lookup-cache
|
||||
download-printf
|
||||
#:prefetch? prefetch?
|
||||
#:prefetch-group prefetch-group))]
|
||||
[else #f])]
|
||||
[(git github clone)
|
||||
(define pkg-url (string->url (pkg-desc-source d)))
|
||||
|
|
|
|||
|
|
@ -884,19 +884,20 @@
|
|||
force)
|
||||
(early-check-for-installed filtered-descs db #:wanted? #f))
|
||||
|
||||
(define-values (new-descs done-descs done-infos clone-behavior repo-descs
|
||||
extra-updating)
|
||||
(adjust-to-normalize-repos filtered-descs old-descs old-infos
|
||||
old-clone-behavior old-repo-descs
|
||||
updating?
|
||||
catalog-lookup-cache
|
||||
download-printf
|
||||
from-command-line?
|
||||
convert-to-non-clone?))
|
||||
|
||||
(call-with-prefetch-cleanup
|
||||
prefetch-group
|
||||
(lambda ()
|
||||
(define-values (new-descs done-descs done-infos clone-behavior repo-descs
|
||||
extra-updating)
|
||||
(adjust-to-normalize-repos filtered-descs old-descs old-infos
|
||||
old-clone-behavior old-repo-descs
|
||||
updating?
|
||||
catalog-lookup-cache
|
||||
download-printf
|
||||
from-command-line?
|
||||
convert-to-non-clone?
|
||||
prefetch-group))
|
||||
|
||||
(with-handlers* ([vector?
|
||||
(match-lambda
|
||||
[(vector updating? new-infos dep-pkg deps more-pre-succeed conv clone-info)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
prefetch-group-in-progress
|
||||
call-with-prefetch-cleanup
|
||||
make-prefetch-future
|
||||
make-prefetch-future/hash
|
||||
prefetch-future?
|
||||
prefetch-touch)
|
||||
|
||||
|
|
@ -71,6 +72,23 @@
|
|||
(pump-output group download-printf)
|
||||
f)
|
||||
|
||||
;; Like `make-prefetch-future`, but ensures a single prefetch for a
|
||||
;; given key with respect to the given table, and install the new future
|
||||
;; in that table.
|
||||
(define (make-prefetch-future/hash table key proc group download-printf)
|
||||
(define s (make-semaphore))
|
||||
(define f (make-prefetch-future
|
||||
group
|
||||
download-printf
|
||||
(lambda (download-printf)
|
||||
;; Don't start until hash table has future:
|
||||
(semaphore-wait s)
|
||||
;; Adjusts cache when it has a result:
|
||||
(proc download-printf))))
|
||||
(hash-set! table key f)
|
||||
(semaphore-post s)
|
||||
f)
|
||||
|
||||
;; Wait for a future to be ready
|
||||
(define (prefetch-touch f group download-printf)
|
||||
(pump-output group download-printf)
|
||||
|
|
|
|||
|
|
@ -57,11 +57,10 @@
|
|||
(define checksum
|
||||
(match pkg
|
||||
[`(catalog ,pkg-name . ,_)
|
||||
;; If we're in a prefetch thread, we expect no other prefetchs in
|
||||
;; progress for `pkg-name`:
|
||||
(hash-ref (package-catalog-lookup pkg-name #f catalog-lookup-cache
|
||||
download-printf)
|
||||
'checksum)]
|
||||
(define info (package-catalog-lookup pkg-name #f catalog-lookup-cache
|
||||
download-printf
|
||||
#:prefetch-group prefetch-group))
|
||||
(hash-ref info 'checksum)]
|
||||
[`(url ,pkg-url-str)
|
||||
(package-url->checksum pkg-url-str
|
||||
#:type type
|
||||
|
|
@ -92,18 +91,11 @@
|
|||
(prefetch-touch checksum prefetch-group download-printf)
|
||||
checksum))]
|
||||
[prefetch?
|
||||
(define s (make-semaphore))
|
||||
(define f (make-prefetch-future
|
||||
prefetch-group
|
||||
download-printf
|
||||
(lambda (download-printf)
|
||||
;; Don't start until hash table has future:
|
||||
(semaphore-wait s)
|
||||
;; Adjusts cache when it has a result:
|
||||
(lookup-normally download-printf))))
|
||||
(hash-set! remote-checksum-cache pkg f)
|
||||
(semaphore-post s)
|
||||
f]
|
||||
(make-prefetch-future/hash remote-checksum-cache
|
||||
pkg
|
||||
lookup-normally
|
||||
prefetch-group
|
||||
download-printf)]
|
||||
[else
|
||||
(lookup-normally download-printf)])))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user