raco setup: repair more problems with multi-cross mode
Fix some race conditions involving concurrent setup tasks that are each trying to generate both machine-independent bytecode and machine-specific bytecode.
This commit is contained in:
Matthew Flatt
parent
b38ce36c92
commit
6d8596bae3
|
|
@ -776,7 +776,8 @@ See also @racket[managed-compile-zo].}
|
|||
|
||||
@defproc[(get-compilation-dir+name [path path-string?]
|
||||
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)]
|
||||
[#:default-root default-root (or/c path-string? 'same) (car roots)])
|
||||
(values path? path?)]{
|
||||
|
||||
Determines the directory that holds the bytecode form of @racket[path]
|
||||
|
|
@ -787,24 +788,32 @@ for each element of @racket[roots] checking @racket[modes] in order.
|
|||
The first such directory that contains a file whose name matches
|
||||
@racket[path] with @filepath{.zo} added (in the sense of
|
||||
@racket[path-add-suffix]) is reported as the return directory path.
|
||||
If no such file is found, the result corresponds to the first elements
|
||||
of @racket[modes] and @racket[roots].}
|
||||
If no such file is found, the result corresponds to the first element
|
||||
of @racket[modes] combined with @racket[default-roots].
|
||||
|
||||
@history[#:changed "7.1.0.9" @elem{Added the @racket[#:default-root] argument.}]}
|
||||
|
||||
@defproc[(get-compilation-dir [path path-string?]
|
||||
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)]
|
||||
[#:default-root default-root (or/c path-string? 'same) (car roots)])
|
||||
path?]{
|
||||
|
||||
The same as @racket[get-compilation-dir+name], but returning only the first result.}
|
||||
The same as @racket[get-compilation-dir+name], but returning only the first result.
|
||||
|
||||
@history[#:changed "7.1.0.9" @elem{Added the @racket[#:default-root] argument.}]}
|
||||
|
||||
@defproc[(get-compilation-bytecode-file [path path-string?]
|
||||
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
|
||||
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)]
|
||||
[#:default-root default-root (or/c path-string? 'same) (car roots)])
|
||||
path?]{
|
||||
|
||||
The same as @racket[get-compilation-dir+name], but combines the
|
||||
results and adds a @filepath{.zo} suffix to arrive at a bytecode file
|
||||
path.}
|
||||
path.
|
||||
|
||||
@history[#:changed "7.1.0.9" @elem{Added the @racket[#:default-root] argument.}]}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
get-compilation-dir
|
||||
get-compilation-bytecode-file)
|
||||
|
||||
(define (do-get-compilation-dir+name who path modes roots)
|
||||
(define (do-get-compilation-dir+name who path modes roots default-root)
|
||||
;; Check arguments
|
||||
(unless (path-string? path)
|
||||
(raise-argument-error who "path-string?" path))
|
||||
|
|
@ -21,6 +21,8 @@
|
|||
(or (path-string? p) (eq? p 'same)))
|
||||
roots))
|
||||
(raise-argument-error who "(non-empty-listof (or/c path-string? 'same))" roots))
|
||||
(unless (or (eq? default-root 'same) (path-string? default-root))
|
||||
(raise-argument-error who "(or/c path-string? 'same)" default-root))
|
||||
;; Function to try one combination:
|
||||
(define (get-one mode root)
|
||||
(let-values ([(base name must-be-dir?) (split-path path)])
|
||||
|
|
@ -37,7 +39,8 @@
|
|||
mode)])
|
||||
name)))
|
||||
;; Try first root:
|
||||
(define-values (p n) (get-one (car modes) (car roots)))
|
||||
(define orig-root (car roots))
|
||||
(define-values (p n) (get-one (car modes) orig-root))
|
||||
(if (or (and (null? (cdr roots))
|
||||
(null? (cdr modes)))
|
||||
(file-exists? (path-add-suffix (build-path p n) #".zo")))
|
||||
|
|
@ -46,8 +49,10 @@
|
|||
(let loop ([roots (cdr roots)])
|
||||
(cond
|
||||
[(null? roots)
|
||||
;; No roots worked, so assume the first mode + root:
|
||||
(values p n)]
|
||||
;; No roots worked, so use the default root
|
||||
(if (equal? default-root orig-root)
|
||||
(values p n)
|
||||
(get-one (car modes) default-root))]
|
||||
[else
|
||||
;; Check next root:
|
||||
(let mloop ([modes modes])
|
||||
|
|
@ -61,17 +66,20 @@
|
|||
|
||||
(define (get-compilation-dir+name path
|
||||
#:modes [modes (use-compiled-file-paths)]
|
||||
#:roots [roots (current-compiled-file-roots)])
|
||||
(do-get-compilation-dir+name 'get-compilation-dir+name path modes roots))
|
||||
#:roots [roots (current-compiled-file-roots)]
|
||||
#:default-root [default-root (and (pair? roots) (car roots))])
|
||||
(do-get-compilation-dir+name 'get-compilation-dir+name path modes roots default-root))
|
||||
|
||||
(define (get-compilation-dir path
|
||||
#:modes [modes (use-compiled-file-paths)]
|
||||
#:roots [roots (current-compiled-file-roots)])
|
||||
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-dir path modes roots)])
|
||||
#:roots [roots (current-compiled-file-roots)]
|
||||
#:default-root [default-root (and (pair? roots) (car roots))])
|
||||
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-dir path modes roots default-root)])
|
||||
dir))
|
||||
|
||||
(define (get-compilation-bytecode-file path
|
||||
#:modes [modes (use-compiled-file-paths)]
|
||||
#:roots [roots (current-compiled-file-roots)])
|
||||
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-bytecode-file path modes roots)])
|
||||
#:roots [roots (current-compiled-file-roots)]
|
||||
#:default-root [default-root (and (pair? roots) (car roots))])
|
||||
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-bytecode-file path modes roots default-root)])
|
||||
(build-path dir (path-add-suffix name #".zo"))))
|
||||
|
|
|
|||
|
|
@ -157,7 +157,17 @@
|
|||
(define deps-imports cdddr)
|
||||
|
||||
(define (get-compilation-path path->mode roots path)
|
||||
(let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)])
|
||||
(let-values ([(dir name) (get-compilation-dir+name path
|
||||
#:modes (list (path->mode path))
|
||||
#:roots roots
|
||||
;; In cross-multi mode, we need to default to the
|
||||
;; ".zo" file that is written first, otherwise we
|
||||
;; may pick the first root where there's no ".dep"
|
||||
;; written yet when the second root on has a ".dep"
|
||||
;; and the ".zo" is not yet in place
|
||||
#:default-root (if (cross-multi-compile? roots)
|
||||
(cadr roots)
|
||||
(car roots)))])
|
||||
(build-path dir name)))
|
||||
|
||||
(define (touch path)
|
||||
|
|
@ -233,7 +243,7 @@
|
|||
(get-source-sha1 (path-replace-extension p #".ss"))))])
|
||||
(call-with-input-file* p sha1)))
|
||||
|
||||
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots seen
|
||||
(define (get-dep-sha1s for-path deps up-to-date collection-cache read-src-syntax path->mode roots seen
|
||||
#:must-exist? must-exist?)
|
||||
(let ([l (for/fold ([l null]) ([dep (in-list deps)])
|
||||
(and l
|
||||
|
|
@ -256,7 +266,9 @@
|
|||
;; apparently, we're forced to use the source of the module,
|
||||
;; so compute a sha1 from it instead of the bytecode
|
||||
(cons (cons (get-source-sha1 p) dep) l)]
|
||||
[else #f]))))])
|
||||
[else
|
||||
(trace-printf "no hash available toward ~a: ~a" for-path p)
|
||||
#f]))))])
|
||||
(and l
|
||||
(let ([p (open-output-string)]
|
||||
[l (map (lambda (v)
|
||||
|
|
@ -296,7 +308,8 @@
|
|||
(write (list* (version)
|
||||
(current-compile-target-machine)
|
||||
(cons (or src-sha1 (get-source-sha1 path))
|
||||
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #hash()
|
||||
(get-dep-sha1s path
|
||||
deps up-to-date collection-cache read-src-syntax path->mode roots #hash()
|
||||
#:must-exist? #t))
|
||||
(sort deps s-exp<?))
|
||||
op)
|
||||
|
|
@ -343,7 +356,7 @@
|
|||
|
||||
(define (cross-multi-compile? roots)
|
||||
;; Combination of cross-installation mode, compiling to machine-independent form,
|
||||
;; and multiple compiled-file roots triggers a special mutli-target compilation mode.
|
||||
;; and multiple compiled-file roots triggers a special multi-target compilation mode.
|
||||
;; Write code compiled for the running Racket to the first root, and write code for
|
||||
;; the cross-compile target to the second root --- but count the cross-compile target
|
||||
;; as machine-independent if it would be the same as the current target.
|
||||
|
|
@ -547,6 +560,7 @@
|
|||
;; with-compile-output...
|
||||
(verify-times path tmp-name)
|
||||
(when (equal? recompile-from zo-name)
|
||||
(trace-printf "recompiling in-place: ~a" zo-name)
|
||||
;; In the case of recompiling, make sure that any concurrent
|
||||
;; process always sees recompile possibilities by writing
|
||||
;; the expected sha1 into ".dep" before deleting the ".zo"
|
||||
|
|
@ -646,7 +660,7 @@
|
|||
;; Beware that if a ".dep" file provides a SHA-1 for the generated
|
||||
;; bytecode (because the bytecode was once recompiled from
|
||||
;; machine-independent bytecode) but the bytecode file isn't present,
|
||||
;; then dependent files will assume that compiling will produce te
|
||||
;; then dependent files will assume that compiling will produce the
|
||||
;; same SHA-1. That limitation is necessary to avoid recompilation
|
||||
;; when one concurrent processes is recompiling and other processes
|
||||
;; are checking whether they can use or merely recompile existing
|
||||
|
|
@ -745,6 +759,7 @@
|
|||
(equal? (version) (deps-version deps))
|
||||
(deps-src-sha1 deps)
|
||||
(get-source-sha1 path)))
|
||||
(define-syntax-rule (explain v e) (or v (and e #f)))
|
||||
(cond
|
||||
[(and (not src-sha1)
|
||||
(not (file-exists? actual-path)))
|
||||
|
|
@ -764,15 +779,27 @@
|
|||
(cond
|
||||
[trying-sha1? #f]
|
||||
[else (build/sync)])])]
|
||||
[(and src-sha1
|
||||
(equal? (version) (deps-version deps))
|
||||
(equal? src-sha1 (and (pair? (deps-sha1s deps))
|
||||
(deps-src-sha1 deps)))
|
||||
(equal? (get-dep-sha1s (deps-imports deps) up-to-date collection-cache read-src-syntax path->mode roots seen
|
||||
#:must-exist? #f)
|
||||
(deps-imports-sha1 deps))
|
||||
(or (eq? (deps-machine deps) (current-compile-target-machine))
|
||||
(not (deps-machine deps))))
|
||||
[(and (explain src-sha1
|
||||
(trace-printf "no source hash: ~a" path))
|
||||
(explain (equal? (version) (deps-version deps))
|
||||
(trace-printf "different version: ~a" path))
|
||||
(explain (equal? src-sha1 (and (pair? (deps-sha1s deps))
|
||||
(deps-src-sha1 deps)))
|
||||
(trace-printf "source hash changed: ~a" path))
|
||||
(explain (or (eq? (deps-machine deps) (current-compile-target-machine))
|
||||
(not (deps-machine deps))
|
||||
(and (cross-multi-compile? roots)
|
||||
(eq? (system-type 'target-machine) (deps-machine deps))))
|
||||
(trace-printf "wrong machine: ~a" path))
|
||||
(let ([imports-sha1
|
||||
(get-dep-sha1s path
|
||||
(deps-imports deps) up-to-date collection-cache read-src-syntax path->mode roots seen
|
||||
#:must-exist? #f)])
|
||||
(explain (equal? imports-sha1 (deps-imports-sha1 deps))
|
||||
(trace-printf "different dependency deps for ~a: ~a ~a"
|
||||
zo-name
|
||||
imports-sha1
|
||||
(deps-imports-sha1 deps)))))
|
||||
;; We need to recompile the file from machine-independent bytecode,
|
||||
;; or maybe just update the file's modification date
|
||||
(trace-printf "hash-equivalent: ~a" zo-name)
|
||||
|
|
@ -845,6 +872,7 @@
|
|||
;; if we have to read the compiled form and that failed (e.g., because
|
||||
;; the file's not there), then return #f overall:
|
||||
(let ([sha-1 (or assume-compiled-sha1 path-sha1)])
|
||||
(trace-printf "compiled hash for ~a: ~a ~a ~a" path sha-1 (and assume-compiled-sha1 #t) imports-sha1)
|
||||
(and sha-1
|
||||
(string-append sha-1 imports-sha1))))))
|
||||
|
||||
|
|
@ -853,7 +881,12 @@
|
|||
;; falling back normally to bytecode, and returning "" insteda of
|
||||
;; #f if compiled code is not available:
|
||||
(define (get-compiled-sha1 path->mode roots path)
|
||||
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
|
||||
(define-values (dir name) (get-compilation-dir+name path
|
||||
#:modes (list (path->mode path))
|
||||
#:roots roots
|
||||
#:default-root (if (cross-multi-compile? roots)
|
||||
(cadr roots)
|
||||
(car roots))))
|
||||
(let ([dep-path (build-path dir (path-add-extension name #".dep"))])
|
||||
(or (try-file-sha1 (build-path dir "native" (system-library-subpath)
|
||||
(path-add-extension name (system-type
|
||||
|
|
@ -887,7 +920,9 @@
|
|||
#:sha1-only? [sha1-only? #f])
|
||||
(define orig-path (simple-form-path path0))
|
||||
(define (read-deps path)
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list #f "none" '(#f . #f)))])
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (ex)
|
||||
(trace-printf "failed reading ~a" path)
|
||||
(list #f "none" '(#f . #f)))])
|
||||
(with-module-reading-parameterization
|
||||
(lambda ()
|
||||
(call-with-input-file*
|
||||
|
|
@ -930,7 +965,10 @@
|
|||
(cond
|
||||
[(not (and (deps-has-version? deps)
|
||||
(equal? (version) (deps-version deps))))
|
||||
(trace-printf "newer version...")
|
||||
(trace-printf "old version ~a for ~a..."
|
||||
(and (deps-has-version? deps)
|
||||
(deps-version deps))
|
||||
path)
|
||||
#t]
|
||||
[(not (and (deps-has-machine? deps)
|
||||
(or (eq? (current-compile-target-machine) (deps-machine deps))
|
||||
|
|
@ -940,7 +978,10 @@
|
|||
(or sha1-only?
|
||||
(deps-machine deps)
|
||||
(not (cross-multi-compile? roots)))))
|
||||
(trace-printf "different machine...")
|
||||
(trace-printf "different machine ~a for ~a..."
|
||||
(and (deps-has-machine? deps)
|
||||
(deps-machine deps))
|
||||
path)
|
||||
#t]
|
||||
[(> path-time (or path-zo-time -inf.0))
|
||||
(trace-printf "newer src... ~a > ~a" path-time path-zo-time)
|
||||
|
|
@ -948,7 +989,7 @@
|
|||
#:trying-sha1? sha1-only?)]
|
||||
[(different-source-sha1-and-dep-recorded path deps)
|
||||
=> (lambda (difference)
|
||||
(trace-printf "different src hash... ~a" difference)
|
||||
(trace-printf "different src hash ~a for ~a..." difference path)
|
||||
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
|
||||
#:trying-sha1? sha1-only?))]
|
||||
[(ormap-strict
|
||||
|
|
@ -958,12 +999,13 @@
|
|||
(define t
|
||||
(if ext?
|
||||
(cons (or (try-file-time d) +inf.0) #f)
|
||||
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax new-seen)))
|
||||
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax new-seen
|
||||
#:sha1-only? sha1-only?)))
|
||||
(and t
|
||||
(car t)
|
||||
(> (car t) (or path-zo-time -inf.0))
|
||||
(begin (trace-printf "newer: ~a (~a > ~a)..."
|
||||
d (car t) path-zo-time)
|
||||
(begin (trace-printf "newer for ~a: ~a (~a > ~a)..."
|
||||
path d (car t) path-zo-time)
|
||||
#t)))
|
||||
(deps-imports deps))
|
||||
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
|
||||
|
|
|
|||
|
|
@ -1059,6 +1059,7 @@
|
|||
(define dir (cc-path cc))
|
||||
(define info (cc-info cc))
|
||||
(compile-directory-zos dir info
|
||||
#:verbose (verbose)
|
||||
#:has-module-suffix? has-module-suffix?
|
||||
#:omit-root (cc-omit-root cc)
|
||||
#:managed-compile-zo caching-managed-compile-zo
|
||||
|
|
@ -2027,6 +2028,8 @@
|
|||
(setup-printf "version" "~a" (version))
|
||||
(setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc))
|
||||
(setup-printf "target machine" "~a" (or (current-compile-target-machine) 'any))
|
||||
(when (cross-installation?)
|
||||
(setup-printf "cross-installation" "yes"))
|
||||
(setup-printf "installation name" "~a" (get-installation-name))
|
||||
(setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", "))
|
||||
(setup-printf "main collects" "~a" main-collects-dir)
|
||||
|
|
@ -2043,6 +2046,12 @@
|
|||
(setup-printf #f " ~a" p))
|
||||
(when (use-user-specific-search-paths)
|
||||
(setup-printf #f " ~a" (find-user-links-file)))
|
||||
(let ([roots (current-compiled-file-roots)])
|
||||
(unless (or (equal? roots '(same))
|
||||
(equal? roots (build-path 'same)))
|
||||
(setup-printf "compiled-file roots" "")
|
||||
(for ([p roots])
|
||||
(setup-printf #f " ~a" p))))
|
||||
(setup-printf "main docs" "~a" (find-doc-dir))
|
||||
|
||||
(when (and (not (null? (archives))) no-specific-collections?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user