add support for thread-safe compilation to compiler/cm (and use it in drracket)

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
+         racket/file
-         scheme/list
+         racket/list
-         scheme/path
+         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))))

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

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
+Holds the parallel compilation lock client, which
-between parallel builders.  The @racket[proc] function takes a command argument
+is used by the result of @racket[make-compilation-manager-load/use-compiled-handler] to
-of either @racket['lock] or @racket['unlock].  The @racket[zo-path] argument
+prevent compilation races between parallel builders.  
-specifies the path of the zo for which compilation should be locked.
+
+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}