From bc929d4876710e7a1e9e699b4a6bb57a26551f42 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Sep 2015 08:38:18 -0600 Subject: [PATCH] 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. --- racket/collects/pkg/private/catalog.rkt | 125 +++++++++++++-------- racket/collects/pkg/private/clone-path.rkt | 56 ++++++--- racket/collects/pkg/private/install.rkt | 21 ++-- racket/collects/pkg/private/prefetch.rkt | 18 +++ racket/collects/pkg/private/stage.rkt | 26 ++--- 5 files changed, 154 insertions(+), 92 deletions(-) diff --git a/racket/collects/pkg/private/catalog.rkt b/racket/collects/pkg/private/catalog.rkt index ebaabb1279..d95228212c 100644 --- a/racket/collects/pkg/private/catalog.rkt +++ b/racket/collects/pkg/private/catalog.rkt @@ -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) diff --git a/racket/collects/pkg/private/clone-path.rkt b/racket/collects/pkg/private/clone-path.rkt index c6635fa9a6..32c37bcb53 100644 --- a/racket/collects/pkg/private/clone-path.rkt +++ b/racket/collects/pkg/private/clone-path.rkt @@ -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))) diff --git a/racket/collects/pkg/private/install.rkt b/racket/collects/pkg/private/install.rkt index 4b6ff339a0..2df70b180d 100644 --- a/racket/collects/pkg/private/install.rkt +++ b/racket/collects/pkg/private/install.rkt @@ -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) diff --git a/racket/collects/pkg/private/prefetch.rkt b/racket/collects/pkg/private/prefetch.rkt index 4400d20e4e..77cb5fd812 100644 --- a/racket/collects/pkg/private/prefetch.rkt +++ b/racket/collects/pkg/private/prefetch.rkt @@ -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) diff --git a/racket/collects/pkg/private/stage.rkt b/racket/collects/pkg/private/stage.rkt index eceef6021b..d8c86a731a 100644 --- a/racket/collects/pkg/private/stage.rkt +++ b/racket/collects/pkg/private/stage.rkt @@ -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)])))