raco make: improve parallelism

The `require` macro now logs "prefetch" messages when it sees a `require`
with multiple module paths. The prefix information is approximate, since
parsing a `require` subform might depend on imports from a previous subform,
but in the common case, there are many obvious module paths to prefetch.

The parallel mode of `raco make` watches for prefetch messages and
records the suggested "prefetch" paths so they can be compiled by other
processes.

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)
@@ -98,14 +99,18 @@
                         dest)))))))]
   ;; Parallel make:
   [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))]
+                      ['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))]
-                      ['output (printf " Output from: ~a\n~a~a" work out err)]
+                      ['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))]
-                      [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)]))
+                      ['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)

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 ...)]{
 

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

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,29 +201,40 @@
     (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 id 'output work "" out err)
-                (handler 'done work "" "" ""))
+                (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)
+           (handler workerid 'start hd "" "" "")
            (values hd (list (->bytes hd) (dir->bytes dir) (->bytes file) null))]
           [(list) null]))
       (define/public (has-jobs?) (not (null? 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))))))

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)))