suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: repair more problems with multi-cross mode

Browse Source 
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 2018-12-02 19:06:03 -07:00
parent b38ce36c92
commit 6d8596bae3
4 changed files with 108 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-doc/scribblings/raco/make.scrbl
View File

@ -776,7 +776,8 @@ See also @racket[managed-compile-zo].}
@defproc[(get-compilation-dir+name [path path-string?] @defproc[(get-compilation-dir+name [path path-string?]
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)] [#: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?)]{ (values path? path?)]{
Determines the directory that holds the bytecode form of @racket[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 The first such directory that contains a file whose name matches
@racket[path] with @filepath{.zo} added (in the sense of @racket[path] with @filepath{.zo} added (in the sense of
@racket[path-add-suffix]) is reported as the return directory path. @racket[path-add-suffix]) is reported as the return directory path.
If no such file is found, the result corresponds to the first elements If no such file is found, the result corresponds to the first element
of @racket[modes] and @racket[roots].} 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?] @defproc[(get-compilation-dir [path path-string?]
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)] [#: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?]{ 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?] @defproc[(get-compilation-bytecode-file [path path-string?]
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)] [#: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?]{ path?]{
The same as @racket[get-compilation-dir+name], but combines the The same as @racket[get-compilation-dir+name], but combines the
results and adds a @filepath{.zo} suffix to arrive at a bytecode file 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.}]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

28
racket/collects/compiler/compilation-path.rkt
View File

