diff --git a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt index a0f67f1e5d..15c8d7bd4b 100644 --- a/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt +++ b/pkgs/compiler-pkgs/compiler-lib/compiler/commands/make.rkt @@ -5,6 +5,7 @@ compiler/compiler dynext/file setup/parallel-build + setup/path-to-relative racket/match) (module test racket/base) @@ -97,15 +98,19 @@ (if did-one? "output to" "already up-to-date at") dest)))))))] ;; Parallel make: - [else + [else + (define path-cache (make-hash)) (or (parallel-compile-files source-files #:worker-count (worker-count) - #:handler (lambda (type work msg out err) + #:handler (lambda (id type work msg out err) + (define (->rel p) + (path->relative-string/library p #:cache path-cache)) (match type - ['done (when (verbose) (printf " Made ~a\n" work))] - ['output (printf " Output from: ~a\n~a~a" work out err)] - [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])) + ['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))] + ['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))] + ['output (printf " ~a output from: ~a\n~a~a" id work out err)] + [else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)])) #:options (let ([cons-if-true (lambda (bool carv cdrv) (if bool (cons carv cdrv) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax.scrbl index 17196db35f..b9de863531 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/syntax.scrbl @@ -852,7 +852,18 @@ corresponds to the default @tech{module name resolver}. of a submodule, and it's intended for use in @racket[(submod "." ....)] and @racket[(submod ".." ....)] forms.} -} +As @racket[require] prepares to handle a sequence of +@racket[require-spec]s, it logs a ``prefetch'' message to the +@tech{current logger} at the @racket['info] level, using the name +@racket['module-prefetch], and including message data that is a list +of two elements: a list of @tech{module paths} that appear to be +imported, and a directory path to use for relative module paths. The +logged list of module paths may be incomplete, but a compilation +manager can use approximate prefetch information to start on +compilations in parallel. + +@history[#:changed "6.0.1.10" @elem{Added prefetch logging.}]} + @defform[(local-require require-spec ...)]{ diff --git a/racket/collects/racket/private/reqprov.rkt b/racket/collects/racket/private/reqprov.rkt index bdc1324d3e..f7377a8bb3 100644 --- a/racket/collects/racket/private/reqprov.rkt +++ b/racket/collects/racket/private/reqprov.rkt @@ -366,7 +366,36 @@ (syntax/loc stx (#%require new-in ...)))] [(_ in ...) - (syntax/loc stx (begin (require in) ...))])))) + ;; Prefetch on simple module paths: + (let ([prefetches + (let loop ([in (syntax->list #'(in ...))]) + (cond + [(null? in) null] + [(let ([a (syntax->datum (car in))]) + (and (module-path? a) a)) + => (lambda (a) + (cons a (loop (cdr in))))] + [else + (let ([a (syntax->list (car in))]) + (if (and a + (let ([i (car a)]) + (and (identifier? i) + (or (free-identifier=? #'for-something #'for-syntax) + (free-identifier=? #'for-something #'for-template) + (free-identifier=? #'for-something #'for-label))))) + (loop (append (cdr a) (cdr in))) + (loop (cdr in))))]))]) + (unless (null? prefetches) + (log-message (current-logger) + 'info + 'module-prefetch + (format "module-prefetch: ~s in: ~s" + prefetches + (current-load-relative-directory)) + (list prefetches (current-load-relative-directory)) + #f)) + (syntax/loc stx + (begin (require in) ...)))])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require transformers diff --git a/racket/collects/setup/parallel-build.rkt b/racket/collects/setup/parallel-build.rkt index 7cadeb9bae..d7b90b56a6 100644 --- a/racket/collects/setup/parallel-build.rkt +++ b/racket/collects/setup/parallel-build.rkt @@ -12,6 +12,7 @@ racket/future compiler/find-exe racket/place + syntax/modresolve (for-syntax racket/base)) @@ -95,6 +96,9 @@ ;(when last (printer (current-output-port) "made" "~a" (cc-name cc))) #t] [else (eprintf "Failed trying to match:\n~e\n" result-type)]))] + [(list _ (list 'ADD fn)) + ;; Currently ignoring queued individual files + #f] [else (match work [(list-rest (list cc file last) message) @@ -197,30 +201,41 @@ (field [results (void)]) (inspect #f) + (define seen + (for/hash ([k (in-list filelist)]) + (values k #t))) + (define/public (work-done work wrkr msg) + (define id (send wrkr get-id)) (match msg [(list result-type out err) (match result-type [(list 'LOCK fn) (lm/lock lock-mgr fn wrkr) #f] [(list 'UNLOCK fn) (lm/unlock lock-mgr fn) #f] - [(list 'ERROR msg) (handler 'error work msg out err) + [(list 'ERROR msg) (handler id 'error work msg out err) (set! results #f) #t] ['DONE (define (string-!empty? s) (not (zero? (string-length s)))) (if (ormap string-!empty? (list out err)) - (handler 'output work "" out err) - (handler 'done work "" "" "")) + (handler id 'output work "" out err) + (handler id 'done work "" "" "")) #t])] + [(list 'ADD fn) + (unless (hash-ref seen fn #f) + (set! filelist (cons fn filelist)) + (set! seen (hash-set seen fn #t))) + #f] [else - (handler 'fatalerror (format "Error matching work: ~a queue ~a" work filelist) "" "") #t])) + (handler id 'fatalerror (format "Error matching work: ~a queue ~a" work filelist) "" "") #t])) (define/public (get-job workerid) (match filelist [(cons hd tail) - (define-values (dir file b) (split-path hd)) - (set! filelist tail) - (values hd (list (->bytes hd) (dir->bytes dir) (->bytes file) null))] + (define-values (dir file b) (split-path hd)) + (set! filelist tail) + (handler workerid 'start hd "" "" "") + (values hd (list (->bytes hd) (dir->bytes dir) (->bytes file) null))] [(list) null])) (define/public (has-jobs?) (not (null? filelist))) (define/public (jobs-cnt) (length filelist)) @@ -252,6 +267,7 @@ (define cop (current-output-port)) (define cep (current-error-port)) (define (send/recv msg) (send/msg msg) (recv/req)) + (define (send/add fn) (send/msg (list 'ADD fn))) (define (send/resp type) (send/msg (list type (get-output-string out-str-port) (get-output-string err-str-port)))) (define (pp x) (fprintf cep "COMPILING ~a ~a ~a ~a\n" worker-id name file x)) @@ -289,7 +305,13 @@ [current-error-port err-str-port] ;[manager-compile-notify-handler pp] ) - (cmc (build-path dir file))) + + ;; Watch for module-prefetch events, and queue jobs in response + (define t (start-prefetch-thread send/add)) + + (cmc (build-path dir file)) + + (kill-thread t)) (send/resp 'DONE))] [x (send/error (format "DIDNT MATCH A ~v\n" x))] [else (send/error (format "DIDNT MATCH A\n"))])))) @@ -304,3 +326,39 @@ (setup-fprintf (current-output-port) #f "--- parallel build using ~a jobs ---" worker-count) (define collects-queue (make-object collects-queue% collects-tree setup-fprintf append-error '())) (parallel-build collects-queue worker-count)) + +(define (start-prefetch-thread send/add) + (define pf (make-log-receiver (current-logger) 'info 'module-prefetch)) + (thread + (lambda () + (let loop () + (let ([v (sync pf)]) + (define l (vector-ref v 2)) + (when (and (list? l) + (= 2 (length l)) + (list? (car l)) + (path? (cadr l)) + (andmap module-path? (car l))) + (define dir (cadr l)) + (define (quote? p) (and (pair? p) (eq? (car p) 'quote))) + (define (submod? p) (and (pair? p) (eq? (car p) 'submod))) + ;; Add prefetch modules to work queue --- but skip the first one, + ;; because it's going to be compiled immediately, anyway: + (for/fold ([prev #f]) ([p (in-list (reverse (car l)))]) + (cond + [(or (quote? p) + (and (submod? p) (quote? (cadr p)))) + ;; skip `quote` module paths + prev] + [else + (when prev + (define path + (let loop ([prev prev]) + (cond + [(submod? prev) + (loop (cadr prev))] + [else (resolve-module-path prev (build-path dir "dummy.rkt"))]))) + (when (path? path) + (send/add path))) + p]))) + (loop)))))) diff --git a/racket/collects/syntax/modresolve.rkt b/racket/collects/syntax/modresolve.rkt index 6980a3efe7..fe351ec6b2 100644 --- a/racket/collects/syntax/modresolve.rkt +++ b/racket/collects/syntax/modresolve.rkt @@ -35,7 +35,8 @@ (define (path-ss->rkt p) (let-values ([(base name dir?) (split-path p)]) - (if (regexp-match #rx"[.]ss$" (path->bytes name)) + (if (and (path? name) + (regexp-match #rx"[.]ss$" (path->bytes name))) (path-replace-suffix p #".rkt") p)))