diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index c507351762..a94836a11f 100644 --- a/collects/compiler/cm.rkt +++ b/collects/compiler/cm.rkt @@ -1,14 +1,15 @@ -#lang scheme/base +#lang racket/base (require syntax/modcode syntax/modresolve syntax/modread setup/main-collects unstable/file - scheme/file - scheme/list - scheme/path + racket/file + racket/list + racket/path racket/promise - openssl/sha1) + openssl/sha1 + racket/place) (provide make-compilation-manager-load/use-compiled-handler managed-compile-zo @@ -22,7 +23,10 @@ get-file-sha1 get-compiled-file-sha1 with-compile-output - parallel-lock-client) + parallel-lock-client + + make-compile-lock + compile-lock->parallel-lock-client) (define manager-compile-notify-handler (make-parameter void)) (define trace (make-parameter void)) @@ -649,3 +653,46 @@ (define (get-file-sha1 path) (get-source-sha1 path)) + +(define (make-compile-lock) + (define-values (manager-side-chan build-side-chan) (place-channel)) + (struct pending (response-chan bytes)) + + (define currently-locked-files (make-hash)) + (define pending-requests '()) + + (thread + (λ () + (let loop () + (define req (place-channel-get manager-side-chan)) + (define command (list-ref req 0)) + (define bytes (list-ref req 1)) + (define response-manager-side (list-ref req 2)) + (cond + [(eq? command 'lock) + (cond + [(hash-ref currently-locked-files bytes #f) + (set! pending-requests (cons (pending response-manager-side bytes) + pending-requests)) + (loop)] + [else + (hash-set! currently-locked-files bytes #t) + (place-channel-put response-manager-side #t) + (loop)])] + [(eq? command 'unlock) + (define (same-bytes? pending) (equal? (pending-bytes pending) bytes)) + (define to-unlock (filter same-bytes? pending-requests)) + (set! pending-requests (filter (compose not same-bytes?) pending-requests)) + (for ([pending (in-list to-unlock)]) + (place-channel-put (pending-response-chan pending) #f)) + (hash-remove! currently-locked-files bytes) + (loop)])))) + + build-side-chan) + +(define (compile-lock->parallel-lock-client build-side-chan) + (λ (command zo-path) + (define-values (response-builder-side response-manager-side) (place-channel)) + (place-channel-put build-side-chan (list command zo-path response-manager-side)) + (when (eq? command 'lock) + (place-channel-get response-builder-side)))) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 2221e58344..79bb967e1a 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -271,6 +271,7 @@ (cons (build-path "compiled" "drracket" "errortrace") (use-compiled-file-paths)))])) + (parallel-lock-client module-language-parallel-lock-client) (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler #t)) (let* ([cd (find-collects-dir)] [no-dirs (if cd @@ -872,4 +873,9 @@ [else (loop (+ pos 1))])))) - (super-new)))) + (super-new))) + + + (define module-language-parallel-lock-client + (compile-lock->parallel-lock-client + (make-compile-lock)))) diff --git a/collects/scribblings/raco/make.scrbl b/collects/scribblings/raco/make.scrbl index 0129626d97..e93b6b1f65 100644 --- a/collects/scribblings/raco/make.scrbl +++ b/collects/scribblings/raco/make.scrbl @@ -273,6 +273,7 @@ A parameter whose value is called for each file that is loaded and @racket[#f], then the file is compiled as usual. The default is @racket[(lambda (x) #f)].} + @defproc[(file-stamp-in-collection [p path?]) (or/c (cons/c number? promise?) #f)]{ Calls @racket[file-stamp-in-paths] with @racket[p] and @racket[(current-library-collection-paths)].} @@ -321,12 +322,25 @@ windows, @racket[with-compile-output] creates a second temporary file @racket[tmp-path2], renames @racket[p] to @racket[tmp-path2], renames @racket[tmp-path] to @racket[p], and finally deletes @racket[tmp-path2].} -@defparam[parallel-lock-client proc ([command (or/c 'lock 'unlock)] [zo-path bytes?] . -> . boolean?)]{ +@defparam[parallel-lock-client proc + (or/c #f + (->i ([command (or/c 'lock 'unlock)] + [file bytes?]) + [res (command) (if (eq? command 'lock) + boolean? + void?)]))]{ -Holds the parallel compilation lock client, which prevents compilation races -between parallel builders. The @racket[proc] function takes a command argument -of either @racket['lock] or @racket['unlock]. The @racket[zo-path] argument -specifies the path of the zo for which compilation should be locked. +Holds the parallel compilation lock client, which +is used by the result of @racket[make-compilation-manager-load/use-compiled-handler] to +prevent compilation races between parallel builders. + +When @racket[proc] is @racket[#f] (the default), no checking for parallel +compilation is done (and thus multiple threads or places running compilations +via @racket[make-compilation-manager-load/use-compiled-handler] will potentially +corrupt each other's @filepath{.zo} files). + +When @racket[proc] is a function, its first argument is a command, indicating +if it wants to lock or unlock the path specified in the second argument. When the @racket[proc] @racket['lock] command returns @racket[#t], the current builder has obtained the lock for @racket[zo-path]. @@ -336,7 +350,9 @@ release the lock by calling @racket[proc] @racket['unlock] with the exact same When the @racket[proc] @racket['lock] command returns @racket[#f], another parallel builder obtained the lock first and has already compiled the zo. The -parallel builder should continue without compiling @racket[zo-path]. +parallel builder should continue without compiling @racket[zo-path]. +(In this case, @racket[make-compilation-manager-load/use-compiled-handler]'s +result will not call @racket[proc] with @racket['unlock].) @examples[ #:eval cm-eval @@ -354,6 +370,22 @@ parallel builder should continue without compiling @racket[zo-path]. (lc 'unlock zo-name))))) ] } + +@defproc[(compile-lock->parallel-lock-client [pc place-channel?]) + (-> (or/c 'lock 'unlock) bytes? boolean?)]{ + + Returns a function that follows the @racket[parallel-lock-client] + by communicating over @racket[pc]. The argument must have + be the result of @racket[make-compile-lock]. +} + +@defproc[(make-compile-lock) place-channel?]{ + Creates a @racket[place-channel?] that can be used with + @racket[compile-lock->parallel-lock-client] to avoid concurrent + compilations of the same racket source files in multiple places. +} + + @; ---------------------------------------------------------------------- @section[#:tag "api:parallel-build"]{API for Parallel-Build}