From 6d8596bae380552b2aee47cd97b8b9f8f1b7961e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 2 Dec 2018 19:06:03 -0700 Subject: [PATCH] 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. --- pkgs/racket-doc/scribblings/raco/make.scrbl | 23 +++-- racket/collects/compiler/compilation-path.rkt | 28 +++--- .../collects/compiler/private/cm-minimal.rkt | 88 ++++++++++++++----- racket/collects/setup/setup-core.rkt | 9 ++ 4 files changed, 108 insertions(+), 40 deletions(-) diff --git a/pkgs/racket-doc/scribblings/raco/make.scrbl b/pkgs/racket-doc/scribblings/raco/make.scrbl index 46022ede48..e878a5f1ef 100644 --- a/pkgs/racket-doc/scribblings/raco/make.scrbl +++ b/pkgs/racket-doc/scribblings/raco/make.scrbl @@ -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.}]} @; ---------------------------------------------------------------------- diff --git a/racket/collects/compiler/compilation-path.rkt b/racket/collects/compiler/compilation-path.rkt index b05990e08f..d6fb8650ac 100644 --- a/racket/collects/compiler/compilation-path.rkt +++ b/racket/collects/compiler/compilation-path.rkt @@ -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")))) diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt index 9fe0285655..1cab2af0c6 100644 --- a/racket/collects/compiler/private/cm-minimal.rkt +++ b/racket/collects/compiler/private/cm-minimal.rkt @@ -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-expmode 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 diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index d08c989ef4..32b19f9ec7 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -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?)