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

fix place and raco exe

Browse Source 
The repair involves making `raco exe` detect a sub-submodule
whose name is `declare-preserve-for-embedding` as an indication
that a submodule should be carried along with its enclosing module.

Normally, `define-runtime-module-path-index` would do that, but
the submodule for `place` is created with `syntax-local-lift-module`,
and the point of `syntax-local-lift-module` is to work in a
nested experssion context where definitions cannot be lifted
to the enclosing module.
This commit is contained in:
Matthew Flatt 2016-01-04 10:59:32 -07:00
parent 5cf748d734
commit d37ee8c5b1
3 changed files with 51 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/scribblings/raco/exe.scrbl
View File

@ -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 @racket[define-runtime-path] to embed references to the run-time files
in the executable; the files are then copied and packaged together in the executable; the files are then copied and packaged together
with the executable when creating a distribution (as described in 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 Modules that are implemented directly by extensions---i.e., extensions
that are automatically loaded from @racket[(build-path "compiled" 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"] @include-section["exe-api.scrbl"]

42
racket/collects/compiler/embed.rkt
View File

@ -571,8 +571,9 @@
(if (or (null? use-submods) (if (or (null? use-submods)
use-source?) use-source?)
null null
(for/list ([m l] (for/list ([m (in-list l)]
#:when (member (cadr (module-compiled-name m)) use-submods)) #:when (or (member (last (module-compiled-name m)) use-submods)
(declares-always-preserved? m)))
m)))] m)))]
[pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))]
[post-submods (extract-submods (module-compiled-submodules renamed-code #f))] [post-submods (extract-submods (module-compiled-submodules renamed-code #f))]
@ -756,6 +757,12 @@
(apply append (apply append
(map accum-from-mod (module-compiled-submodules mod #f)))))) (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) (define (compile-using-kernel e)
@ -825,7 +832,7 @@
(namespace-module-registry (current-namespace)) (namespace-module-registry (current-namespace))
(vector mapping-table library-table)) (vector mapping-table library-table))
(letrec-values ([(lookup) (letrec-values ([(lookup)
(lambda (name rel-to stx load? orig) (lambda (name rel-to stx load? for-submod? orig)
(if (not (module-path? name)) (if (not (module-path? name))
;; Bad input ;; Bad input
(orig name rel-to stx load?) (orig name rel-to stx load?)
@ -1018,8 +1025,17 @@
(if a3 (if a3
;; Have it: ;; Have it:
(make-resolved-module-path (cdr a3)) (make-resolved-module-path (cdr a3))
;; Let default handler try: (if (if for-submod?
(orig name rel-to stx load?)))))))))))] (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) [(embedded-resolver)
(case-lambda (case-lambda
[(name from-namespace) [(name from-namespace)
@ -1055,20 +1071,26 @@
(void)) (void))
(orig name from-namespace)] (orig name from-namespace)]
[(name rel-to stx load?) [(name rel-to stx load?)
(lookup name rel-to stx load? (lookup name rel-to stx load? #f
(lambda (name rel-to stx load?) (lambda (name rel-to stx load?)
;; For a submodule, if we have a mapping for the base name, ;; For a submodule, if we have a mapping for the base name,
;; then don't try the original handler. ;; then don't try the original handler.
(let-values ([(base) (let-values ([(base)
(if (pair? name) (if (pair? name)
(if (eq? (car name) 'submod) (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)
#f)]) #f)])
(if base (if base
;; don't chain to `orig': ;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`,
(make-resolved-module-path ;; and if that still fails, just construct a submodule path:
(list* 'submod (resolved-module-path-name base) (cddr name))) (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': ;; chain to `orig':
(orig name rel-to stx load?)))))])]) (orig name rel-to stx load?)))))])])
(current-module-name-resolver embedded-resolver)))))) (current-module-name-resolver embedded-resolver))))))

19
racket/collects/racket/place.rkt
View File

@ -11,6 +11,7 @@
racket/place/private/prop racket/place/private/prop
racket/private/streams racket/private/streams
racket/match racket/match
racket/runtime-path
(for-syntax racket/base (for-syntax racket/base
@ -186,7 +187,7 @@
(syntax-case stx () (syntax-case stx ()
[(who ch body1 body ...) [(who ch body1 body ...)
(if (eq? (syntax-local-context) 'module-begin) (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) #`(begin #,stx)
;; normal case: ;; normal case:
(let () (let ()
@ -200,10 +201,14 @@
(string->symbol (string->symbol
(format "place-body-~a" place-body-counter)))) (format "place-body-~a" place-body-counter))))
(with-syntax ([internal-def-name (with-syntax ([internal-def-name
(syntax-local-lift-module #`(module* #,module-name-stx #f (syntax-local-lift-module
(provide main) #`(module* #,module-name-stx #f
(define (main ch) (provide main)
body1 body ...)))] (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] [in _in]
[out _out] [out _out]
[err _err] [err _err]
@ -236,9 +241,9 @@
(error who "the enclosing module's resolved name is not a path or predefined")) (error who "the enclosing module's resolved name is not a path or predefined"))
(define submod-ref (define submod-ref
(match name (match name
[(? symbol?) `(quote 'name)] [(? symbol?) `(submod (quote ,name) ,submod-name)]
[(? path?) `(submod ,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)) (start-place-func who submod-ref 'main in out err))
(define-syntax (place/context stx) (define-syntax (place/context stx)