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

compiler/compilation-path: added

Browse Source 
Provides functions for finding the bytecode path for a source file,
which might depend on PLTCOMPILEDROOTS, etc.
This commit is contained in:
Matthew Flatt 2014-05-27 08:23:00 +01:00
parent 25d159eba7
commit dfcadcfacf
4 changed files with 126 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

4
pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl
View File

@ -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

48
racket/collects/compiler/cm.rkt
View File

@ -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

77
racket/collects/compiler/compilation-path.rkt Normal file
View File

@ -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"))))