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

change place to create a submodule

Browse Source 
When `place` expands, the body of the `place` form is placed into a
`(module* place-body-<n> #f ....)` submodule.

The `place` form previously placed its body in a lifted function,
where the function's exported name was based on
`(current-inexact-milliseconds)`. The generated submodules have
deterministic names, so that compilation is deterministic, and
submodule names don't collide (unlike exported function names) when
multiple `place`-using module are imported into some other module.
Also, using a submodule avoids the problem that the clock doesn't
change fast enough on Windows.
This commit is contained in:
Matthew Flatt 2015-08-14 17:09:56 -06:00
parent 0caf079637
commit 80aac79507
2 changed files with 20 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-doc/scribblings/reference/places.scrbl
View File

@ -240,10 +240,16 @@ The @racket[dynamic-place*] binding is protected in the same way as
expressions with @racket[id] bound to a place channel. The
@racket[body]s close only over @racket[id] plus the top-level
bindings of the enclosing module, because the
@racket[body]s are lifted to a function that is exported by
the module. The result of @racket[place] is a place descriptor,
@racket[body]s are lifted to a submodule.
The result of @racket[place] is a place descriptor,
like the result of @racket[dynamic-place].
The generated submodule has the name @racketidfont{place-body-@racket[_n]}
for an integer @racket[_n], and the submodule exports a @racket[main]
function that takes a place channel for the new place. The submodule
is not intended for use, however, except by the expansion of the
@racket[place] form.
The @racket[place] binding is protected in the same way as
@racket[dynamic-place].}

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

@ -179,6 +179,8 @@
[(symbol? name) (symbol->string name)]
[(path? name) (path->string name)])]))
(define-for-syntax place-body-counter 0)
(define-for-syntax (place-form _in _out _err _start-place-func stx orig-stx)
(syntax-case stx ()
[(who ch body1 body ...)
@ -191,20 +193,21 @@
(raise-syntax-error #f "can only be used in a module" stx))
(unless (identifier? #'ch)
(raise-syntax-error #f "expected an identifier" stx #'ch))
(define func-name-stx
(set! place-body-counter (add1 place-body-counter))
(define module-name-stx
(datum->syntax stx
(string->symbol
(string-append "place/anon"
(modpath->string (current-module-declare-name))))))
(format "place-body-~a" place-body-counter))))
(with-syntax ([internal-def-name
(syntax-local-lift-expression #'(lambda (ch) body1 body ...))]
[func-name (generate-temporary func-name-stx)]
(syntax-local-lift-module #`(module* #,module-name-stx #f
(provide main)
(define (main ch)
body1 body ...)))]
[in _in]
[out _out]
[err _err]
[start-place-func _start-place-func])
(syntax-local-lift-provide #'(rename internal-def-name func-name))
#'(place/proc (#%variable-reference) 'func-name 'who start-place-func in out err))))]
#`(place/proc (#%variable-reference) '#,module-name-stx 'who start-place-func in out err))))]
[(_ ch)
(raise-syntax-error #f "expected at least one body expression" orig-stx)]))
@ -222,7 +225,7 @@
[(pf #:err err ch body ...) (place-form #'#f #'#f #'err #'start-place* #'(pf ch body ...) stx)]
[(pf ch body ...) (place-form #'#f #'#f #'#f #'start-place* #'(pf ch body ...) stx)]))
(define (place/proc vr func-name who start-place-func in out err)
(define (place/proc vr submod-name who start-place-func in out err)
(define name
(resolved-module-path-name
(variable-reference->resolved-module-path
@ -230,7 +233,7 @@
(when (and (symbol? name)
(not (module-predefined? `(quote ,name))))
(error who "the enclosing module's resolved name is not a path or predefined"))
(start-place-func who (if (symbol? name) `(quote ,name) name) func-name in out err))
(start-place-func who `(submod ,(if (symbol? name) `(quote ,name) name) ,submod-name) 'main in out err))
(define-syntax (place/context stx)
(syntax-parse stx