From d5b1cc6bafdf2e350d96051a075d681ddcb3f90a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Apr 2007 01:18:58 +0000 Subject: [PATCH] add src-filter to create-exembedding-executable svn: r6028 --- collects/compiler/doc.txt | 10 +++++++++- collects/compiler/embed-unit.ss | 29 +++++++++++++++++++++------ collects/syntax/doc.txt | 35 +++++++++++++++++++++------------ collects/syntax/modcode.ss | 27 ++++++++++++++++++------- 4 files changed, 74 insertions(+), 27 deletions(-) diff --git a/collects/compiler/doc.txt b/collects/compiler/doc.txt index 5e569e7b20..e291e3d2d5 100644 --- a/collects/compiler/doc.txt +++ b/collects/compiler/doc.txt @@ -408,7 +408,8 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_. [#:launcher? launcher?] [#:verbose? verbose?] [#:compiler compile-proc] - [#:expand-namespace expand-namespace]) + [#:expand-namespace expand-namespace] + [#:src-filter src-filter-proc]) - Copies the MzScheme (if `mred?' is #f) or MrEd (otherwise) binary, embedding code into the copied executable to be loaded on startup. (Under Unix, the binary is actually a wrapper executable that execs @@ -601,6 +602,13 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_. be directed to the current locations (and, unltimately, redirected to copies in a distribution). + The `src-filter-proc' takes a path and returns true if the + corresponding file source be included in the embedding executable + in source form (insteda of compiled form), #f otherwise. The + default returns #f for all paths. Beware that the current output + port may be redirected to the result executable when the filter + procedure is called. + > (make-embedding-executable dest mred? verbose? mod-list literal-file-list literal-sexpr cmdline-list [aux launcher? variant]) Old (keywordless) interface to `create-embedding-executable'. diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 4f5752765b..039c22efeb 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -328,6 +328,10 @@ (let-values ([(base name dir?) (split-path p)]) (make-directory* base) p)))) + + (define (file-date f) + (with-handlers ([exn:fail:filesystem? (lambda (x) -inf.0)]) + (file-or-directory-modify-seconds f))) (define-struct extension (path)) @@ -365,8 +369,15 @@ "cannot use a _loader extension: ~e" file) (make-extension file)))) - ;; Prefer extensions if we're handling them: - (not on-extension))] + #:choose + ;; Prefer extensions, if we're handling them: + (lambda (src zo so) + (if on-extension + #f + (if (and (file-exists? so) + ((file-date so) . >= . (file-date zo))) + 'so + #f))))] [name (let-values ([(base name dir?) (split-path filename)]) (path->string (path-replace-suffix name #"")))] [prefix (let ([a (assoc filename prefixes)]) @@ -549,7 +560,7 @@ ;; Write a module bundle that can be loaded with 'load' (do not embed it ;; into an executable). The bundle is written to the current output port. (define (write-module-bundle verbose? modules literal-files literal-expression collects-dest - on-extension program-name compiler expand-namespace) + on-extension program-name compiler expand-namespace src-filter) (let* ([module-paths (map cadr modules)] [files (map (lambda (mp) @@ -676,7 +687,11 @@ (when verbose? (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc))) (write `(current-module-name-prefix ',(string->symbol (mod-prefix nc)))) - (write (mod-code nc)))) + (if (src-filter (mod-file nc)) + (with-input-from-file (mod-file nc) + (lambda () + (copy-port (current-input-port) (current-output-port)))) + (write (mod-code nc))))) l)) (write '(current-module-name-prefix #f)) (newline) @@ -729,7 +744,8 @@ [expand-namespace (current-namespace)] [compiler (lambda (expr) (parameterize ([current-namespace expand-namespace]) - (compile expr)))]) + (compile expr)))] + [src-filter (lambda (filename) #f)]) (define keep-exe? (and launcher? (let ([m (assq 'forget-exe? aux)]) (or (not m) @@ -828,7 +844,8 @@ on-extension (file-name-from-path dest) compiler - expand-namespace))]) + expand-namespace + src-filter))]) (let-values ([(start end) (if (and (eq? (system-type) 'macosx) (not unix-starter?)) diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt index 86f38c7bac..a694ed8a5e 100644 --- a/collects/syntax/doc.txt +++ b/collects/syntax/doc.txt @@ -323,7 +323,8 @@ _modread.ss_: reading module source code _modcode.ss_: getting module compiled code ====================================================================== -> (get-module-code path [compiled-subdir compile-proc ext-proc prefer-ext?]) - +> (get-module-code path [compiled-subdir compile-proc ext-proc] + [#:choose choose-proc]) - returns a compiled expression for the declaration of the module specified by `module-path-v'. The `module-path-v' argument is a quoted module path, as for MzScheme's `dynamic-require' using the @@ -337,21 +338,29 @@ _modcode.ss_: getting module compiled code available. The `ext-proc' argument defaults to #f. If it is not #f, it must be - a procedure of two arguments that is used when `path' does not exist - and no ".zo" version of `path' can be found, but an extension - implementing `path' is found. In that case, the arguments to + a procedure of two arguments that is called when a native-code + version of `path' is should be used. In that case, the arguments to `ext-proc' are the path for the extension, and a boolean indicating whether the extension is a _loader file (#t) or not (#f). - If a ".zo" version of `path' is available and newer than var `path' - (in one of the directories specified by `compiled-subdir'), then it - is used instead of the source. Native-code versions of `path' are - ignored --- unless only a native-code version exists (i.e., `path' - itself does not exist), or `prefer-ext?' is true and the native-code - file is not a _loader variant. If a native-code version is prefer or - is the only file that exists, it is supplied to `ext-proc' when - `ext-proc' is #f, or an exception is raised (to report that an - extension file cannot be used) when `ext-proc' is #f. + The `choose-proc' argument is a procedure that takes three paths: a + source path, a .zo file path, and an extension path (for a + non-_loader extension). Some of the paths may not exist. The result + should be either 'src, 'zo, 'so, or #f, indicating which variant + should be used or (in the case of #f) that the default choice should + be used. + + The default choice is computed as follows: if a ".zo" version of + `path' is available and newer than `path' itself (in one of the + directories specified by `compiled-subdir'), then it is used instead + of the source. Native-code versions of `path' are ignored, unless + only a native-code non_loader version exists (i.e., `path' itself + does not exist). A _loader extension is selected a last resort. + + If an extension is prefered or is the only file that exists, it is + supplied to `ext-proc' when `ext-proc' is #f, or an exception is + raised (to report that an extension file cannot be used) when + `ext-proc' is #f. > moddep-current-open-input-file diff --git a/collects/syntax/modcode.ss b/collects/syntax/modcode.ss index 7e2269c3ad..cffa4933ac 100644 --- a/collects/syntax/modcode.ss +++ b/collects/syntax/modcode.ss @@ -9,7 +9,10 @@ exn:get-module-code exn:get-module-code? exn:get-module-code-path - make-exn:get-module-code) + make-exn:get-module-code + get-module-code) + #; + ;; Contracts don't yet play well with keyword arguments: (provide/contract [get-module-code ([path-string?] [(and/c path-string? relative-path?) @@ -65,7 +68,9 @@ (define/kw (get-module-code path #:optional - [sub-path "compiled"] [compiler compile] [extension-handler #f] [prefer-so? #f]) + [sub-path "compiled"] [compiler compile] [extension-handler #f] + #:key + [choose (lambda (src zo so) #f)]) (unless (path-string? path) (raise-type-error 'get-module-code "path or string (sans nul)" path)) (let*-values ([(path) (resolve path)] @@ -87,13 +92,19 @@ (if (path? base) base (current-directory))]) - (t)))]) + (t)))] + [prefer (choose path zo so)]) (cond ;; Use .zo, if it's new enough - [(date>=? zo path-d) (read-one zo #f)] + [(or (eq? prefer 'zo) + (and (not prefer) + (date>=? zo path-d))) + (read-one zo #f)] ;; Maybe there's an .so? Use it only if we don't prefer source. - [(and (or (not path-d) prefer-so?) - (date>=? so path-d)) + [(or (eq? prefer 'so) + (and (not prefer) + (or (not path-d) + (date>=? so path-d)))) (if extension-handler (extension-handler so #f) (raise (make-exn:get-module-code @@ -101,7 +112,9 @@ (current-continuation-marks) so)))] ;; Use source if it exists - [path-d (with-dir (lambda () (compiler (read-one path #t))))] + [(or (eq? prefer 'src) + path-d) + (with-dir (lambda () (compiler (read-one path #t))))] ;; Or maybe even a _loader.so? [(and (not path-d) (date>=? _loader-so path-d)