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

Create racket/place/dynamic to reduce dependencies.

Browse Source 
Also adjust implementation of th-places slightly to avoid startup
time dependencies.
This commit is contained in:
Sam Tobin-Hochstadt 2020-11-24 14:44:23 -05:00 committed by Matthew Flatt
parent ef96d98b04
commit 1173006212
7 changed files with 277 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/racket-doc/scribblings/reference/mz.rkt
View File

@ -33,23 +33,33 @@
(provide note-lib) (provide note-lib)
(define-syntax note-lib (define-syntax note-lib
(syntax-rules () (syntax-rules ()
[(_ lib #:use-sources (src ...) . more) [(_ lib #:more-libs (lib+ ...) #:use-sources (src ...) . more)
(begin (begin
(declare-exporting lib racket #:use-sources (src ...)) (declare-exporting lib lib+ ... racket #:use-sources (src ...))
(defmodule*/no-declare (lib) (defmodule*/no-declare (lib lib+ ...)
(t (make-collect-element (t (make-collect-element
#f null #f null
(lambda (ci) (lambda (ci)
(collect-put! ci `(racket-extra-lib ,'lib) (racketmodname lib)))) (collect-put! ci `(racket-extra-lib ,'lib) (racketmodname lib))))
"The bindings documented in this section are provided by the " "The bindings documented in this section are provided by the "
(racketmodname lib) (combine-library-names (racketmodname lib) (racketmodname lib+) ...) ; includes trailing space
" and " "and "
(racketmodname racket) (racketmodname racket)
" libraries, but not " (racketmodname racket/base) " libraries, but not " (racketmodname racket/base)
"." "."
. more)))] . more)))]
[(_ lib #:more-libs (lib+ ...) . more)
(note-lib lib #:more-libs (lib+ ...) #:use-sources () . more)]
[(_ lib #:use-sources (src ...) . more)
(note-lib lib #:more-libs () #:use-sources (src ...) . more)]
[(_ lib . more) [(_ lib . more)
(note-lib lib #:use-sources () . more)])) (note-lib lib #:more-libs () #:use-sources () . more)]))
(define (combine-library-names lib . lib+s)
(if (null? lib+s)
(list lib " ")
(for/list ([lib (in-list (cons lib lib+s))])
(list lib ", "))))
(provide note-init-lib) (provide note-init-lib)
(define-syntax note-init-lib (define-syntax note-init-lib

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

@ -18,7 +18,7 @@
@guideintro["effective-places"]{places} @guideintro["effective-places"]{places}
@note-lib[racket/place] @note-lib[racket/place #:more-libs (racket/place/dynamic) #:use-sources(racket/place)]
@tech{Places} enable the development of parallel programs that @tech{Places} enable the development of parallel programs that
take advantage of machines with multiple processors, cores, or take advantage of machines with multiple processors, cores, or
@ -246,46 +246,6 @@ The @racket[dynamic-place*] procedure returns four values:
The @racket[dynamic-place*] binding is protected in the same way as The @racket[dynamic-place*] binding is protected in the same way as
@racket[dynamic-place].} @racket[dynamic-place].}
@defform[(place id body ...+)]{
Creates a place that evaluates @racket[body]
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 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].}
@defform/subs[(place* maybe-port ...
id
body ...+)
([maybe-port code:blank
(code:line #:in in-expr)
(code:line #:out out-expr)
(code:line #:err err-expr)])]{
Like @racket[place], but supports optional @racket[#:in], @racket[#:out],
and @racket[#:err] expressions (at most one of each) to specify ports in the same way and
with the same defaults as @racket[dynamic-place*]. The result of
a @racket[place*] form is also the same as for @racket[dynamic-place*].
The @racket[place*] binding is protected in the same way as
@racket[dynamic-place].}
@defform[(place/context id body ...+)]{
Like @racket[place], but @racket[body ...] may have free lexical
variables, which are automatically sent to the newly-created place.
Note that these variables must have values accepted by
@racket[place-message-allowed?], otherwise an @exnraise[exn:fail:contract].
}
@defproc[(place-wait [p place?]) exact-integer?]{ @defproc[(place-wait [p place?]) exact-integer?]{
Returns the @tech{completion value} of the place indicated by @racket[p], Returns the @tech{completion value} of the place indicated by @racket[p],
@ -322,7 +282,6 @@ If any pumping threads were created to connect a non-@tech{file-stream
Sends the main thread of place @racket[p] a break; see @secref["breakhandler"]. Sends the main thread of place @racket[p] a break; see @secref["breakhandler"].
} }
@defproc[(place-channel) (values place-channel? place-channel?)]{ @defproc[(place-channel) (values place-channel? place-channel?)]{
Returns two @tech{place channels}. Data sent through the first Returns two @tech{place channels}. Data sent through the first
@ -427,6 +386,56 @@ A @tech{place location} can be passed as the @racket[#:at] argument to
A distributed places note created with @racket[create-place-node] A distributed places note created with @racket[create-place-node]
is an example of a @tech{place location}.} is an example of a @tech{place location}.}
@section[#:tag "places-syntax"]{Syntactic Support for Using Places}
@declare-exporting[racket/place]
The bindings in this section are @emph{not} provided by
@racketmodname[racket/place/dynamic].
@defform[(place id body ...+)]{
Creates a place that evaluates @racket[body]
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 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].}
@defform/subs[(place* maybe-port ...
id
body ...+)
([maybe-port code:blank
(code:line #:in in-expr)
(code:line #:out out-expr)
(code:line #:err err-expr)])]{
Like @racket[place], but supports optional @racket[#:in], @racket[#:out],
and @racket[#:err] expressions (at most one of each) to specify ports in the same way and
with the same defaults as @racket[dynamic-place*]. The result of
a @racket[place*] form is also the same as for @racket[dynamic-place*].
The @racket[place*] binding is protected in the same way as
@racket[dynamic-place].}
@defform[(place/context id body ...+)]{
Like @racket[place], but @racket[body ...] may have free lexical
variables, which are automatically sent to the newly-created place.
Note that these variables must have values accepted by
@racket[place-message-allowed?], otherwise an @exnraise[exn:fail:contract].
}
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@include-section["places-logging.scrbl"] @include-section["places-logging.scrbl"]

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

@ -1,171 +1,19 @@
#lang racket/base #lang racket/base
(require (prefix-in pl- '#%place) (require (prefix-in pl- '#%place)
(only-in '#%paramz parameterization-key)
(only-in '#%futures processor-count)
'#%place-struct
racket/fixnum
racket/flonum
racket/vector
racket/place/private/th-place
racket/place/private/prop
racket/private/streams
racket/match racket/match
racket/runtime-path racket/place/dynamic
(only-in "private/place.rkt"
start-place
start-place*)
(for-syntax racket/base (for-syntax racket/base
racket/syntax racket/syntax
syntax/parse syntax/parse
syntax/free-vars)) syntax/free-vars))
(provide (protect-out dynamic-place (provide (all-from-out racket/place/dynamic)
dynamic-place*) (protect-out place place*)
place-wait place/context)
place-kill
(rename-out [place-break/opt place-break])
place-channel
place-channel-put
place-channel-get
place-channel?
place?
place-message-allowed?
place-channel-put/get
processor-count
(protect-out place
place*)
place/context
(rename-out [pl-place-enabled? place-enabled?])
place-dead-evt
place-location?
prop:place-location)
(define-syntax (define-pl-func stx)
(syntax-case stx ()
[(_ func p args ...)
(with-syntax [(func-sym #'(quote func))
(pl-func (string->symbol (string-append "pl-" (symbol->string (syntax->datum #'func)))))
(th-func (string->symbol (string-append "th-" (symbol->string (syntax->datum #'func)))))]
#'(define (func p args ...)
(cond
[(prop:place? p) ((prop:place-ref p) func-sym p args ...)]
[(pl-place-enabled?) (pl-func p args ...)]
[else (th-func p args ...)])))]))
(define (place-channel-put/get ch msg)
(place-channel-put ch msg)
(place-channel-get ch))
(define place-channel (if (pl-place-enabled?) pl-place-channel th-place-channel))
(define-pl-func place-wait p)
(define-pl-func place-kill p)
(define-pl-func place-break p kind)
(define-pl-func place-channel-put p msg)
(define-pl-func place-channel-get p)
(define-pl-func place-channel? p)
(define-pl-func place? p)
(define-pl-func place-message-allowed? p)
(define-pl-func place-dead-evt p)
(define-values (prop:place-location place-location? place-location-ref)
(make-struct-type-property 'place-location
(lambda (v info)
(unless (and (procedure? v)
(procedure-arity-includes? v 4))
(raise-argument-error 'guard-for-prop:place-location
"(procedure-arity-includes/c 4)"
v))
v)))
(define place-break/opt
(let ([place-break (lambda (p [kind #f]) (place-break p kind))])
place-break))
(define (pump-place p pin pout perr in out err)
(cond
[(pl-place-enabled?)
(define-values (t-in t-out t-err) (pump-ports (place-dead-evt p) pin pout perr in out err))
(pl-place-pumper-threads p (vector t-in t-out t-err))]
[else (void)]))
(define (dynamic-place module-path function #:at [node #f] #:named [named #f])
(cond
[node
(unless (place-location? node)
(raise-argument-error 'dynamic-place "(or/c place-location? #f)" node))
((place-location-ref node) node module-path function named)]
[else
(start-place 'dynamic-place module-path function
#f (current-output-port) (current-error-port))]))
(define (dynamic-place* module-path
function
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(start-place* 'dynamic-place* module-path function in out err))
(define (start-place who module-path function in out err)
(define-values (p i o e) (start-place* who
module-path
function
in
out
err))
(close-output-port i)
p)
(define (start-place* who module-path function in out err)
;; Duplicate checks in that are in the primitive `pl-dynamic-place',
;; unfortunately, but we want these checks before we start making
;; stream-pumping threads, etc.
(unless (or (module-path? module-path) (path? module-path))
(raise-argument-error who "(or/c module-path? path?)" module-path))
(unless (symbol? function)
(raise-argument-error who "symbol?" function))
(unless (or (not in) (input-port? in))
(raise-argument-error who "(or/c input-port? #f)" in))
(unless (or (not out) (output-port? out))
(raise-argument-error who "(or/c output-port? #f)" out))
(unless (or (not err) (output-port? err) (eq? err 'stdout))
(raise-argument-error who "(or/c output-port? #f 'stdout)" err))
(when (and (pair? module-path) (eq? (car module-path) 'quote)
(not (module-predefined? module-path)))
(raise-arguments-error who "not a filesystem or predefined module path"
"module path" module-path))
(when (and (input-port? in) (port-closed? in))
(raise-arguments-error who "input port is closed" "port" in))
(when (and (output-port? out) (port-closed? out))
(raise-arguments-error who "output port is closed" "port" out))
(when (and (output-port? err) (port-closed? err))
(raise-arguments-error who "error port is closed" "port" err))
(cond
[(pl-place-enabled?)
(define-values (p pin pout perr)
(pl-dynamic-place module-path
function
(if-stream-in who in)
(if-stream-out who out)
(if-stream-out who err)))
(pump-place p pin pout perr in out err)
(values p
(and (not in) pin)
(and (not out) pout)
(and (not err) perr))]
[else
(define-values (inr inw ) (if in (values #f #f) (make-pipe)))
(define-values (outr outw) (if out (values #f #f) (make-pipe)))
(define-values (errr errw) (if err (values #f #f) (make-pipe)))
(parameterize ([current-input-port (or in inr)]
[current-output-port (or out outw)]
[current-error-port (or err errw)])
(values (th-dynamic-place module-path function)
(and (not in ) inw )
(and (not out) outr)
(and (not err) errr)))]))
(define-for-syntax place-body-counter 0) (define-for-syntax place-body-counter 0)

6
racket/collects/racket/place/dynamic.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "../private/place.rkt")
(provide (except-out (all-from-out "../private/place.rkt")
start-place
start-place*))

8
racket/collects/racket/place/private/prop.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base #lang s-exp racket/kernel
(provide prop:place (#%provide prop:place
prop:place? prop:place?
prop:place-ref) prop:place-ref)
(define-values (prop:place prop:place? prop:place-ref) (define-values (prop:place prop:place? prop:place-ref)
(make-struct-type-property 'place)) (make-struct-type-property 'place))

41
racket/collects/racket/place/private/th-place.rkt
View File

@ -2,13 +2,11 @@
(require (prefix-in pl- '#%place) (require (prefix-in pl- '#%place)
'#%boot '#%boot
(only-in '#%paramz parameterization-key) (only-in '#%paramz parameterization-key)
(only-in '#%unsafe unsafe-make-custodian-at-root)
'#%place-struct '#%place-struct
racket/fixnum '#%flfxnum
racket/flonum (only-in '#%unsafe unsafe-make-custodian-at-root)
racket/vector (only-in '#%foreign cpointer?)
(only-in ffi/unsafe cpointer?) (only-in '#%network tcp-port? tcp-listener?))
racket/tcp)
(provide th-dynamic-place (provide th-dynamic-place
;th-dynamic-place* ;th-dynamic-place*
@ -25,6 +23,17 @@
th-place-dead-evt th-place-dead-evt
) )
(define-syntax-rule (copiers fXvector-copy! fXvector-set! fXvector-ref)
(define (fXvector-copy! vec dest-start flv start end)
(let ([len (- end start)])
(for ([i (in-range len)])
(fXvector-set! vec (+ i dest-start)
(fXvector-ref flv (+ i start)))))))
(copiers fxvector-copy! fxvector-set! fxvector-ref)
(copiers flvector-copy! flvector-set! flvector-ref)
(define-struct TH-place (th ch cust cust-box result-box) (define-struct TH-place (th ch cust cust-box result-box)
#:property prop:evt (lambda (x) (TH-place-channel-in (TH-place-ch x)))) #:property prop:evt (lambda (x) (TH-place-channel-in (TH-place-ch x))))
@ -111,8 +120,16 @@
[(cond [(cond
[(path-for-some-system? o) o] [(path-for-some-system? o) o]
[(bytes? o) (if (pl-place-shared? o) o (record o (bytes-copy o)))] [(bytes? o) (if (pl-place-shared? o) o (record o (bytes-copy o)))]
[(fxvector? o) (if (pl-place-shared? o) o (record o (fxvector-copy o)))] [(fxvector? o) (if (pl-place-shared? o)
[(flvector? o) (if (pl-place-shared? o) o (record o (flvector-copy o)))] o
(let* ([c (make-fxvector (fxvector-length o))])
(fxvector-copy! c 0 o 0 (fxvector-length o))
(record o c)))]
[(flvector? o) (if (pl-place-shared? o)
o
(let* ([c (make-flvector (flvector-length o))])
(flvector-copy! c 0 o 0 (flvector-length o))
(record o c)))]
[else #f]) [else #f])
=> values] => values]
[(TH-place? o) (dcw (TH-place-ch o))] [(TH-place? o) (dcw (TH-place-ch o))]
@ -122,7 +139,13 @@
(lambda () (lambda ()
(cons (dcw (car o)) (dcw (cdr o)))))] (cons (dcw (car o)) (dcw (cdr o)))))]
[(vector? o) [(vector? o)
(vector-map! dcw (record o (vector-copy o)))] (define new-v (make-vector (vector-length o)))
(vector-copy! new-v 0 o)
(define r (record o new-v))
(for ([i (in-naturals)]
[v (in-vector r)])
(vector-set! new-v i (dcw v)))
r]
[(hash? o) [(hash? o)
(with-placeholder (with-placeholder
o o

157
racket/collects/racket/private/place.rkt Normal file
View File

@ -0,0 +1,157 @@
#lang racket/base
(require (prefix-in pl- '#%place)
(only-in '#%futures processor-count)
racket/place/private/th-place
racket/place/private/prop
racket/private/streams
(for-syntax racket/base racket/syntax))
;; This module is mostly re-exported by `racket/place/dynamic`
(provide (protect-out dynamic-place
dynamic-place*
start-place
start-place*)
place-wait
place-kill
(rename-out [place-break/opt place-break])
place-channel
place-channel-put
place-channel-get
place-channel?
place?
place-message-allowed?
place-channel-put/get
processor-count
(rename-out [pl-place-enabled? place-enabled?])
place-dead-evt
place-location?
prop:place-location)
(define-syntax (define-pl-func stx)
(syntax-case stx ()
[(_ func p args ...)
(with-syntax [(func-sym #'(quote func))
(pl-func (format-id #'here "pl-~a" #'func))
(th-func (format-id #'here "th-~a" #'func))]
#'(define (func p args ...)
(cond
[(prop:place? p) ((prop:place-ref p) func-sym p args ...)]
[(pl-place-enabled?) (pl-func p args ...)]
[else (th-func p args ...)])))]))
(define (place-channel-put/get ch msg)
(place-channel-put ch msg)
(place-channel-get ch))
(define place-channel (if (pl-place-enabled?) pl-place-channel th-place-channel))
(define-pl-func place-wait p)
(define-pl-func place-kill p)
(define-pl-func place-break p kind)
(define-pl-func place-channel-put p msg)
(define-pl-func place-channel-get p)
(define-pl-func place-channel? p)
(define-pl-func place? p)
(define-pl-func place-message-allowed? p)
(define-pl-func place-dead-evt p)
(define-values (prop:place-location place-location? place-location-ref)
(make-struct-type-property 'place-location
(lambda (v info)
(unless (and (procedure? v)
(procedure-arity-includes? v 4))
(raise-argument-error 'guard-for-prop:place-location
"(procedure-arity-includes/c 4)"
v))
v)))
(define place-break/opt
(let ([place-break (lambda (p [kind #f]) (place-break p kind))])
place-break))
(define (pump-place p pin pout perr in out err)
(cond
[(pl-place-enabled?)
(define-values (t-in t-out t-err) (pump-ports (place-dead-evt p) pin pout perr in out err))
(pl-place-pumper-threads p (vector t-in t-out t-err))]
[else (void)]))
(define (dynamic-place module-path function #:at [node #f] #:named [named #f])
(cond
[node
(unless (place-location? node)
(raise-argument-error 'dynamic-place "(or/c place-location? #f)" node))
((place-location-ref node) node module-path function named)]
[else
(start-place 'dynamic-place module-path function
#f (current-output-port) (current-error-port))]))
(define (dynamic-place* module-path
function
#:in [in #f]
#:out [out (current-output-port)]
#:err [err (current-error-port)])
(start-place* 'dynamic-place* module-path function in out err))
(define (start-place who module-path function in out err)
(define-values (p i o e) (start-place* who
module-path
function
in
out
err))
(close-output-port i)
p)
(define (start-place* who module-path function in out err)
;; Duplicate checks in that are in the primitive `pl-dynamic-place',
;; unfortunately, but we want these checks before we start making
;; stream-pumping threads, etc.
(unless (or (module-path? module-path) (path? module-path))
(raise-argument-error who "(or/c module-path? path?)" module-path))
(unless (symbol? function)
(raise-argument-error who "symbol?" function))
(unless (or (not in) (input-port? in))
(raise-argument-error who "(or/c input-port? #f)" in))
(unless (or (not out) (output-port? out))
(raise-argument-error who "(or/c output-port? #f)" out))
(unless (or (not err) (output-port? err) (eq? err 'stdout))
(raise-argument-error who "(or/c output-port? #f 'stdout)" err))
(when (and (pair? module-path) (eq? (car module-path) 'quote)
(not (module-predefined? module-path)))
(raise-arguments-error who "not a filesystem or predefined module path"
"module path" module-path))
(when (and (input-port? in) (port-closed? in))
(raise-arguments-error who "input port is closed" "port" in))
(when (and (output-port? out) (port-closed? out))
(raise-arguments-error who "output port is closed" "port" out))
(when (and (output-port? err) (port-closed? err))
(raise-arguments-error who "error port is closed" "port" err))
(cond
[(pl-place-enabled?)
(define-values (p pin pout perr)
(pl-dynamic-place module-path
function
(if-stream-in who in)
(if-stream-out who out)
(if-stream-out who err)))
(pump-place p pin pout perr in out err)
(values p
(and (not in) pin)
(and (not out) pout)
(and (not err) perr))]
[else
(define-values (inr inw ) (if in (values #f #f) (make-pipe)))
(define-values (outr outw) (if out (values #f #f) (make-pipe)))
(define-values (errr errw) (if err (values #f #f) (make-pipe)))
(parameterize ([current-input-port (or in inr)]
[current-output-port (or out outw)]
[current-error-port (or err errw)])
(values (th-dynamic-place module-path function)
(and (not in ) inw )
(and (not out) outr)
(and (not err) errr)))]))