diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl index 4ae706fbee..f562c2133b 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl @@ -587,6 +587,46 @@ See also @racket[managed-compile-zo].} @; ---------------------------------------------------------------------- +@section[#:tag "api:compile-path"]{API for Bytecode Paths} + +@defmodule[compiler/compilation-path] + +@history[#:added "6.0.1.10"] + +@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)]) + (values path? path?)]{ + +Determines the directory that holds the bytecode form of @racket[path] +plus base name of @racket[path]. + +The directory is determined by checking @racket[roots] in order, and +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].} + +@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)]) + path?]{ + +The same as @racket[get-compilation-dir+home], but returning only the first result.} + +@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)]) + path?]{ + +The same as @racket[get-compilation-dir+home], but combines the +results and adds a @filepath{.zo} suffix to arrive at a bytecode file +path.} + +@; ---------------------------------------------------------------------- + @section[#:tag "zo"]{Compiling to Raw Bytecode} The @DFlag{no-deps} mode for @exec{raco make} is an improverished diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl index 4d91589b3f..79f752b577 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl @@ -258,7 +258,9 @@ The check for a compiled file occurs whenever the given path indicated by the @racket[current-compiled-file-roots] and @racket[use-compiled-file-paths] parameters relative to @racket[_file], where the former supplies ``roots'' for compiled files -and the latter provides subdirectories. A ``root'' can be an absolute +and the latter provides subdirectories. +@margin-note*{See also @racketmodname[compiler/compilation-path].} +A ``root'' can be an absolute path, in which case @racket[_file]'s directory is combined with @racket[reroot-path] and the root as the second argument; if the ``root'' is a relative path, then the relative path is instead diff --git a/racket/collects/compiler/cm.rkt b/racket/collects/compiler/cm.rkt index 7d2fe7ba06..77f9db167d 100644 --- a/racket/collects/compiler/cm.rkt +++ b/racket/collects/compiler/cm.rkt @@ -9,7 +9,8 @@ racket/promise openssl/sha1 racket/place - setup/collects) + setup/collects + compiler/compilation-path) (provide make-compilation-manager-load/use-compiled-handler managed-compile-zo @@ -172,47 +173,10 @@ (loop subcode ht)))) (for/list ([k (in-hash-keys ht)]) k)) -(define (get-compilation-dir+name mode roots path) - (define (get-one root) - (let-values ([(base name must-be-dir?) (split-path path)]) - (values - (cond - [(eq? 'relative base) - (cond - [(eq? root 'same) mode] - [else (build-path root mode)])] - [else (build-path (cond - [(eq? root 'same) base] - [(relative-path? root) (build-path base root)] - [else (reroot-path base root)]) - mode)]) - name))) - ;; Try first root: - (define-values (p n) (get-one (car roots))) - (if (or (null? (cdr roots)) - (file-exists? (path-add-suffix (build-path p n) #".zo"))) - ;; Only root or first has a ".zo" file: - (values p n) - (let loop ([roots (cdr roots)]) - (cond - [(null? roots) - ;; No roots worked, so assume the first root: - (values p n)] - [else - ;; Check next root: - (define-values (p n) (get-one (car roots))) - (if (file-exists? (path-add-suffix (build-path p n) #".zo")) - (values p n) - (loop (cdr roots)))])))) - (define (get-compilation-path mode roots path) - (let-values ([(dir name) (get-compilation-dir+name mode roots path)]) + (let-values ([(dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots)]) (build-path dir name))) -(define (get-compilation-dir mode roots path) - (let-values ([(dir name) (get-compilation-dir+name mode roots path)]) - dir)) - (define (touch path) (with-compiler-security-guard (file-or-directory-modify-seconds @@ -420,7 +384,7 @@ (lambda (a b) #f) ; extension handler #:source-reader read-src-syntax))) (define dest-roots (list (car roots))) - (define code-dir (get-compilation-dir mode dest-roots path)) + (define code-dir (get-compilation-dir path #:modes (list mode) #:roots dest-roots)) ;; Wait for accomplice logging to finish: (log-message accomplice-logger 'info "stop" done-key) @@ -581,7 +545,7 @@ (trace-printf "end compile: ~a" actual-path))))) (define (get-compiled-time mode roots path) - (define-values (dir name) (get-compilation-dir+name mode roots path)) + (define-values (dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots)) (or (try-file-time (build-path dir "native" (system-library-subpath) (path-add-suffix name (system-type 'so-suffix)))) @@ -597,7 +561,7 @@ (call-with-input-file* dep-path (lambda (p) (cdadr (read p)))))))))) (define (get-compiled-sha1 mode roots path) - (define-values (dir name) (get-compilation-dir+name mode roots path)) + (define-values (dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots)) (let ([dep-path (build-path dir (path-add-suffix name #".dep"))]) (or (try-file-sha1 (build-path dir "native" (system-library-subpath) (path-add-suffix name (system-type diff --git a/racket/collects/compiler/compilation-path.rkt b/racket/collects/compiler/compilation-path.rkt new file mode 100644 index 0000000000..b05990e08f --- /dev/null +++ b/racket/collects/compiler/compilation-path.rkt @@ -0,0 +1,77 @@ +#lang racket/base + +(provide get-compilation-dir+name + get-compilation-dir + get-compilation-bytecode-file) + +(define (do-get-compilation-dir+name who path modes roots) + ;; Check arguments + (unless (path-string? path) + (raise-argument-error who "path-string?" path)) + (unless (and (list? modes) + (pair? modes) + (andmap (lambda (p) + (and (path-string? p) + (relative-path? p))) + modes)) + (raise-argument-error who "(non-empty-listof (and/c path-string? relative-path?))" modes)) + (unless (and (list? roots) + (pair? roots) + (andmap (lambda (p) + (or (path-string? p) (eq? p 'same))) + roots)) + (raise-argument-error who "(non-empty-listof (or/c path-string? 'same))" roots)) + ;; Function to try one combination: + (define (get-one mode root) + (let-values ([(base name must-be-dir?) (split-path path)]) + (values + (cond + [(eq? 'relative base) + (cond + [(eq? root 'same) mode] + [else (build-path root mode)])] + [else (build-path (cond + [(eq? root 'same) base] + [(relative-path? root) (build-path base root)] + [else (reroot-path base root)]) + mode)]) + name))) + ;; Try first root: + (define-values (p n) (get-one (car modes) (car roots))) + (if (or (and (null? (cdr roots)) + (null? (cdr modes))) + (file-exists? (path-add-suffix (build-path p n) #".zo"))) + ;; Only root or first has a ".zo" file: + (values p n) + (let loop ([roots (cdr roots)]) + (cond + [(null? roots) + ;; No roots worked, so assume the first mode + root: + (values p n)] + [else + ;; Check next root: + (let mloop ([modes modes]) + (cond + [(null? modes) (loop (cdr roots))] + [else + (define-values (p n) (get-one (car modes) (car roots))) + (if (file-exists? (path-add-suffix (build-path p n) #".zo")) + (values p n) + (mloop (cdr modes)))]))])))) + +(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)) + +(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)]) + 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)]) + (build-path dir (path-add-suffix name #".zo"))))