@ -4,7 +4,7 @@
get-compilation-dir get-compilation-dir
get-compilation-bytecode-file) 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 ;; Check arguments
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error who "path-string?" path)) (raise-argument-error who "path-string?" path))
@ -21,6 +21,8 @@
(or (path-string? p) (eq? p 'same))) (or (path-string? p) (eq? p 'same)))
roots)) roots))
(raise-argument-error who "(non-empty-listof (or/c path-string? '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: ;; Function to try one combination:
(define (get-one mode root) (define (get-one mode root)
(let-values ([(base name must-be-dir?) (split-path path)]) (let-values ([(base name must-be-dir?) (split-path path)])
@ -37,7 +39,8 @@
mode)]) mode)])
name))) name)))
;; Try first root: ;; 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)) (if (or (and (null? (cdr roots))
(null? (cdr modes))) (null? (cdr modes)))
(file-exists? (path-add-suffix (build-path p n) #".zo"))) (file-exists? (path-add-suffix (build-path p n) #".zo")))
@ -46,8 +49,10 @@
(let loop ([roots (cdr roots)]) (let loop ([roots (cdr roots)])
(cond (cond
[(null? roots) [(null? roots)
;; No roots worked, so assume the first mode + root: ;; No roots worked, so use the default root
(values p n)] (if (equal? default-root orig-root)
(values p n)
(get-one (car modes) default-root))]
[else [else
;; Check next root: ;; Check next root:
(let mloop ([modes modes]) (let mloop ([modes modes])
@ -61,17 +66,20 @@
(define (get-compilation-dir+name path (define (get-compilation-dir+name path
#:modes [modes (use-compiled-file-paths)] #:modes [modes (use-compiled-file-paths)]
#:roots [roots (current-compiled-file-roots)]) #:roots [roots (current-compiled-file-roots)]
(do-get-compilation-dir+name 'get-compilation-dir+name path modes 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 (define (get-compilation-dir path
#:modes [modes (use-compiled-file-paths)] #:modes [modes (use-compiled-file-paths)]
#:roots [roots (current-compiled-file-roots)]) #:roots [roots (current-compiled-file-roots)]
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-dir path modes 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)) dir))
(define (get-compilation-bytecode-file path (define (get-compilation-bytecode-file path
#:modes [modes (use-compiled-file-paths)] #:modes [modes (use-compiled-file-paths)]
#:roots [roots (current-compiled-file-roots)]) #:roots [roots (current-compiled-file-roots)]
(let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-bytecode-file path modes 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")))) (build-path dir (path-add-suffix name #".zo"))))

88
racket/collects/compiler/private/cm-minimal.rkt
View File

@ -157,7 +157,17 @@
(define deps-imports cdddr) (define deps-imports cdddr)
(define (get-compilation-path path->mode roots path) (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))) (build-path dir name)))
(define (touch path) (define (touch path)
@ -233,7 +243,7 @@
(get-source-sha1 (path-replace-extension p #".ss"))))]) (get-source-sha1 (path-replace-extension p #".ss"))))])
(call-with-input-file* p sha1))) (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?) #:must-exist? must-exist?)
(let ([l (for/fold ([l null]) ([dep (in-list deps)]) (let ([l (for/fold ([l null]) ([dep (in-list deps)])
(and l (and l
@ -256,7 +266,9 @@
;; apparently, we're forced to use the source of the module, ;; apparently, we're forced to use the source of the module,
;; so compute a sha1 from it instead of the bytecode ;; so compute a sha1 from it instead of the bytecode
(cons (cons (get-source-sha1 p) dep) l)] (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 (and l
(let ([p (open-output-string)] (let ([p (open-output-string)]
[l (map (lambda (v) [l (map (lambda (v)
@ -296,7 +308,8 @@
(write (list* (version) (write (list* (version)
(current-compile-target-machine) (current-compile-target-machine)
(cons (or src-sha1 (get-source-sha1 path)) (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)) #:must-exist? #t))
(sort deps s-exp<?)) (sort deps s-exp<?))
op) op)
@ -343,7 +356,7 @@
(define (cross-multi-compile? roots) (define (cross-multi-compile? roots)
;; Combination of cross-installation mode, compiling to machine-independent form, ;; 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 ;; 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 ;; 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. ;; as machine-independent if it would be the same as the current target.
@ -547,6 +560,7 @@
;; with-compile-output... ;; with-compile-output...
(verify-times path tmp-name) (verify-times path tmp-name)
(when (equal? recompile-from zo-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 ;; In the case of recompiling, make sure that any concurrent
;; process always sees recompile possibilities by writing ;; process always sees recompile possibilities by writing
;; the expected sha1 into ".dep" before deleting the ".zo" ;; 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 ;; Beware that if a ".dep" file provides a SHA-1 for the generated
;; bytecode (because the bytecode was once recompiled from ;; bytecode (because the bytecode was once recompiled from
;; machine-independent bytecode) but the bytecode file isn't present, ;; 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 ;; same SHA-1. That limitation is necessary to avoid recompilation
;; when one concurrent processes is recompiling and other processes ;; when one concurrent processes is recompiling and other processes
;; are checking whether they can use or merely recompile existing ;; are checking whether they can use or merely recompile existing
@ -745,6 +759,7 @@
(equal? (version) (deps-version deps)) (equal? (version) (deps-version deps))
(deps-src-sha1 deps) (deps-src-sha1 deps)
(get-source-sha1 path))) (get-source-sha1 path)))
(define-syntax-rule (explain v e) (or v (and e #f)))
(cond (cond
[(and (not src-sha1) [(and (not src-sha1)
(not (file-exists? actual-path))) (not (file-exists? actual-path)))
@ -764,15 +779,27 @@
(cond (cond
[trying-sha1? #f] [trying-sha1? #f]
[else (build/sync)])])] [else (build/sync)])])]
[(and src-sha1 [(and (explain src-sha1
(equal? (version) (deps-version deps)) (trace-printf "no source hash: ~a" path))
(equal? src-sha1 (and (pair? (deps-sha1s deps)) (explain (equal? (version) (deps-version deps))
(deps-src-sha1 deps))) (trace-printf "different version: ~a" path))
(equal? (get-dep-sha1s (deps-imports deps) up-to-date collection-cache read-src-syntax path->mode roots seen (explain (equal? src-sha1 (and (pair? (deps-sha1s deps))
#:must-exist? #f) (deps-src-sha1 deps)))
(deps-imports-sha1 deps)) (trace-printf "source hash changed: ~a" path))
(or (eq? (deps-machine deps) (current-compile-target-machine)) (explain (or (eq? (deps-machine deps) (current-compile-target-machine))
(not (deps-machine deps)))) (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, ;; We need to recompile the file from machine-independent bytecode,
;; or maybe just update the file's modification date ;; or maybe just update the file's modification date
(trace-printf "hash-equivalent: ~a" zo-name) (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 ;; if we have to read the compiled form and that failed (e.g., because
;; the file's not there), then return #f overall: ;; the file's not there), then return #f overall:
(let ([sha-1 (or assume-compiled-sha1 path-sha1)]) (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 (and sha-1
(string-append sha-1 imports-sha1)))))) (string-append sha-1 imports-sha1))))))
@ -853,7 +881,12 @@
;; falling back normally to bytecode, and returning "" insteda of ;; falling back normally to bytecode, and returning "" insteda of
;; #f if compiled code is not available: ;; #f if compiled code is not available:
(define (get-compiled-sha1 path->mode roots path) (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"))]) (let ([dep-path (build-path dir (path-add-extension name #".dep"))])
(or (try-file-sha1 (build-path dir "native" (system-library-subpath) (or (try-file-sha1 (build-path dir "native" (system-library-subpath)
(path-add-extension name (system-type (path-add-extension name (system-type
@ -887,7 +920,9 @@
#:sha1-only? [sha1-only? #f]) #:sha1-only? [sha1-only? #f])
(define orig-path (simple-form-path path0)) (define orig-path (simple-form-path path0))
(define (read-deps path) (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 (with-module-reading-parameterization
(lambda () (lambda ()
(call-with-input-file* (call-with-input-file*
@ -930,7 +965,10 @@
(cond (cond
[(not (and (deps-has-version? deps) [(not (and (deps-has-version? deps)
(equal? (version) (deps-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] #t]
[(not (and (deps-has-machine? deps) [(not (and (deps-has-machine? deps)
(or (eq? (current-compile-target-machine) (deps-machine deps)) (or (eq? (current-compile-target-machine) (deps-machine deps))
@ -940,7 +978,10 @@
(or sha1-only? (or sha1-only?
(deps-machine deps) (deps-machine deps)
(not (cross-multi-compile? roots))))) (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] #t]
[(> path-time (or path-zo-time -inf.0)) [(> path-time (or path-zo-time -inf.0))
(trace-printf "newer src... ~a > ~a" path-time path-zo-time) (trace-printf "newer src... ~a > ~a" path-time path-zo-time)
@ -948,7 +989,7 @@
#:trying-sha1? sha1-only?)] #:trying-sha1? sha1-only?)]
[(different-source-sha1-and-dep-recorded path deps) [(different-source-sha1-and-dep-recorded path deps)
=> (lambda (difference) => (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 (maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen
#:trying-sha1? sha1-only?))] #:trying-sha1? sha1-only?))]
[(ormap-strict [(ormap-strict
@ -958,12 +999,13 @@
(define t (define t
(if ext? (if ext?
(cons (or (try-file-time d) +inf.0) #f) (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 (and t
(car t) (car t)
(> (car t) (or path-zo-time -inf.0)) (> (car t) (or path-zo-time -inf.0))
(begin (trace-printf "newer: ~a (~a > ~a)..." (begin (trace-printf "newer for ~a: ~a (~a > ~a)..."
d (car t) path-zo-time) path d (car t) path-zo-time)
#t))) #t)))
(deps-imports deps)) (deps-imports deps))
(maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen (maybe-compile-zo deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen

9
racket/collects/setup/setup-core.rkt
View File

@ -1059,6 +1059,7 @@
(define dir (cc-path cc)) (define dir (cc-path cc))
(define info (cc-info cc)) (define info (cc-info cc))
(compile-directory-zos dir info (compile-directory-zos dir info
#:verbose (verbose)
#:has-module-suffix? has-module-suffix? #:has-module-suffix? has-module-suffix?
#:omit-root (cc-omit-root cc) #:omit-root (cc-omit-root cc)
#:managed-compile-zo caching-managed-compile-zo #:managed-compile-zo caching-managed-compile-zo
@ -2027,6 +2028,8 @@
(setup-printf "version" "~a" (version)) (setup-printf "version" "~a" (version))
(setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc)) (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)) (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 "installation name" "~a" (get-installation-name))
(setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", ")) (setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", "))
(setup-printf "main collects" "~a" main-collects-dir) (setup-printf "main collects" "~a" main-collects-dir)
@ -2043,6 +2046,12 @@
(setup-printf #f " ~a" p)) (setup-printf #f " ~a" p))
(when (use-user-specific-search-paths) (when (use-user-specific-search-paths)
(setup-printf #f " ~a" (find-user-links-file))) (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)) (setup-printf "main docs" "~a" (find-doc-dir))
(when (and (not (null? (archives))) no-specific-collections?) (when (and (not (null? (archives))) no-specific-collections?)