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

add plumbers, remove custodian-tidy-all

Browse Source 
In v6.0.1.7, I tried to give a port-flushing job to custodians. They
turned out to be unqualified, so let's try employing specialists.

Thanks to Eli for pointing out the problem with the v6.0.1.7 design:
attaching callbacks to custodians allows a sandboxed task to escape
through the custodian hierarchy. Plumbers avoid this problem by
having no hierarchy.
This commit is contained in:
Matthew Flatt 2014-05-08 18:20:29 -06:00
parent e1ab2ffcf4
commit d5b42f8c50
35 changed files with 1151 additions and 973 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
pkgs/racket-pkgs/racket-doc/scribblings/reference/custodians.scrbl
View File

@ -128,60 +128,3 @@ The @tech{custodian box} becomes ready when its custodian is shut down;
@defproc[(custodian-box-value [cb custodian-box?]) any]{Returns the
value in the given @tech{custodian box}, or @racket[#f] if the value
has been removed.}
@defproc[(custodian-tidy-callback? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] represents the registration of a
@tech{tidy callback}, @racket[#f] otherwise.
@history[#:added "6.0.1.7"]}
@defproc[(custodian-add-tidy! [cust custodian?]
[proc (custodian-tidy-callback? . -> . any)])
custodian-tidy-callback?]{
Registers @racket[proc] as a @tech{tidy callback} in @racket[cust], so
that @racket[proc] is called when @racket[custodian-tidy-all] is
applied to @racket[cust] or any of its superordinates.
The result value represents the registration of the callback and can
be used with @racket[custodian-remove-tidy!] to unregister the callback.
When @racket[proc] is called as a @tech{tidy callback}, it is passed
the same value that is returned by @racket[custodian-add-tidy!] so
that @racket[proc] can conveniently unregister itself. The call of
@racket[proc] is within a @tech{continuation barrier}.
All registered @tech{tidy callbacks} are preserved in @racket[cust]
until they are explicitly removed with @racket[custodian-remove-tidy!]
or the custodian is shut down with @racket[custodian-shutdown-all].
If @racket[cust] has been shut down already, the @exnraise[exn:fail:contract].
@history[#:added "6.0.1.7"]}
@defproc[(custodian-remove-tidy! [tidy custodian-tidy-callback?]) void?]{
Unregisters the @tech{tidy callback} that was registered by the
@racket[custodian-add-tidy!] call that produced @racket[tidy].
If the registration represented by @racket[tidy] has been removed already,
then @racket[custodian-remove-tidy!] has no effect.
@history[#:added "6.0.1.7"]}
@defproc[(custodian-tidy-all [cust custodian?]) void?]{
Calls all @tech{tidy callbacks} registered with @racket[cust] (and its
subordinates).
The @tech{tidy callbacks} to call are collected from @racket[cust]
before the first one is called. If a @tech{tidy callback} registers a
new @tech{tidy callback}, the new one is @emph{not} called. If a
@tech{tidy callback} raises an exception or otherwise escapes, then
the remaining @tech{tidy callbacks} are not called.
@history[#:added "6.0.1.7"]}

8
pkgs/racket-pkgs/racket-doc/scribblings/reference/eval-model.scrbl
View File

@ -850,14 +850,6 @@ down, if a procedure is called that attempts to create a managed resource (e.g.,
@racket[open-input-file], @racket[thread]), then the
@exnraise[exn:fail:contract].
A @tech{custodian} also supports @deftech{tidy callbacks}, which are
normally triggered just before a Racket process or @tech{place} exits.
For example, a @tech{tidy callback} might flush an output port's
buffer. A tidying custodian calls its own callbacks as well as the
tidy callbacks of its subcustodians, but there is no guarantee that a
tidy callback will be called before exit. Shutting down a
custodian does @emph{not} call tidy callbacks.
A thread can have multiple managing custodians, and a suspended thread
created with @racket[thread/suspend-to-kill] can have zero
custodians. Extra custodians become associated with a thread through

2
pkgs/racket-pkgs/racket-doc/scribblings/reference/exit.scrbl
View File

@ -16,7 +16,7 @@ A @tech{parameter} that determines the current @deftech{exit handler}. The
@tech{exit handler} is called by @racket[exit].
The default @tech{exit handler} in the Racket executable
takes any argument, calls @racket[custodian-tidy-all] on the root custodian,
takes any argument, calls @racket[plumber-flush-all] on the original plumber,
and shuts down the OS-level Racket process. The
argument is used as the OS-level exit code if it is an exact integer
between @racket[1] and @racket[255] (which normally means

4
pkgs/racket-pkgs/racket-doc/scribblings/reference/file-ports.scrbl
View File

@ -43,8 +43,8 @@ recognizes file-stream ports.
When an input or output file-stream port is created, it is placed into
the management of the current custodian (see
@secref["custodians"]). In the case of an output port, a @tech{tidy
callback} is registered to flush the port.
@secref["custodians"]). In the case of an output port, a @tech{flush
callback} is registered with the @tech{current plumber} to flush the port.
@defproc[(open-input-file [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary]

103
pkgs/racket-pkgs/racket-doc/scribblings/reference/plumbers.scrbl Normal file
View File

@ -0,0 +1,103 @@
#lang scribble/doc
@(require "mz.rkt")
@title[#:tag "plumbers"]{Plumbers}
A @deftech{plumber} supports @deftech{flush callbacks}, which are
normally triggered just before a Racket process or @tech{place} exits.
For example, a @tech{flush callback} might flush an output port's
buffer.
There is no guarantee that a flush callback will be called before a
process terminates---either because the plumber is not the original
plumber that is flushed by the default @tech{exit handler}, or because
the process is terminated forcibly (e.g., through a custodian
shutdown).
@defproc[(plumber? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{plumber} value,
@racket[#f] otherwise.
@history[#:added "6.0.1.8"]}
@defproc[(make-plumber) pluber?]{
Creates a new @tech{plumber}.
Plumbers have no hierarchy (unlike @tech{custodians} or
@tech{inspectors}), but a @tech{flush callback} can be registered in
one plumber to call @racket[plumber-flush-all] with another plumber.
@history[#:added "6.0.1.8"]}
@defparam[current-plumber plumber plumber?]{
A @tech{parameter} that determines a @deftech{current plumber} for
@tech{flush callbacks}. For example, creating an output @tech{file
stream port} registers a @tech{flush callback} with the @tech{current
plumber} to flush the port as long as the port is opened.
@history[#:added "6.0.1.8"]}
@defproc[(plumber-flush-all [plumber plumber?]) void?]{
Calls all @tech{flush callbacks} that are registered with @racket[plumber].
The @tech{flush callbacks} to call are collected from @racket[plumber]
before the first one is called. If a @tech{flush callback} registers a
new @tech{flush callback}, the new one is @emph{not} called. If a
@tech{flush callback} raises an exception or otherwise escapes, then
the remaining @tech{flush callbacks} are not called.
@history[#:added "6.0.1.8"]}
@defproc[(plumber-flush-handle? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @deftech{flush handle}
represents the registration of a @tech{flush callback}, @racket[#f]
otherwise.
@history[#:added "6.0.1.8"]}
@defproc[(plumber-add-flush! [plumber plumber?]
[proc (plumber-flush-handle? . -> . any)]
[weak? any/c #f])
plumber-flush-handle?]{
Registers @racket[proc] as a @tech{flush callback} with @racket[plumber], so
that @racket[proc] is called when @racket[plumber-flush-all] is
applied to @racket[plumber].
The result @tech{flush handle} represents the registration of the
callback, and it can be used with @racket[plumber-flush-handle-remove!] to
unregister the callback.
The given @racket[proc] is reachable from the @tech{flush handle}, but
if @racket[weak?] is true, then @racket[plumber] retains only a
@tech{weak reference} to the result @tech{flush handle} (and
thus @racket[proc]).
When @racket[proc] is called as a @tech{flush callback}, it is passed
the same value that is returned by @racket[plumber-add-flush!] so
that @racket[proc] can conveniently unregister itself. The call of
@racket[proc] is within a @tech{continuation barrier}.
@history[#:added "6.0.1.8"]}
@defproc[(plumber-flush-handle-remove! [handle plumber-flush-handle?]) void?]{
Unregisters the @tech{flush callback} that was registered by the
@racket[plumber-add-flush!] call that produced @racket[handle].
If the registration represented by @racket[handle] has been removed already,
then @racket[plumber-flush-handle-remove!] has no effect.
@history[#:added "6.0.1.8"]}

4
pkgs/racket-pkgs/racket-doc/scribblings/reference/port-lib.scrbl
View File

@ -423,8 +423,8 @@ The resulting output port does not support atomic writes. An explicit
flush or special-write to the output port can hang if the most
recently written bytes form an incomplete encoding sequence.
When the port is buffered, a @tech{tidy callback} is registered with
the current custodian (see @secref["custodians"]) to flush the buffer.}
When the port is buffered, a @tech{flush callback} is registered with
the @tech{current plumber} to flush the buffer.}
@defproc[(dup-input-port [in input-port?]

1
pkgs/racket-pkgs/racket-doc/scribblings/reference/security.scrbl
View File

@ -16,4 +16,5 @@
@include-section["thread-groups.scrbl"]
@include-section["struct-inspectors.scrbl"]
@include-section["code-inspectors.scrbl"]
@include-section["plumbers.scrbl"]
@include-section["sandbox.scrbl"]

14
pkgs/racket-pkgs/racket-test/tests/racket/place-tidy.rkt → pkgs/racket-pkgs/racket-test/tests/racket/place-plumber.rkt
View File

@ -4,19 +4,19 @@
(define (go)
(place
pch
(custodian-add-tidy! (current-custodian)
(lambda (e)
(custodian-remove-tidy! e)
(place-channel-put pch 'done)))
(plumber-add-flush! (current-plumber)
(lambda (e)
(plumber-flush-handle-remove! e)
(place-channel-put pch 'done)))
(place-channel-put pch 'ready)
(define mode (place-channel-get pch))
(case mode
[(exit) (exit 2)]
[(error)
(error-display-handler void)
(custodian-add-tidy! (current-custodian)
(lambda (e)
(error "fail")))]
(plumber-add-flush! (current-plumber)
(lambda (e)
(error "fail")))]
[else (void)])))
(module+ main

6
pkgs/racket-pkgs/racket-test/tests/racket/portlib.rktl
View File

@ -790,9 +790,9 @@
(test #\c read-char ei)
(test eof read-char ei))))
;; (check-buffering flush-output)
(let ([c (make-custodian)])
(parameterize ([current-custodian c])
(check-buffering (lambda (o) (custodian-tidy-all c))))))
(let ([p (make-plumber)])
(parameterize ([current-plumber p])
(check-buffering (lambda (o) (plumber-flush-all p))))))
(err/rt-test
(port->bytes (reencode-input-port (open-input-bytes #"\xFF\xFF") "utf-8"))

77
pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl
View File

@ -1180,66 +1180,69 @@
(test #f thread-running? t2))
;; ----------------------------------------
;; custodian exits
;; plumbers
(let ()
(define c (make-custodian))
(define c (make-plumber))
(test #t plumber? c)
(define done 0)
(define e (custodian-add-tidy! c (lambda (e) (set! done (add1 done)))))
(define e (plumber-add-flush! c (lambda (e) (set! done (add1 done)))))
(test #t custodian-tidy-callback? e)
(test #f custodian-tidy-callback? c)
(test #t plumber-flush-handle? e)
(test #f plumber-flush-handle? c)
(test #f ormap custodian-tidy-callback?
(custodian-managed-list c (current-custodian)))
(plumber-flush-handle-remove! e)
(plumber-flush-handle-remove! e) ; no-op
(custodian-remove-tidy! e)
(custodian-remove-tidy! e) ; no-op
(custodian-tidy-all c)
(plumber-flush-all c)
(test 0 values done)
(define e2 (custodian-add-tidy! c (lambda (e) (set! done (add1 done)))))
(custodian-tidy-all c)
(define e2 (plumber-add-flush! c (lambda (e) (set! done (add1 done)))))
(plumber-flush-all c)
(test 1 values done)
(custodian-remove-tidy! e2)
(plumber-flush-handle-remove! e2)
(define e3 (custodian-add-tidy! (make-custodian c) (lambda (e) (set! done (add1 done)))))
(custodian-tidy-all c)
(define e3 (plumber-add-flush! c (lambda (e) (set! done (add1 done)))))
(plumber-flush-all c)
(test 2 values done)
(custodian-tidy-all c)
(plumber-flush-all c)
(test 3 values done)
(custodian-remove-tidy! e3)
(plumber-flush-handle-remove! e3)
(custodian-add-tidy! c (lambda (e)
(custodian-remove-tidy! e)
(plumber-add-flush! c (lambda (e)
(plumber-flush-handle-remove! e)
(set! done (add1 done))
(custodian-add-tidy! c (lambda (e)
(custodian-remove-tidy! e)
(set! done (add1 done))))))
(custodian-tidy-all c)
(plumber-add-flush! c (lambda (e)
(plumber-flush-handle-remove! e)
(set! done (add1 done))))))
(plumber-flush-all c)
(test 4 values done)
(custodian-tidy-all c)
(plumber-flush-all c)
(test 5 values done)
(custodian-tidy-all c)
(plumber-flush-all c)
(test 5 values done)
(define e5 (custodian-add-tidy! c (lambda (e) (error "oops1"))))
(err/rt-test (custodian-tidy-all c) exn:fail?)
(err/rt-test (custodian-tidy-all c) exn:fail?)
(custodian-remove-tidy! e5)
(test (void) custodian-tidy-all c)
(define e5 (plumber-add-flush! c (lambda (e) (error "oops1"))))
(err/rt-test (plumber-flush-all c) exn:fail?)
(err/rt-test (plumber-flush-all c) exn:fail?)
(plumber-flush-handle-remove! e5)
(test (void) plumber-flush-all c)
(custodian-add-tidy! c (lambda (e) (set! done (add1 done))))
(custodian-shutdown-all c)
(test 5 values done)
(custodian-tidy-all c)
(test 5 values done)
(err/rt-test (custodian-add-tidy! c (lambda (e) 'x))))
;; Weak reference:
(when (regexp-match #rx"3m" (path->bytes (system-library-subpath)))
(let ([h (plumber-add-flush! c (lambda (e) (set! done (add1 done))) #t)])
(collect-garbage)
(plumber-flush-all c)
(test 6 values done)
(set! h #f)
(collect-garbage)
(plumber-flush-all c)
(test 6 values done))))
;; ----------------------------------------

15
racket/collects/racket/port.rkt
View File

@ -1637,8 +1637,8 @@
[buffer-mode (or (file-stream-buffer-mode port) 'block)]
[debuffer-buf #f]
[newline-buffer #f]
[cust (current-custodian)]
[tidy-callback #f]
[plumber (current-plumber)]
[flush-handle #f]
[self #f])
(define-values (buffered-r buffered-w) (make-pipe 4096))
@ -1868,11 +1868,12 @@
(define (buffering! on?)
(cond
[(and on? (not tidy-callback))
(set! tidy-callback (custodian-add-tidy! cust (lambda (e) (flush-output self))))]
[(and (not on?) tidy-callback)
(custodian-remove-tidy! tidy-callback)
(set! tidy-callback #f)]))
[(and on? (not flush-handle))
(set! flush-handle (plumber-add-flush! plumber (lambda (fh) (flush-output self))))]
[(and (not on?) flush-handle)
(define h flush-handle)
(set! flush-handle #f)
(plumber-flush-handle-remove! h)]))
;; Try to flush immediately a certain number of bytes.
;; we've already converted them, so we have to keep

2
racket/src/racket/cmdline.inc
View File

@ -602,7 +602,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
}
#endif
if (scheme_tidy_managed(NULL, 1))
if (scheme_flush_managed(NULL, 1))
exit_val = 1;
return exit_val;

4
racket/src/racket/include/mzwin.def
View File

@ -73,9 +73,11 @@ EXPORTS
scheme_custodian_is_available
scheme_remove_managed
scheme_close_managed
scheme_tidy_managed
scheme_schedule_custodian_close
scheme_add_custodian_extractor
scheme_flush_managed
scheme_add_flush
scheme_remove_flush
scheme_add_atexit_closer
scheme_add_evt
scheme_add_evt_through_sema

4
racket/src/racket/include/mzwin3m.def
View File

@ -73,9 +73,11 @@ EXPORTS
scheme_custodian_is_available
scheme_remove_managed
scheme_close_managed
scheme_tidy_managed
scheme_schedule_custodian_close
scheme_add_custodian_extractor
scheme_flush_managed
scheme_add_flush
scheme_remove_flush
scheme_add_atexit_closer
scheme_add_evt
scheme_add_evt_through_sema

4
racket/src/racket/include/racket.exp
View File

@ -71,9 +71,11 @@ scheme_custodian_check_available
scheme_custodian_is_available
scheme_remove_managed
scheme_close_managed
scheme_tidy_managed
scheme_schedule_custodian_close
scheme_add_custodian_extractor
scheme_flush_managed
scheme_add_flush
scheme_remove_flush
scheme_add_atexit_closer
scheme_add_evt
scheme_add_evt_through_sema

4
racket/src/racket/include/racket3m.exp
View File

@ -71,9 +71,11 @@ scheme_custodian_check_available
scheme_custodian_is_available
scheme_remove_managed
scheme_close_managed
scheme_tidy_managed
scheme_schedule_custodian_close
scheme_add_custodian_extractor
scheme_flush_managed
scheme_add_flush
scheme_remove_flush
scheme_add_atexit_closer
scheme_add_evt
scheme_add_evt_through_sema

3
racket/src/racket/include/scheme.h
View File

@ -545,6 +545,7 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_THREADP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
#define SCHEME_CUSTODIANP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
#define SCHEME_PLUMBERP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_plumber_type)
#define SCHEME_SEMAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
#define SCHEME_CHANNELP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_type)
#define SCHEME_CHANNEL_PUTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_put_type)
@ -1044,6 +1045,7 @@ typedef struct Scheme_Custodian *Scheme_Custodian_Reference;
typedef struct Scheme_Custodian Scheme_Custodian;
typedef Scheme_Bucket_Table Scheme_Thread_Cell_Table;
typedef struct Scheme_Config Scheme_Config;
typedef struct Scheme_Plumber Scheme_Plumber;
typedef int (*Scheme_Ready_Fun)(Scheme_Object *o);
typedef void (*Scheme_Needs_Wakeup_Fun)(Scheme_Object *, void *);
@ -1357,6 +1359,7 @@ enum {
MZCONFIG_CUSTODIAN,
MZCONFIG_INSPECTOR,
MZCONFIG_CODE_INSPECTOR,
MZCONFIG_PLUMBER,
MZCONFIG_USE_COMPILED_KIND,
MZCONFIG_USE_COMPILED_ROOTS,

2
racket/src/racket/include/schthread.h
View File

@ -251,6 +251,7 @@ typedef struct Thread_Local_Variables {
struct Scheme_Custodian *main_custodian_;
struct Scheme_Custodian *last_custodian_;
struct Scheme_Hash_Table *limited_custodians_;
struct Scheme_Plumber *initial_plumber_;
struct Scheme_Config *initial_config_;
struct Scheme_Thread *swap_target_;
struct Scheme_Object *scheduled_kills_;
@ -634,6 +635,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define main_custodian XOA (scheme_get_thread_local_variables()->main_custodian_)
#define last_custodian XOA (scheme_get_thread_local_variables()->last_custodian_)
#define limited_custodians XOA (scheme_get_thread_local_variables()->limited_custodians_)
#define initial_plumber XOA (scheme_get_thread_local_variables()->initial_plumber_)
#define initial_config XOA (scheme_get_thread_local_variables()->initial_config_)
#define swap_target XOA (scheme_get_thread_local_variables()->swap_target_)
#define scheduled_kills XOA (scheme_get_thread_local_variables()->scheduled_kills_)

1180
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
racket/src/racket/src/error.c
View File

@ -3358,7 +3358,7 @@ def_exit_handler_proc(int argc, Scheme_Object *argv[])
} else
status = 0;
scheme_tidy_managed(NULL, 0);
scheme_flush_managed(NULL, 0);
if (scheme_exit)
scheme_exit(status);

6
racket/src/racket/src/mzmark_place.inc
View File

@ -93,7 +93,8 @@ static int place_async_channel_val_MARK(void *p, struct NewGC *gc) {
gcMARK2(pac->msg_chains, gc);
gcMARK2(pac->wakeup_signal, gc);
/* mark master-allocated objects within each messages: */
/* mark master-allocated objects within each messages; the
raw pairs that form the list are embedded in each message block */
j = pac->out;
sz = pac->size;
for (i = pac->count; i--; ) {
@ -118,7 +119,8 @@ static int place_async_channel_val_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(pac->msg_chains, gc);
gcFIXUP2(pac->wakeup_signal, gc);
/* mark master-allocated objects within each messages: */
/* mark master-allocated objects within each messages; the
raw pairs that form the list are embedded in each message block */
j = pac->out;
sz = pac->size;
for (i = pac->count; i--; ) {

2
racket/src/racket/src/mzmark_port.inc
View File

@ -65,6 +65,7 @@ static int mark_input_fd_MARK(void *p, struct NewGC *gc) {
gcMARK2(fd->buffer, gc);
gcMARK2(fd->refcount, gc);
gcMARK2(fd->flush_handle, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_FD));
@ -75,6 +76,7 @@ static int mark_input_fd_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(fd->buffer, gc);
gcFIXUP2(fd->refcount, gc);
gcFIXUP2(fd->flush_handle, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_FD));

29
racket/src/racket/src/mzmark_thread.inc
View File

@ -426,3 +426,32 @@ static int mark_thread_cell_FIXUP(void *p, struct NewGC *gc) {
#define mark_thread_cell_IS_CONST_SIZE 1
static int mark_plumber_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Plumber));
}
static int mark_plumber_MARK(void *p, struct NewGC *gc) {
Scheme_Plumber *pl = (Scheme_Plumber *)p;
gcMARK2(pl->handles, gc);
gcMARK2(pl->weak_handles, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Plumber));
}
static int mark_plumber_FIXUP(void *p, struct NewGC *gc) {
Scheme_Plumber *pl = (Scheme_Plumber *)p;
gcFIXUP2(pl->handles, gc);
gcFIXUP2(pl->weak_handles, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Plumber));
}
#define mark_plumber_IS_ATOMIC 0
#define mark_plumber_IS_CONST_SIZE 1

12
racket/src/racket/src/mzmarksrc.c
View File

@ -1727,6 +1727,7 @@ mark_input_fd {
gcMARK2(fd->buffer, gc);
gcMARK2(fd->refcount, gc);
gcMARK2(fd->flush_handle, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_FD));
@ -2059,6 +2060,17 @@ mark_thread_cell {
gcBYTES_TO_WORDS(sizeof(Thread_Cell));
}
mark_plumber {
mark:
Scheme_Plumber *pl = (Scheme_Plumber *)p;
gcMARK2(pl->handles, gc);
gcMARK2(pl->weak_handles, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Plumber));
}
END thread;
/**********************************************************************/

2
racket/src/racket/src/place.c
View File

@ -2605,7 +2605,7 @@ static void terminate_current_place(Scheme_Object *result)
mzrt_mutex_unlock(place_obj->lock);
if (!place_obj_die) {
if (scheme_tidy_managed(NULL, 1))
if (scheme_flush_managed(NULL, 1))
result = scheme_make_integer(1);
}

8
racket/src/racket/src/port.c
View File

@ -287,6 +287,7 @@ typedef struct Scheme_FD {
char textmode; /* Windows: textmode => CRLF conversion; SOME_FDS_... => select definitely works */
unsigned char *buffer;
int *refcount;
Scheme_Object *flush_handle; /* output port: registration with plumber */
# ifdef WINDOWS_FILE_HANDLES
Win_FD_Input_Thread *th; /* input mode */
@ -8235,6 +8236,8 @@ fd_close_output(Scheme_Output_Port *port)
}
#endif
scheme_remove_flush(fop->flush_handle);
/* Make sure no close happened while we blocked above! */
if (port->closed)
return;
@ -8316,7 +8319,7 @@ make_fd_output_port(intptr_t fd, Scheme_Object *name, int regfile, int win_textm
{
Scheme_FD *fop;
unsigned char *bfr;
Scheme_Object *the_port;
Scheme_Object *the_port, *fh;
int start_closed = 0;
fop = MALLOC_ONE_RT(Scheme_FD);
@ -8373,6 +8376,9 @@ make_fd_output_port(intptr_t fd, Scheme_Object *name, int regfile, int win_textm
1);
((Scheme_Port *)the_port)->buffer_mode_fun = fd_output_buffer_mode;
fh = scheme_add_flush(NULL, the_port, 0);
fop->flush_handle = fh;
if (start_closed)
scheme_close_output_port(the_port);

5
racket/src/racket/src/schemef.h
View File

@ -163,10 +163,13 @@ MZ_EXTERN void scheme_custodian_check_available(Scheme_Custodian *m, const char
MZ_EXTERN int scheme_custodian_is_available(Scheme_Custodian *m);
MZ_EXTERN void scheme_remove_managed(Scheme_Custodian_Reference *m, Scheme_Object *o);
MZ_EXTERN void scheme_close_managed(Scheme_Custodian *m);
MZ_EXTERN int scheme_tidy_managed(Scheme_Custodian *m, int catch_errors);
MZ_EXTERN void scheme_schedule_custodian_close(Scheme_Custodian *c);
MZ_EXTERN void scheme_add_custodian_extractor(Scheme_Type t, Scheme_Custodian_Extractor e);
MZ_EXTERN int scheme_flush_managed(Scheme_Plumber *p, int catch_errors);
MZ_EXTERN Scheme_Object *scheme_add_flush(Scheme_Plumber *p, Scheme_Object *proc_or_port, int weak_flush);
MZ_EXTERN void scheme_remove_flush(Scheme_Object *h);
MZ_EXTERN void scheme_add_atexit_closer(Scheme_Exit_Closer_Func f);
MZ_EXTERN void scheme_add_evt(Scheme_Type type,

4
racket/src/racket/src/schemex.h
View File

@ -116,9 +116,11 @@ void (*scheme_custodian_check_available)(Scheme_Custodian *m, const char *who, c
int (*scheme_custodian_is_available)(Scheme_Custodian *m);
void (*scheme_remove_managed)(Scheme_Custodian_Reference *m, Scheme_Object *o);
void (*scheme_close_managed)(Scheme_Custodian *m);
int (*scheme_tidy_managed)(Scheme_Custodian *m, int catch_errors);
void (*scheme_schedule_custodian_close)(Scheme_Custodian *c);
void (*scheme_add_custodian_extractor)(Scheme_Type t, Scheme_Custodian_Extractor e);
int (*scheme_flush_managed)(Scheme_Plumber *p, int catch_errors);
Scheme_Object *(*scheme_add_flush)(Scheme_Plumber *p, Scheme_Object *proc_or_port, int weak_flush);
void (*scheme_remove_flush)(Scheme_Object *h);
void (*scheme_add_atexit_closer)(Scheme_Exit_Closer_Func f);
void (*scheme_add_evt)(Scheme_Type type,
Scheme_Ready_Fun ready,

4
racket/src/racket/src/schemex.inc
View File

@ -79,9 +79,11 @@
scheme_extension_table->scheme_custodian_is_available = scheme_custodian_is_available;
scheme_extension_table->scheme_remove_managed = scheme_remove_managed;
scheme_extension_table->scheme_close_managed = scheme_close_managed;
scheme_extension_table->scheme_tidy_managed = scheme_tidy_managed;
scheme_extension_table->scheme_schedule_custodian_close = scheme_schedule_custodian_close;
scheme_extension_table->scheme_add_custodian_extractor = scheme_add_custodian_extractor;
scheme_extension_table->scheme_flush_managed = scheme_flush_managed;
scheme_extension_table->scheme_add_flush = scheme_add_flush;
scheme_extension_table->scheme_remove_flush = scheme_remove_flush;
scheme_extension_table->scheme_add_atexit_closer = scheme_add_atexit_closer;
scheme_extension_table->scheme_add_evt = scheme_add_evt;
scheme_extension_table->scheme_add_evt_through_sema = scheme_add_evt_through_sema;

4
racket/src/racket/src/schemexm.h
View File

@ -79,9 +79,11 @@
#define scheme_custodian_is_available (scheme_extension_table->scheme_custodian_is_available)
#define scheme_remove_managed (scheme_extension_table->scheme_remove_managed)
#define scheme_close_managed (scheme_extension_table->scheme_close_managed)
#define scheme_tidy_managed (scheme_extension_table->scheme_tidy_managed)
#define scheme_schedule_custodian_close (scheme_extension_table->scheme_schedule_custodian_close)
#define scheme_add_custodian_extractor (scheme_extension_table->scheme_add_custodian_extractor)
#define scheme_flush_managed (scheme_extension_table->scheme_flush_managed)
#define scheme_add_flush (scheme_extension_table->scheme_add_flush)
#define scheme_remove_flush (scheme_extension_table->scheme_remove_flush)
#define scheme_add_atexit_closer (scheme_extension_table->scheme_add_atexit_closer)
#define scheme_add_evt (scheme_extension_table->scheme_add_evt)
#define scheme_add_evt_through_sema (scheme_extension_table->scheme_add_evt_through_sema)

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1121
#define EXPECTED_PRIM_COUNT 1124
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.0.1.7"
#define MZSCHEME_VERSION "6.0.1.8"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

153
racket/src/racket/src/stypes.h
View File

@ -211,87 +211,88 @@ enum {
scheme_environment_variables_type, /* 187 */
scheme_filesystem_change_evt_type, /* 188 */
scheme_ctype_type, /* 189 */
scheme_custodian_tidy_type, /* 190 */
scheme_plumber_type, /* 190 */
scheme_plumber_handle_type, /* 191 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 191 */
_scheme_last_normal_type_, /* 192 */
scheme_rt_weak_array, /* 192 */
scheme_rt_weak_array, /* 193 */
scheme_rt_comp_env, /* 193 */
scheme_rt_constant_binding, /* 194 */
scheme_rt_resolve_info, /* 195 */
scheme_rt_unresolve_info, /* 196 */
scheme_rt_optimize_info, /* 197 */
scheme_rt_compile_info, /* 198 */
scheme_rt_cont_mark, /* 199 */
scheme_rt_saved_stack, /* 200 */
scheme_rt_reply_item, /* 201 */
scheme_rt_closure_info, /* 202 */
scheme_rt_overflow, /* 203 */
scheme_rt_overflow_jmp, /* 204 */
scheme_rt_meta_cont, /* 205 */
scheme_rt_dyn_wind_cell, /* 206 */
scheme_rt_dyn_wind_info, /* 207 */
scheme_rt_dyn_wind, /* 208 */
scheme_rt_dup_check, /* 209 */
scheme_rt_thread_memory, /* 210 */
scheme_rt_input_file, /* 211 */
scheme_rt_input_fd, /* 212 */
scheme_rt_oskit_console_input, /* 213 */
scheme_rt_tested_input_file, /* 214 */
scheme_rt_tested_output_file, /* 215 */
scheme_rt_indexed_string, /* 216 */
scheme_rt_output_file, /* 217 */
scheme_rt_load_handler_data, /* 218 */
scheme_rt_pipe, /* 219 */
scheme_rt_beos_process, /* 220 */
scheme_rt_system_child, /* 221 */
scheme_rt_tcp, /* 222 */
scheme_rt_write_data, /* 223 */
scheme_rt_tcp_select_info, /* 224 */
scheme_rt_param_data, /* 225 */
scheme_rt_will, /* 226 */
scheme_rt_linker_name, /* 227 */
scheme_rt_param_map, /* 228 */
scheme_rt_finalization, /* 229 */
scheme_rt_finalizations, /* 230 */
scheme_rt_cpp_object, /* 231 */
scheme_rt_cpp_array_object, /* 232 */
scheme_rt_stack_object, /* 233 */
scheme_rt_preallocated_object, /* 234 */
scheme_thread_hop_type, /* 235 */
scheme_rt_srcloc, /* 236 */
scheme_rt_evt, /* 237 */
scheme_rt_syncing, /* 238 */
scheme_rt_comp_prefix, /* 239 */
scheme_rt_user_input, /* 240 */
scheme_rt_user_output, /* 241 */
scheme_rt_compact_port, /* 242 */
scheme_rt_read_special_dw, /* 243 */
scheme_rt_regwork, /* 244 */
scheme_rt_rx_lazy_string, /* 245 */
scheme_rt_buf_holder, /* 246 */
scheme_rt_parameterization, /* 247 */
scheme_rt_print_params, /* 248 */
scheme_rt_read_params, /* 249 */
scheme_rt_native_code, /* 250 */
scheme_rt_native_code_plus_case, /* 251 */
scheme_rt_jitter_data, /* 252 */
scheme_rt_module_exports, /* 253 */
scheme_rt_delay_load_info, /* 254 */
scheme_rt_marshal_info, /* 255 */
scheme_rt_unmarshal_info, /* 256 */
scheme_rt_runstack, /* 257 */
scheme_rt_sfs_info, /* 258 */
scheme_rt_validate_clearing, /* 259 */
scheme_rt_avl_node, /* 260 */
scheme_rt_lightweight_cont, /* 261 */
scheme_rt_export_info, /* 262 */
scheme_rt_cont_jmp, /* 263 */
scheme_rt_letrec_check_frame, /* 264 */
scheme_rt_comp_env, /* 194 */
scheme_rt_constant_binding, /* 195 */
scheme_rt_resolve_info, /* 196 */
scheme_rt_unresolve_info, /* 197 */
scheme_rt_optimize_info, /* 198 */
scheme_rt_compile_info, /* 199 */
scheme_rt_cont_mark, /* 200 */
scheme_rt_saved_stack, /* 201 */
scheme_rt_reply_item, /* 202 */
scheme_rt_closure_info, /* 203 */
scheme_rt_overflow, /* 204 */
scheme_rt_overflow_jmp, /* 205 */
scheme_rt_meta_cont, /* 206 */
scheme_rt_dyn_wind_cell, /* 207 */
scheme_rt_dyn_wind_info, /* 208 */
scheme_rt_dyn_wind, /* 209 */
scheme_rt_dup_check, /* 210 */
scheme_rt_thread_memory, /* 211 */
scheme_rt_input_file, /* 212 */
scheme_rt_input_fd, /* 213 */
scheme_rt_oskit_console_input, /* 214 */
scheme_rt_tested_input_file, /* 215 */
scheme_rt_tested_output_file, /* 216 */
scheme_rt_indexed_string, /* 217 */
scheme_rt_output_file, /* 218 */
scheme_rt_load_handler_data, /* 219 */
scheme_rt_pipe, /* 220 */
scheme_rt_beos_process, /* 221 */
scheme_rt_system_child, /* 222 */
scheme_rt_tcp, /* 223 */
scheme_rt_write_data, /* 224 */
scheme_rt_tcp_select_info, /* 225 */
scheme_rt_param_data, /* 226 */
scheme_rt_will, /* 227 */
scheme_rt_linker_name, /* 228 */
scheme_rt_param_map, /* 229 */
scheme_rt_finalization, /* 230 */
scheme_rt_finalizations, /* 231 */
scheme_rt_cpp_object, /* 232 */
scheme_rt_cpp_array_object, /* 233 */
scheme_rt_stack_object, /* 234 */
scheme_rt_preallocated_object, /* 235 */
scheme_thread_hop_type, /* 236 */
scheme_rt_srcloc, /* 237 */
scheme_rt_evt, /* 238 */
scheme_rt_syncing, /* 239 */
scheme_rt_comp_prefix, /* 240 */
scheme_rt_user_input, /* 241 */
scheme_rt_user_output, /* 242 */
scheme_rt_compact_port, /* 243 */
scheme_rt_read_special_dw, /* 244 */
scheme_rt_regwork, /* 245 */
scheme_rt_rx_lazy_string, /* 246 */
scheme_rt_buf_holder, /* 247 */
scheme_rt_parameterization, /* 248 */
scheme_rt_print_params, /* 249 */
scheme_rt_read_params, /* 250 */
scheme_rt_native_code, /* 251 */
scheme_rt_native_code_plus_case, /* 252 */
scheme_rt_jitter_data, /* 253 */
scheme_rt_module_exports, /* 254 */
scheme_rt_delay_load_info, /* 255 */
scheme_rt_marshal_info, /* 256 */
scheme_rt_unmarshal_info, /* 257 */
scheme_rt_runstack, /* 258 */
scheme_rt_sfs_info, /* 259 */
scheme_rt_validate_clearing, /* 260 */
scheme_rt_avl_node, /* 261 */
scheme_rt_lightweight_cont, /* 262 */
scheme_rt_export_info, /* 263 */
scheme_rt_cont_jmp, /* 264 */
scheme_rt_letrec_check_frame, /* 265 */
#endif
scheme_deferred_expr_type, /* 265 */
scheme_deferred_expr_type, /* 266 */
_scheme_last_type_
};

388
racket/src/racket/src/thread.c
View File

@ -192,6 +192,8 @@ THREAD_LOCAL_DECL(static Scheme_Custodian *last_custodian);
THREAD_LOCAL_DECL(static Scheme_Hash_Table *limited_custodians = NULL);
READ_ONLY static Scheme_Object *initial_inspector;
THREAD_LOCAL_DECL(static Scheme_Custodian *initial_plumber);
THREAD_LOCAL_DECL(Scheme_Config *initial_config);
#ifndef MZ_PRECISE_GC
@ -316,6 +318,12 @@ typedef struct {
intptr_t size;
} Scheme_Phantom_Bytes;
struct Scheme_Plumber {
Scheme_Object so;
Scheme_Hash_Table *handles;
Scheme_Bucket_Table *weak_handles;
};
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -357,10 +365,6 @@ static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_tidy_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_add_tidy(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_remove_tidy(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_tidy_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_custodian(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[]);
@ -368,6 +372,14 @@ static Scheme_Object *custodian_box_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_box_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_add_flush(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_remove_flush(int argc, Scheme_Object *argv[]);
static Scheme_Object *plumber_flush_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_plumber(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_namespace(int argc, Scheme_Object *args[]);
static Scheme_Object *namespace_p(int argc, Scheme_Object *args[]);
@ -534,16 +546,20 @@ void scheme_init_thread(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("make-custodian" , make_custodian , 0, 1, env);
GLOBAL_FOLDING_PRIM("custodian?" , custodian_p , 1, 1, 1 , env);
GLOBAL_PRIM_W_ARITY("custodian-shutdown-all", custodian_close_all , 1, 1, env);
GLOBAL_PRIM_W_ARITY("custodian-tidy-all" , custodian_tidy_all , 1, 1, env);
GLOBAL_PRIM_W_ARITY("custodian-add-tidy!" , custodian_add_tidy , 2, 2, env);
GLOBAL_PRIM_W_ARITY("custodian-remove-tidy!", custodian_remove_tidy, 1, 1, env);
GLOBAL_PRIM_W_ARITY("custodian-tidy-callback?", custodian_tidy_p , 1, 1, env);
GLOBAL_PRIM_W_ARITY("custodian-managed-list", custodian_to_list , 2, 2, env);
GLOBAL_PRIM_W_ARITY("make-custodian-box" , make_custodian_box , 2, 2, env);
GLOBAL_PRIM_W_ARITY("custodian-box-value" , custodian_box_value , 1, 1, env);
GLOBAL_FOLDING_PRIM("custodian-box?" , custodian_box_p , 1, 1, 1 , env);
GLOBAL_PRIM_W_ARITY("call-in-nested-thread" , call_as_nested_thread, 1, 2, env);
GLOBAL_PARAMETER("current-plumber" , current_plumber , MZCONFIG_PLUMBER, env);
GLOBAL_PRIM_W_ARITY("make-plumber" , make_plumber , 0, 0, env);
GLOBAL_FOLDING_PRIM("plumber?" , plumber_p , 1, 1, 1 , env);
GLOBAL_PRIM_W_ARITY("plumber-flush-all" , plumber_flush_all , 1, 1, env);
GLOBAL_PRIM_W_ARITY("plumber-add-flush!" , plumber_add_flush , 2, 3, env);
GLOBAL_PRIM_W_ARITY("plumber-flush-handle-remove!" , plumber_remove_flush, 1, 1, env);
GLOBAL_PRIM_W_ARITY("plumber-flush-handle?" , plumber_flush_p , 1, 1, env);
GLOBAL_PARAMETER("current-namespace" , current_namespace, MZCONFIG_ENV, env);
GLOBAL_PRIM_W_ARITY("namespace?" , namespace_p , 1, 1, env);
@ -1481,97 +1497,6 @@ void scheme_close_managed(Scheme_Custodian *m)
scheme_current_thread->ran_some = 1;
}
static Scheme_Object *get_tidy_managed(Scheme_Custodian *m)
{
Scheme_Custodian *c, *start;
Scheme_Object *o, *r = scheme_null;
int i;
if (!m)
m = main_custodian;
if (m->shut_down)
return scheme_null;
for (c = m; CUSTODIAN_FAM(c->children); ) {
for (c = CUSTODIAN_FAM(c->children); CUSTODIAN_FAM(c->sibling); ) {
c = CUSTODIAN_FAM(c->sibling);
}
}
start = m;
m = c;
while (1) {
for (i = 0; i < m->count; i++) {
if (m->boxes[i]) {
o = xCUSTODIAN_FAM(m->boxes[i]);
if (o && (SCHEME_OUTPORTP(o)
|| SAME_TYPE(SCHEME_TYPE(o), scheme_custodian_tidy_type))) {
r = scheme_make_pair(o, r);
SCHEME_USE_FUEL(1);
}
}
}
if (SAME_OBJ(m, start))
break;
m = CUSTODIAN_FAM(m->global_prev);
if (!m) {
/* custodian was shut down? */
break;
}
}
return r;
}
int scheme_tidy_managed(Scheme_Custodian *m, int catch_errors)
{
Scheme_Object *r, *o;
Scheme_Thread *p;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf new_error_buf;
volatile int escaped = 0;
if (catch_errors) {
p = scheme_current_thread;
saved_error_buf = p->error_buf;
p->error_buf = &new_error_buf;
} else
saved_error_buf = NULL;
if (!scheme_setjmp(new_error_buf)) {
r = get_tidy_managed(m);
while (!SCHEME_NULLP(r)) {
o = SCHEME_CAR(r);
if (SCHEME_OUTPORTP(o)) {
scheme_flush_if_output_fds(o);
} else {
Scheme_Object *f, *a[1];
f = SCHEME_PTR1_VAL(o);
a[0] = o;
(void)scheme_apply_multi(f, 1, a);
}
r = SCHEME_CDR(r);
}
} else {
escaped = 1;
}
if (catch_errors)
scheme_current_thread->error_buf = saved_error_buf;
return escaped;
}
static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[])
{
Scheme_Custodian *m;
@ -1612,67 +1537,6 @@ static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *custodian_tidy_all(int argc, Scheme_Object *argv[])
{
if (!SCHEME_CUSTODIANP(argv[0]))
scheme_wrong_contract("custodian-tidy-all", "custodian?", 0, argc, argv);
scheme_tidy_managed((Scheme_Custodian *)argv[0], 0);
return scheme_void;
}
static Scheme_Object *custodian_add_tidy(int argc, Scheme_Object *argv[])
{
Scheme_Object *e;
Scheme_Custodian_Reference *mref;
Scheme_Custodian *m;
if (!SCHEME_CUSTODIANP(argv[0]))
scheme_wrong_contract("custodian-add-tidy!", "custodian?", 0, argc, argv);
scheme_check_proc_arity("custodian-add-tidy!", 1, 1, argc, argv);
m = (Scheme_Custodian *)argv[0];
if (!scheme_custodian_is_available(m))
scheme_contract_error("custodian-add-tidy!", "the custodian has been shut down",
"custodian", 1, m,
NULL);
e = scheme_alloc_object();
e->type = scheme_custodian_tidy_type;
SCHEME_PTR1_VAL(e) = argv[1];
mref = scheme_add_managed(m, e, NULL, NULL, 1);
SCHEME_PTR2_VAL(e) = mref;
return e;
}
static Scheme_Object *custodian_remove_tidy(int argc, Scheme_Object *argv[])
{
Scheme_Custodian_Reference *mref;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_custodian_tidy_type))
scheme_wrong_contract("custodian-remove-tidy!", "custodian-tidy-callback?", 0, argc, argv);
mref = SCHEME_PTR2_VAL(argv[0]);
if (mref) {
SCHEME_PTR2_VAL(argv[0]) = NULL;
scheme_remove_managed(mref, argv[0]);
}
return scheme_void;
}
static Scheme_Object *custodian_tidy_p(int argc, Scheme_Object *argv[])
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_custodian_tidy_type)
? scheme_true
: scheme_false);
}
Scheme_Custodian* scheme_custodian_extract_reference(Scheme_Custodian_Reference *mr)
{
return CUSTODIAN_FAM(mr);
@ -1766,7 +1630,7 @@ static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[])
o = ex(o);
}
if (o && !SAME_TYPE(SCHEME_TYPE(o), scheme_custodian_tidy_type)) {
if (o) {
hold[j] = o;
j++;
}
@ -2070,6 +1934,197 @@ void scheme_free_all(void)
#endif
}
/*========================================================================*/
/* plumbers */
/*========================================================================*/
#define FLUSH_HANDLE_FLAGS(h) MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)h)->iso)
Scheme_Object *get_plumber_handles(Scheme_Plumber *p)
{
Scheme_Object *v, *r = scheme_null;
Scheme_Bucket_Table *bt;
Scheme_Hash_Table *ht;
int i;
bt = p->weak_handles;
if (bt) {
for (i = bt->size; i--; ) {
if (bt->buckets[i]) {
v = (Scheme_Object *)HT_EXTRACT_WEAK(bt->buckets[i]->key);
if (v) {
r = scheme_make_pair(v, r);
SCHEME_USE_FUEL(1);
}
}
}
}
ht = p->handles;
for (i = ht->size; i--; ) {
if (ht->vals[i])
r = scheme_make_pair(ht->keys[i], r);
SCHEME_USE_FUEL(1);
}
return r;
}
int scheme_flush_managed(Scheme_Plumber *p, int catch_errors)
{
Scheme_Object *r, *h, *o, *a[1];
Scheme_Thread *pt;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf new_error_buf;
volatile int escaped = 0;
if (!p) p = initial_plumber;
if (catch_errors) {
pt = scheme_current_thread;
saved_error_buf = pt->error_buf;
pt->error_buf = &new_error_buf;
} else
saved_error_buf = NULL;
if (!scheme_setjmp(new_error_buf)) {
r = get_plumber_handles(p);
while (!SCHEME_NULLP(r)) {
h = SCHEME_CAR(r);
o = SCHEME_PTR2_VAL(h);
if (SCHEME_OUTPORTP(o)) {
scheme_flush_if_output_fds(o);
} else {
a[0] = h;
(void)scheme_apply_multi(o, 1, a);
}
r = SCHEME_CDR(r);
}
} else {
escaped = 1;
}
if (catch_errors)
scheme_current_thread->error_buf = saved_error_buf;
return escaped;
}
static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[])
{
Scheme_Plumber *p;
Scheme_Hash_Table *ht;
p = MALLOC_ONE_TAGGED(Scheme_Plumber);
p->so.type = scheme_plumber_type;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
p->handles = ht;
return (Scheme_Object *)p;
}
static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[])
{
return SCHEME_PLUMBERP(argv[0]) ? scheme_true : scheme_false;
}
static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PLUMBERP(argv[0]))
scheme_wrong_contract("plumber-flush-all", "plumber?", 0, argc, argv);
scheme_flush_managed((Scheme_Plumber *)argv[0], 0);
return scheme_void;
}
Scheme_Object *scheme_add_flush(Scheme_Plumber *p, Scheme_Object *proc_or_port, int weak_flush)
{
Scheme_Object *h;
if (!p)
p = (Scheme_Plumber *)scheme_get_param(scheme_current_config(), MZCONFIG_PLUMBER);
h = scheme_alloc_object();
h->type = scheme_plumber_handle_type;
SCHEME_PTR1_VAL(h) = (Scheme_Object *)p;
SCHEME_PTR2_VAL(h) = proc_or_port;
if (weak_flush) {
FLUSH_HANDLE_FLAGS(h) |= 0x1;
if (!p->weak_handles) {
Scheme_Bucket_Table *bt;
bt = scheme_make_bucket_table(4, SCHEME_hash_weak_ptr);
p->weak_handles = bt;
}
scheme_add_to_table(p->weak_handles, (const char *)h, scheme_true, 0);
} else
scheme_hash_set(p->handles, h, scheme_true);
return h;
}
static Scheme_Object *plumber_add_flush(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PLUMBERP(argv[0]))
scheme_wrong_contract("plumber-add-flush!", "plumber?", 0, argc, argv);
scheme_check_proc_arity("plumber-add-flush!", 1, 1, argc, argv);
return scheme_add_flush((Scheme_Plumber *)argv[0], argv[1],
(argc > 2) && SCHEME_TRUEP(argv[2]));
}
void scheme_remove_flush(Scheme_Object *h)
{
Scheme_Plumber *p;
p = (Scheme_Plumber *)SCHEME_PTR1_VAL(h);
if (p) {
if (FLUSH_HANDLE_FLAGS(h) & 0x1) {
Scheme_Bucket *b;
b = scheme_bucket_or_null_from_table(p->weak_handles, (char *)h, 0);
if (b) {
HT_EXTRACT_WEAK(b->key) = NULL;
b->val = NULL;
}
} else
scheme_hash_set(p->handles, h, NULL);
SCHEME_PTR1_VAL(h) = NULL;
SCHEME_PTR2_VAL(h) = NULL;
}
}
static Scheme_Object *plumber_remove_flush(int argc, Scheme_Object *argv[])
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_plumber_handle_type))
scheme_wrong_contract("plumber-flush-handle-remove!", "plumber-handle?", 0, argc, argv);
scheme_remove_flush(argv[0]);
return scheme_void;
}
static Scheme_Object *plumber_flush_p(int argc, Scheme_Object *argv[])
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_plumber_handle_type)
? scheme_true
: scheme_false);
}
static Scheme_Object *current_plumber(int argc, Scheme_Object *argv[])
{
return scheme_param_config2("current-plumber",
scheme_make_integer(MZCONFIG_PLUMBER),
argc, argv,
-1, plumber_p, "plumber?", 0);
}
/*========================================================================*/
/* thread sets */
/*========================================================================*/
@ -2667,7 +2722,7 @@ static void do_swap_thread()
{
intptr_t cpm;
cpm = scheme_get_process_milliseconds();
cpm = 0; // scheme_get_process_milliseconds();
scheme_current_thread->current_start_process_msec = cpm;
}
@ -2680,7 +2735,7 @@ static void do_swap_thread()
{
intptr_t cpm;
cpm = scheme_get_process_milliseconds();
cpm = 0; // scheme_get_process_milliseconds();
scheme_current_thread->accum_process_msec += (cpm - scheme_current_thread->current_start_process_msec);
}
@ -3006,7 +3061,7 @@ static void start_child(Scheme_Thread * volatile child,
{
intptr_t cpm;
cpm = scheme_get_process_milliseconds();
cpm = 0; // scheme_get_process_milliseconds();
scheme_current_thread->current_start_process_msec = cpm;
}
@ -7692,6 +7747,10 @@ static void make_initial_config(Scheme_Thread *p)
last_custodian = main_custodian;
init_param(cells, paramz, MZCONFIG_CUSTODIAN, (Scheme_Object *)main_custodian);
REGISTER_SO(initial_plumber);
initial_plumber = (Scheme_Plumber *)make_plumber(0, NULL);
init_param(cells, paramz, MZCONFIG_PLUMBER, (Scheme_Object *)initial_plumber);
init_param(cells, paramz, MZCONFIG_ALLOW_SET_UNDEFINED, (scheme_allow_set_undefined
? scheme_true
: scheme_false));
@ -9190,6 +9249,7 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_thread_set_type, mark_thread_set);
GC_REG_TRAV(scheme_config_type, mark_config);
GC_REG_TRAV(scheme_thread_cell_type, mark_thread_cell);
GC_REG_TRAV(scheme_plumber_type, mark_plumber);
GC_REG_TRAV(scheme_rt_param_data, mark_param_data);
GC_REG_TRAV(scheme_rt_will, mark_will);

5
racket/src/racket/src/type.c
View File

@ -227,7 +227,8 @@ scheme_init_type ()
set_name(scheme_custodian_type, "<custodian>");
set_name(scheme_cust_box_type, "<custodian-box>");
set_name(scheme_custodian_tidy_type, "<custodian-tidy-callback>");
set_name(scheme_plumber_type, "<plumber>");
set_name(scheme_plumber_handle_type, "<plumber-flush-handle>");
set_name(scheme_cont_mark_set_type, "<continuation-mark-set>");
set_name(scheme_cont_mark_chain_type, "<chain>");
@ -728,7 +729,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_environment_variables_type, small_object);
GC_REG_TRAV(scheme_custodian_tidy_type, twoptr_obj);
GC_REG_TRAV(scheme_plumber_handle_type, twoptr_obj);
}
END_XFORM_SKIP;