diff --git a/pkgs/racket-doc/scribblings/raco/exe.scrbl b/pkgs/racket-doc/scribblings/raco/exe.scrbl index 3e957c98b4..2a276cd540 100644 --- a/pkgs/racket-doc/scribblings/raco/exe.scrbl +++ b/pkgs/racket-doc/scribblings/raco/exe.scrbl @@ -49,7 +49,10 @@ created executable. Such modules can be explicitly included using the @racket[define-runtime-path] to embed references to the run-time files in the executable; the files are then copied and packaged together with the executable when creating a distribution (as described in -@secref["exe-dist"]). +@secref["exe-dist"]). Finally, a submodule is included if its +enclosing module is included and the submodule contains a +sub-submodule named @racketidfont{declare-preserve-for-embedding} +(where the implementation of the sub-submodule is ignored). Modules that are implemented directly by extensions---i.e., extensions that are automatically loaded from @racket[(build-path "compiled" @@ -172,6 +175,9 @@ The @exec{raco exe} command accepts the following command-line flags: ] +@history[#:changed "6.3.0.11" @elem{Added support for + @racketidfont{declare-preserve-for-embedding}.}] + @; ---------------------------------------------------------------------- @include-section["exe-api.scrbl"] diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index f95d115feb..00c783b475 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -571,8 +571,9 @@ (if (or (null? use-submods) use-source?) null - (for/list ([m l] - #:when (member (cadr (module-compiled-name m)) use-submods)) + (for/list ([m (in-list l)] + #:when (or (member (last (module-compiled-name m)) use-submods) + (declares-always-preserved? m))) m)))] [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] [post-submods (extract-submods (module-compiled-submodules renamed-code #f))] @@ -756,6 +757,12 @@ (apply append (map accum-from-mod (module-compiled-submodules mod #f)))))) +(define (declares-always-preserved? m) + (for/or ([s (in-list + (append (module-compiled-submodules m #t) + (module-compiled-submodules m #f)))]) + (eq? (last (module-compiled-name s)) 'declare-preserve-for-embedding))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (compile-using-kernel e) @@ -825,7 +832,7 @@ (namespace-module-registry (current-namespace)) (vector mapping-table library-table)) (letrec-values ([(lookup) - (lambda (name rel-to stx load? orig) + (lambda (name rel-to stx load? for-submod? orig) (if (not (module-path? name)) ;; Bad input (orig name rel-to stx load?) @@ -1018,8 +1025,17 @@ (if a3 ;; Have it: (make-resolved-module-path (cdr a3)) - ;; Let default handler try: - (orig name rel-to stx load?)))))))))))] + (if (if for-submod? + (if (pair? name) + (if (eq? (car name) 'quote) + (assq (cadr name) mapping-table) + #f) + #f) + #f) + ;; Report that we have mappings relative to `name`: + (make-resolved-module-path (cadr name)) + ;; Let default handler try: + (orig name rel-to stx load?))))))))))))] [(embedded-resolver) (case-lambda [(name from-namespace) @@ -1055,20 +1071,26 @@ (void)) (orig name from-namespace)] [(name rel-to stx load?) - (lookup name rel-to stx load? + (lookup name rel-to stx load? #f (lambda (name rel-to stx load?) ;; For a submodule, if we have a mapping for the base name, ;; then don't try the original handler. (let-values ([(base) (if (pair? name) (if (eq? (car name) 'submod) - (lookup (cadr name) rel-to stx load? (lambda (n r s l?) #f)) + ;; Pass #t for `for-submod?`, which causes a + ;; resolved module name to be returned for a quoted + ;; module name if we have any relative mappings for it: + (lookup (cadr name) rel-to stx load? #t (lambda (n r s l?) #f)) #f) #f)]) (if base - ;; don't chain to `orig': - (make-resolved-module-path - (list* 'submod (resolved-module-path-name base) (cddr name))) + ;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`, + ;; and if that still fails, just construct a submodule path: + (lookup (cons 'submod (cons "." (cddr name))) base stx load? #f + (lambda (name rel-to stx load?) + (make-resolved-module-path + (cons (resolved-module-path-name base) (cddr name))))) ;; chain to `orig': (orig name rel-to stx load?)))))])]) (current-module-name-resolver embedded-resolver)))))) diff --git a/racket/collects/racket/place.rkt b/racket/collects/racket/place.rkt index 237e71f194..b5886c63b6 100644 --- a/racket/collects/racket/place.rkt +++ b/racket/collects/racket/place.rkt @@ -11,6 +11,7 @@ racket/place/private/prop racket/private/streams racket/match + racket/runtime-path (for-syntax racket/base @@ -186,7 +187,7 @@ (syntax-case stx () [(who ch body1 body ...) (if (eq? (syntax-local-context) 'module-begin) - ;; when a `place' form is the only thing in a module mody: + ;; when a `place' form is the only thing in a module body: #`(begin #,stx) ;; normal case: (let () @@ -200,10 +201,14 @@ (string->symbol (format "place-body-~a" place-body-counter)))) (with-syntax ([internal-def-name - (syntax-local-lift-module #`(module* #,module-name-stx #f - (provide main) - (define (main ch) - body1 body ...)))] + (syntax-local-lift-module + #`(module* #,module-name-stx #f + (provide main) + (define (main ch) + body1 body ...) + ;; The existence of this submodule makes the + ;; enclosing submodule preserved by `raco exe`: + (module declare-preserve-for-embedding '#%kernel)))] [in _in] [out _out] [err _err] @@ -236,9 +241,9 @@ (error who "the enclosing module's resolved name is not a path or predefined")) (define submod-ref (match name - [(? symbol?) `(quote 'name)] + [(? symbol?) `(submod (quote ,name) ,submod-name)] [(? path?) `(submod ,name ,submod-name)] - [`(,p ,s ...) `(submod ,p ,@s ,submod-name)])) + [`(,p ,s ...) `(submod ,(if (symbol? p) `(quote ,p) p) ,@s ,submod-name)])) (start-place-func who submod-ref 'main in out err)) (define-syntax (place/context stx)