call-with-atomic-output-file: option to make Windows moves more atomic
It most cases, it's more important for `compiler/cm` to reliably replace a file that might be busy than to make the file update atomic. To suport that kind of use, `call-with-atomic-output-file` implemented a fairly reliable, multi-step, non-atomic process for replacing a file on Windows. For recompilation of bytecode in machine-independent form, however, `compiler/cm` now really wants to atomically write a replacement bytecode file. That's not generally possible on Windows (except on NTFS with transactions, which are discouraged...), but MoveFileEx work atomically in some cases and it's likely to work for the cases needed by `compiler/cm`. Probably. So, add a mode to `call-with-atomic-output-file` to get "more atomic" updates on Windows. This mode is enabled by a callback that makes the caller responsible for deciding what to do with the move fails, such as waiting a while and trying again. And `compiler/cm` now waits a while and tries again, up to a limit, which should be good enough for recompilation.
This commit is contained in:
parent
b68866db0f
commit
5f940e462e
|
@ -1240,14 +1240,17 @@ needed.}
|
|||
|
||||
@defproc[(call-with-atomic-output-file [file path-string?]
|
||||
[proc ([port output-port?] [tmp-path path?] . -> . any)]
|
||||
[#:security-guard security-guard (or/c #f security-guard?) #f])
|
||||
[#:security-guard security-guard (or/c #f security-guard?) #f]
|
||||
[#:rename-fail-handler rename-fail-handler (or/c #f (exn:fail:filesystem? path> . -> . any)) #f])
|
||||
any]{
|
||||
|
||||
Opens a temporary file for writing in the same directory as
|
||||
@racket[file], calls @racket[proc] to write to the temporary file, and
|
||||
then atomically moves the temporary file in place of @racket[file].
|
||||
The atomic move simply uses @racket[rename-file-or-directory] on Unix
|
||||
and Mac OS, but it uses an extra rename step (see below) on Windows
|
||||
then atomically (except on Windows) moves the temporary file in place of @racket[file].
|
||||
The move simply uses @racket[rename-file-or-directory] on Unix
|
||||
and Mac OS, and it uses @racket[rename-file-or-directory] on Windows
|
||||
if @racket[rename-fail-handler] is provided; otherwise, on Windows,
|
||||
the moves uses an extra rename step (see below) on Windows
|
||||
to avoid problems due to concurrent readers of @racket[file].
|
||||
|
||||
The @racket[proc] function is called with an output port for the
|
||||
|
@ -1259,11 +1262,24 @@ temporary files on exceptions.
|
|||
|
||||
Windows prevents programs from deleting or replacing files that are
|
||||
open, but it allows renaming of open files. Therefore, on Windows,
|
||||
@racket[call-with-atomic-output-file] creates a second temporary file
|
||||
@racket[_extra-tmp-file], renames @racket[file] to
|
||||
@racket[call-with-atomic-output-file] by default creates a second
|
||||
temporary file @racket[_extra-tmp-file], renames @racket[file] to
|
||||
@racket[_extra-tmp-file], renames the temporary file written by
|
||||
@racket[proc] to @racket[file], and finally deletes
|
||||
@racket[_extra-tmp-file].}
|
||||
@racket[_extra-tmp-file]. Since that process is not atomic, however,
|
||||
@racket[rename-file-or-directory] is used if
|
||||
@racket[rename-fail-handler] is provided, where
|
||||
@racket[rename-file-or-directory] has some chance of being atomic,
|
||||
since that the source and destination of the moves will be in the same
|
||||
directory; any filesystem exception while attempting to rename the
|
||||
file is send to @racket[rename-fail-handler], which can
|
||||
re-@racket[raise] the exception or simply return to try again, perhaps
|
||||
after a delay. In addition to a filesystem exception, the
|
||||
@racket[rename-fail-handler] procedure also receives the temporary
|
||||
file path to be moved to @racket[path]. The
|
||||
@racket[rename-fail-handler] argument is used only on Windows.
|
||||
|
||||
@history[#:changed "7.1.0.6" @elem{Added the @racket[#:rename-fail-handler] argument.}]}
|
||||
|
||||
|
||||
@defproc[(get-preference [name symbol?]
|
||||
|
|
|
@ -173,7 +173,14 @@
|
|||
;; Attempt to delete, but give up if it doesn't work:
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
(when noisy? (trace-printf "deleting ~a" path))
|
||||
(with-compiler-security-guard (delete-file path))))
|
||||
(with-compiler-security-guard (delete-file* path))))
|
||||
|
||||
(define (delete-file* path)
|
||||
(if (eq? 'windows (system-type))
|
||||
;; Using `delete-directory/files` tries deleting by first moving
|
||||
;; to the temporary folder:
|
||||
(delete-directory/files path #:must-exist? #f)
|
||||
(delete-file path)))
|
||||
|
||||
(define (compilation-failure path->mode roots path zo-name keep-zo-name date-path reason)
|
||||
(unless (equal? zo-name keep-zo-name)
|
||||
|
@ -185,7 +192,29 @@
|
|||
(call-with-atomic-output-file
|
||||
path
|
||||
#:security-guard (pick-security-guard)
|
||||
proc))
|
||||
proc
|
||||
;; On Windows, if some other process/place is reading the file, then
|
||||
;; an atomic move cannot succeed. Pause and try again, up to a point,
|
||||
;; then give up on atomicity.
|
||||
#:rename-fail-handler (let ([amt 0.01])
|
||||
(lambda (exn tmp-path)
|
||||
(cond
|
||||
[(and amt
|
||||
(eq? 'windows (system-type))
|
||||
(exn:fail:filesystem:errno? exn)
|
||||
(let ([errno (exn:fail:filesystem:errno-errno exn)])
|
||||
(and (eq? 'windows (cdr errno))
|
||||
(eqv? (car errno) 5)))) ; ERROR_ACCESS_DENIED
|
||||
(cond
|
||||
[(< amt 0.5)
|
||||
(sleep amt)
|
||||
(set! amt (* 2 amt))]
|
||||
[else
|
||||
;; Give up an atomicity
|
||||
(try-delete-file path)
|
||||
;; And give up on trying to handle errors
|
||||
(set! amt #f)])]
|
||||
[else (raise exn)])))))
|
||||
|
||||
(define-syntax-rule
|
||||
(with-compiler-security-guard expr)
|
||||
|
@ -1047,7 +1076,7 @@
|
|||
(define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo"))
|
||||
(when (file-exists? to-delete)
|
||||
(trace-printf "deleting: ~s" to-delete)
|
||||
(with-compiler-security-guard (delete-file to-delete))))]
|
||||
(with-compiler-security-guard (delete-file* to-delete))))]
|
||||
[(if cp->m
|
||||
(not (equal? (current-path->mode) cp->m))
|
||||
(let ([current-cfp (use-compiled-file-paths)])
|
||||
|
|
|
@ -235,7 +235,8 @@
|
|||
;; the file is reliably deleted if there's a break.
|
||||
(define (call-with-atomic-output-file path
|
||||
proc
|
||||
#:security-guard [guard #f])
|
||||
#:security-guard [guard #f]
|
||||
#:rename-fail-handler [rename-fail-handler #f])
|
||||
(unless (path-string? path)
|
||||
(raise-argument-error 'call-with-atomic-output-file "path-string?" path))
|
||||
(unless (and (procedure? proc)
|
||||
|
@ -244,6 +245,10 @@
|
|||
(unless (or (not guard)
|
||||
(security-guard? guard))
|
||||
(raise-argument-error 'call-with-atomic-output-file "(or/c #f security-guard?)" guard))
|
||||
(unless (or (not rename-fail-handler)
|
||||
(procedure? rename-fail-handler)
|
||||
(procedure-arity-includes? rename-fail-handler 2))
|
||||
(raise-argument-error 'call-with-atomic-output-file "(or/c #f (procedure-arity-includes/c 2))" rename-fail-handler))
|
||||
(define (try-delete-file path [noisy? #t])
|
||||
;; Attempt to delete, but give up if it doesn't work:
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
|
@ -268,13 +273,28 @@
|
|||
(lambda ()
|
||||
(parameterize ([current-security-guard (or guard (current-security-guard))])
|
||||
(if ok?
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(try-delete-file tmp-path)
|
||||
(raise exn))])
|
||||
(if (eq? (system-type) 'windows)
|
||||
(cond
|
||||
[rename-fail-handler
|
||||
(let loop ()
|
||||
(with-handlers* ([exn:fail:filesystem?
|
||||
(lambda (exn)
|
||||
(call-with-break-parameterization
|
||||
bp
|
||||
(lambda () (rename-fail-handler exn tmp-path)))
|
||||
(loop))])
|
||||
(rename-file-or-directory tmp-path path #t)
|
||||
void))]
|
||||
[else
|
||||
(let ([tmp-path2 (make-temporary-file "tmp~a" #f (path-only path))])
|
||||
(with-handlers ([exn:fail:filesystem? void])
|
||||
(rename-file-or-directory path tmp-path2 #t))
|
||||
(rename-file-or-directory tmp-path path #t)
|
||||
(try-delete-file tmp-path2))
|
||||
(rename-file-or-directory tmp-path path #t))
|
||||
(try-delete-file tmp-path2))])
|
||||
(rename-file-or-directory tmp-path path #t)))
|
||||
(try-delete-file tmp-path)))))))
|
||||
|
||||
(define (with-pref-params thunk)
|
||||
|
|
Loading…
Reference in New Issue
Block a user