Adding more race condition protection to the compiler for DrDr and parallel setup-plt

svn: r18103

collects/compiler/cm.ss

@@ -3,6 +3,7 @@
          syntax/modresolve
          setup/main-collects
          scheme/file
+         unstable/file
          scheme/list
          scheme/path)
 
@@ -117,19 +118,30 @@
   (trace-printf "failure"))
 
 ;; with-compile-output : path (output-port -> alpha) -> alpha
-;;  Open path for writing, and arranges to delete path if there's
+;;  Open a temporary path for writing, automatically renames after,
+;;  and arranges to delete path if there's
 ;;  an exception. Breaks are managed so that the port is reliably
 ;;  closed and the file is reliably deleted if there's a break
 (define (with-compile-output path proc)
-  (let ([bp (current-break-parameterization)])
+  (let ([bp (current-break-parameterization)]
-    (with-handlers ([void (lambda (exn) (try-delete-file path) (raise exn))])
+        [tmp-path (make-temporary-file "tmp~a" #f (path-only path))]
-      (let ([out (open-output-file path #:exists 'truncate/replace)])
+        [ok? #f])
     (dynamic-wind
      void
      (lambda ()
-            (call-with-break-parameterization bp (lambda () (proc out))))
+       (begin0
+         (let ([out (open-output-file tmp-path #:exists 'truncate/replace)])
+           (dynamic-wind
+            void
             (lambda ()
-            (close-output-port out)))))))
+              (call-with-break-parameterization bp (lambda () (proc out tmp-path))))
+            (lambda ()
+              (close-output-port out))))
+         (set! ok? #t)))
+     (lambda ()
+       (if ok?
+           (rename-file-or-directory/ignore-exists-exn tmp-path path)
+           (try-delete-file tmp-path))))))
 
 (define (write-deps code mode path external-deps reader-deps)
   (let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")]
@@ -137,7 +149,7 @@
                                          reader-deps))]
         [external-deps (remove-duplicates external-deps)])
     (with-compile-output dep-path
-      (lambda (op)
+      (lambda (op tmp-path)
         (write `(,(version)
                  ,@(map path->main-collects-relative deps)
                  ,@(map (lambda (x)
@@ -239,9 +251,9 @@
 
   ;; Write the code and dependencies:
   (when code
-    (make-directory* code-dir)
+    (make-directory*/ignore-exists-exn code-dir)
     (with-compile-output zo-name
-      (lambda (out)
+      (lambda (out tmp-name)
         (with-handlers ([exn:fail?
                          (lambda (ex)
                            (close-output-port out)
@@ -258,7 +270,7 @@
         (close-output-port out)
         ;; Note that we check time and write .deps before returning from
         ;; with-compile-output...
-        (verify-times path zo-name)
+        (verify-times path tmp-name)
         (write-deps code mode path external-deps reader-deps)))))
 
 (define depth (make-parameter 0))

collects/mzlib/compile.ss

@@ -1,14 +1,15 @@
 #lang scheme/base
 (require scheme/function
          scheme/path
-         scheme/file)
+         scheme/file
+         unstable/file)
 (provide compile-file)
 
 (define compile-file
   (case-lambda
     [(src)
      (define cdir (build-path (path-only src) "compiled"))
-     (make-directory* cdir)
+     (make-directory*/ignore-exists-exn cdir)
      (compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))]
     [(src dest) 
      (compile-file src dest values)]
@@ -55,7 +56,7 @@
                 (close-output-port out)))))
          (lambda ()
            (if ok?
-               (rename-file-or-directory temp-filename dest)
+               (rename-file-or-directory/ignore-exists-exn temp-filename dest)
                (with-handlers ([exn:fail:filesystem? void])
                  (delete-file temp-filename))))))
       (lambda () (close-input-port in)))

collects/unstable/file.ss

@@ -0,0 +1,24 @@
+#lang scheme/base
+; Responsible: Jay McCarthy
+(require scheme/contract)
+
+(define (exn:fail:filesystem:exists? x)
+  (and (exn:fail:filesystem? x)
+       (regexp-match #rx"exists" (exn-message x))))
+
+(define (make-directory*/ignore-exists-exn dir)
+  (let-values ([(base name dir?) (split-path dir)])
+    (when (and (path? base)
+               (not (directory-exists? base)))
+      (make-directory*/ignore-exists-exn base))
+    (unless (directory-exists? dir)
+      (with-handlers ([exn:fail:filesystem:exists? void])
+        (make-directory dir)))))
+
+(define (rename-file-or-directory/ignore-exists-exn from to)
+  (with-handlers ([exn:fail:filesystem:exists? void])
+    (rename-file-or-directory from to)))
+
+(provide/contract
+ [make-directory*/ignore-exists-exn (path-string? . -> . void)]
+ [rename-file-or-directory/ignore-exists-exn (path-string? path-string? . -> . void)])

collects/unstable/scribblings/file.scrbl

@@ -0,0 +1,24 @@
+#lang scribble/doc
+@(require scribble/base
+          scribble/manual
+          "utils.ss"
+          (for-label unstable/file
+                     scheme/file
+                     scheme/contract
+                     scheme/base))
+
+@title[#:tag "file"]{Filesystem}
+
+@defmodule[unstable/file]
+
+@unstable[@author+email["Jay McCarthy" "jay@plt-scheme.org"]]
+
+@defproc[(make-directory*/ignore-exists-exn [pth path-string?])
+         void]{
+ Like @scheme[make-directory*], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create directories.
+}
+              
+@defproc[(rename-file-or-directory/ignore-exists-exn [from path-string?] [to path-string?])
+         void]{
+ Like @scheme[rename-file-or-directory], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create files.
+}

collects/unstable/scribblings/unstable.scrbl

@@ -74,6 +74,7 @@ Keep documentation and tests up to date.
 @include-section["bytes.scrbl"]
 @include-section["contract.scrbl"]
 @include-section["exn.scrbl"]
+@include-section["file.scrbl"]
 @include-section["list.scrbl"]
 @include-section["net.scrbl"]
 @include-section["path.scrbl"]