add custodian-tidy-all
This commit is contained in:
Matthew Flatt
parent
0ba8cd9586
commit
1bd604073a
|
|
@ -24,7 +24,8 @@ automatically directed to shut down its managed values as well.}
|
|||
|
||||
@defproc[(custodian-shutdown-all [cust custodian?]) void?]{
|
||||
|
||||
@margin-note{In GRacket, @|eventspaces| managed by @racket[cust] are also
|
||||
@margin-note{In @racketmodname[racket/gui/base],
|
||||
@|eventspaces| managed by @racket[cust] are also
|
||||
shut down.}
|
||||
|
||||
Closes all @tech{file-stream ports}, @tech{TCP ports}, @tech{TCP
|
||||
|
|
@ -40,7 +41,8 @@ thread.}
|
|||
|
||||
@defparam[current-custodian cust custodian?]{
|
||||
|
||||
@margin-note{In GRacket, custodians also manage @|eventspaces|.}
|
||||
@margin-note{Custodians also manage @|eventspaces|
|
||||
from @racketmodname[racket/gui/base].}
|
||||
|
||||
A @tech{parameter} that determines a custodian that assumes responsibility
|
||||
for newly created threads, @tech{file-stream ports}, TCP ports,
|
||||
|
|
@ -126,3 +128,60 @@ 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"]}
|
||||
|
|
|
|||
|
|
@ -833,7 +833,8 @@ created, it is placed under the management of the @deftech{current
|
|||
custodian} as determined by the @racket[current-custodian]
|
||||
@tech{parameter}.
|
||||
|
||||
@margin-note{In GRacket, custodians also manage eventspaces.}
|
||||
@margin-note{Custodians also manage eventspaces from
|
||||
@racketmodname[racket/gui/base].}
|
||||
|
||||
Except for the root custodian, every @tech{custodian} itself is
|
||||
managed by a @tech{custodian}, so that custodians form a hierarchy.
|
||||
|
|
@ -849,6 +850,14 @@ 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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@ 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 and shuts down the OS-level Racket process. The
|
||||
takes any argument, calls @racket[custodian-tidy-all] on the root custodian,
|
||||
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
|
||||
``failure''); otherwise, the exit code is @racket[0], (which normally
|
||||
|
|
|
|||
|
|
@ -43,7 +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"]).
|
||||
@secref["custodians"]). In the case of an output port, a @tech{tidy
|
||||
callback} is registered to flush the port.
|
||||
|
||||
@defproc[(open-input-file [path path-string?]
|
||||
[#:mode mode-flag (or/c 'binary 'text) 'binary]
|
||||
|
|
|
|||
49
pkgs/racket-pkgs/racket-test/tests/racket/place-tidy.rkt
Normal file
49
pkgs/racket-pkgs/racket-test/tests/racket/place-tidy.rkt
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
#lang racket/base
|
||||
(require racket/place)
|
||||
|
||||
(define (go)
|
||||
(place
|
||||
pch
|
||||
(custodian-add-tidy! (current-custodian)
|
||||
(lambda (e)
|
||||
(custodian-remove-tidy! 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")))]
|
||||
[else (void)])))
|
||||
|
||||
(module+ main
|
||||
(require rackunit)
|
||||
|
||||
(define p1 (go))
|
||||
(check-equal? 'ready (place-channel-get p1))
|
||||
(place-channel-put p1 'normal)
|
||||
(check-equal? 0 (place-wait p1))
|
||||
(check-equal? 'done (place-channel-get p1))
|
||||
|
||||
(define p2 (go))
|
||||
(check-equal? 'ready (place-channel-get p2))
|
||||
(place-channel-put p2 'exit)
|
||||
(check-equal? 2 (place-wait p2))
|
||||
(check-equal? 'done (place-channel-get p2))
|
||||
|
||||
(define p3 (go))
|
||||
(check-equal? 'ready (place-channel-get p3))
|
||||
(place-kill p3)
|
||||
(check-equal? 1 (place-wait p3))
|
||||
(check-equal? #f (sync/timeout 0.1 p3))
|
||||
|
||||
(define p4 (go))
|
||||
(check-equal? 'ready (place-channel-get p4))
|
||||
(place-channel-put p4 'error)
|
||||
(check-equal? 1 (place-wait p4)))
|
||||
|
||||
(module+ test
|
||||
(require (submod ".." main)))
|
||||
|
|
@ -1179,6 +1179,68 @@
|
|||
(test #f thread-running? t1)
|
||||
(test #f thread-running? t2))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; custodian exits
|
||||
|
||||
(let ()
|
||||
(define c (make-custodian))
|
||||
|
||||
(define done 0)
|
||||
|
||||
(define e (custodian-add-tidy! c (lambda (e) (set! done (add1 done)))))
|
||||
|
||||
(test #t custodian-tidy-callback? e)
|
||||
(test #f custodian-tidy-callback? c)
|
||||
|
||||
(test #f ormap custodian-tidy-callback?
|
||||
(custodian-managed-list c (current-custodian)))
|
||||
|
||||
(custodian-remove-tidy! e)
|
||||
(custodian-remove-tidy! e) ; no-op
|
||||
|
||||
(custodian-tidy-all c)
|
||||
(test 0 values done)
|
||||
|
||||
(define e2 (custodian-add-tidy! c (lambda (e) (set! done (add1 done)))))
|
||||
(custodian-tidy-all c)
|
||||
(test 1 values done)
|
||||
|
||||
(custodian-remove-tidy! e2)
|
||||
|
||||
(define e3 (custodian-add-tidy! (make-custodian c) (lambda (e) (set! done (add1 done)))))
|
||||
(custodian-tidy-all c)
|
||||
(test 2 values done)
|
||||
(custodian-tidy-all c)
|
||||
(test 3 values done)
|
||||
|
||||
(custodian-remove-tidy! e3)
|
||||
|
||||
(custodian-add-tidy! c (lambda (e)
|
||||
(custodian-remove-tidy! e)
|
||||
(set! done (add1 done))
|
||||
(custodian-add-tidy! c (lambda (e)
|
||||
(custodian-remove-tidy! e)
|
||||
(set! done (add1 done))))))
|
||||
(custodian-tidy-all c)
|
||||
(test 4 values done)
|
||||
(custodian-tidy-all c)
|
||||
(test 5 values done)
|
||||
(custodian-tidy-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)
|
||||
|
||||
(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))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Check that a terminated thread cleans up ownership
|
||||
|
|
|
|||
|
|
@ -602,6 +602,9 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
|
|||
}
|
||||
#endif
|
||||
|
||||
if (scheme_tidy_managed(NULL, 1))
|
||||
exit_val = 1;
|
||||
|
||||
return exit_val;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -73,6 +73,7 @@ EXPORTS
|
|||
scheme_custodian_is_available
|
||||
scheme_remove_managed
|
||||
scheme_close_managed
|
||||
scheme_tidy_managed
|
||||
scheme_schedule_custodian_close
|
||||
scheme_add_custodian_extractor
|
||||
scheme_add_atexit_closer
|
||||
|
|
|
|||
|
|
@ -73,6 +73,7 @@ EXPORTS
|
|||
scheme_custodian_is_available
|
||||
scheme_remove_managed
|
||||
scheme_close_managed
|
||||
scheme_tidy_managed
|
||||
scheme_schedule_custodian_close
|
||||
scheme_add_custodian_extractor
|
||||
scheme_add_atexit_closer
|
||||
|
|
|
|||
|
|
@ -71,6 +71,7 @@ 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_add_atexit_closer
|
||||
|
|
|
|||
|
|
@ -71,6 +71,7 @@ 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_add_atexit_closer
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3358,6 +3358,8 @@ def_exit_handler_proc(int argc, Scheme_Object *argv[])
|
|||
} else
|
||||
status = 0;
|
||||
|
||||
scheme_tidy_managed(NULL, 0);
|
||||
|
||||
if (scheme_exit)
|
||||
scheme_exit(status);
|
||||
else
|
||||
|
|
|
|||
|
|
@ -2599,11 +2599,17 @@ static void terminate_current_place(Scheme_Object *result)
|
|||
Scheme_Place_Object *place_obj;
|
||||
|
||||
place_obj = place_object;
|
||||
place_object = NULL;
|
||||
|
||||
mzrt_mutex_lock(place_obj->lock);
|
||||
place_obj_die = place_obj->die;
|
||||
mzrt_mutex_unlock(place_obj->lock);
|
||||
|
||||
if (!place_obj_die) {
|
||||
if (scheme_tidy_managed(NULL, 1))
|
||||
result = scheme_make_integer(1);
|
||||
}
|
||||
|
||||
place_object = NULL;
|
||||
|
||||
/*printf("Leavin place: proc thread id%u\n", ptid);*/
|
||||
|
||||
|
|
|
|||
|
|
@ -8390,14 +8390,19 @@ make_fd_output_port(intptr_t fd, Scheme_Object *name, int regfile, int win_textm
|
|||
|
||||
static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
|
||||
{
|
||||
if (SCHEME_OUTPUT_PORTP(o)) {
|
||||
Scheme_Output_Port *op;
|
||||
op = scheme_output_port_record(o);
|
||||
if (SAME_OBJ(op->sub_type, fd_output_port_type))
|
||||
scheme_flush_output(o);
|
||||
if (SCHEME_OUTPORTP(o)) {
|
||||
scheme_flush_if_output_fds(o);
|
||||
}
|
||||
}
|
||||
|
||||
void scheme_flush_if_output_fds(Scheme_Object *o)
|
||||
{
|
||||
Scheme_Output_Port *op;
|
||||
op = scheme_output_port_record(o);
|
||||
if (SAME_OBJ(op->sub_type, fd_output_port_type))
|
||||
scheme_flush_output(o);
|
||||
}
|
||||
|
||||
#ifdef WINDOWS_FILE_HANDLES
|
||||
|
||||
static long WINAPI WindowsFDWriter(Win_FD_Output_Thread *oth)
|
||||
|
|
|
|||
|
|
@ -163,6 +163,7 @@ 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);
|
||||
|
||||
|
|
|
|||
|
|
@ -116,6 +116,7 @@ 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);
|
||||
void (*scheme_add_atexit_closer)(Scheme_Exit_Closer_Func f);
|
||||
|
|
|
|||
|
|
@ -79,6 +79,7 @@
|
|||
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_add_atexit_closer = scheme_add_atexit_closer;
|
||||
|
|
|
|||
|
|
@ -79,6 +79,7 @@
|
|||
#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_add_atexit_closer (scheme_extension_table->scheme_add_atexit_closer)
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1117
|
||||
#define EXPECTED_PRIM_COUNT 1121
|
||||
#define EXPECTED_UNSAFE_COUNT 106
|
||||
#define EXPECTED_FLFXNUM_COUNT 69
|
||||
#define EXPECTED_EXTFL_COUNT 45
|
||||
|
|
|
|||
|
|
@ -3840,6 +3840,7 @@ extern Scheme_Object *scheme_tcp_output_port_type;
|
|||
THREAD_LOCAL_DECL(extern int scheme_force_port_closed);
|
||||
|
||||
void scheme_flush_orig_outputs(void);
|
||||
void scheme_flush_if_output_fds(Scheme_Object *o);
|
||||
Scheme_Object *scheme_file_stream_port_p(int, Scheme_Object *[]);
|
||||
Scheme_Object *scheme_terminal_port_p(int, Scheme_Object *[]);
|
||||
Scheme_Object *scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[],
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "6.0.1.6"
|
||||
#define MZSCHEME_VERSION "6.0.1.7"
|
||||
|
||||
#define MZSCHEME_VERSION_X 6
|
||||
#define MZSCHEME_VERSION_Y 0
|
||||
#define MZSCHEME_VERSION_Z 1
|
||||
#define MZSCHEME_VERSION_W 6
|
||||
#define MZSCHEME_VERSION_W 7
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -211,86 +211,87 @@ enum {
|
|||
scheme_environment_variables_type, /* 187 */
|
||||
scheme_filesystem_change_evt_type, /* 188 */
|
||||
scheme_ctype_type, /* 189 */
|
||||
scheme_custodian_tidy_type, /* 190 */
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_, /* 190 */
|
||||
_scheme_last_normal_type_, /* 191 */
|
||||
|
||||
scheme_rt_weak_array, /* 191 */
|
||||
scheme_rt_weak_array, /* 192 */
|
||||
|
||||
scheme_rt_comp_env, /* 192 */
|
||||
scheme_rt_constant_binding, /* 193 */
|
||||
scheme_rt_resolve_info, /* 194 */
|
||||
scheme_rt_unresolve_info, /* 195 */
|
||||
scheme_rt_optimize_info, /* 196 */
|
||||
scheme_rt_compile_info, /* 197 */
|
||||
scheme_rt_cont_mark, /* 198 */
|
||||
scheme_rt_saved_stack, /* 199 */
|
||||
scheme_rt_reply_item, /* 200 */
|
||||
scheme_rt_closure_info, /* 201 */
|
||||
scheme_rt_overflow, /* 202 */
|
||||
scheme_rt_overflow_jmp, /* 203 */
|
||||
scheme_rt_meta_cont, /* 204 */
|
||||
scheme_rt_dyn_wind_cell, /* 205 */
|
||||
scheme_rt_dyn_wind_info, /* 206 */
|
||||
scheme_rt_dyn_wind, /* 207 */
|
||||
scheme_rt_dup_check, /* 208 */
|
||||
scheme_rt_thread_memory, /* 209 */
|
||||
scheme_rt_input_file, /* 210 */
|
||||
scheme_rt_input_fd, /* 211 */
|
||||
scheme_rt_oskit_console_input, /* 212 */
|
||||
scheme_rt_tested_input_file, /* 213 */
|
||||
scheme_rt_tested_output_file, /* 214 */
|
||||
scheme_rt_indexed_string, /* 215 */
|
||||
scheme_rt_output_file, /* 216 */
|
||||
scheme_rt_load_handler_data, /* 217 */
|
||||
scheme_rt_pipe, /* 218 */
|
||||
scheme_rt_beos_process, /* 219 */
|
||||
scheme_rt_system_child, /* 220 */
|
||||
scheme_rt_tcp, /* 221 */
|
||||
scheme_rt_write_data, /* 222 */
|
||||
scheme_rt_tcp_select_info, /* 223 */
|
||||
scheme_rt_param_data, /* 224 */
|
||||
scheme_rt_will, /* 225 */
|
||||
scheme_rt_linker_name, /* 226 */
|
||||
scheme_rt_param_map, /* 227 */
|
||||
scheme_rt_finalization, /* 228 */
|
||||
scheme_rt_finalizations, /* 229 */
|
||||
scheme_rt_cpp_object, /* 230 */
|
||||
scheme_rt_cpp_array_object, /* 231 */
|
||||
scheme_rt_stack_object, /* 232 */
|
||||
scheme_rt_preallocated_object, /* 233 */
|
||||
scheme_thread_hop_type, /* 234 */
|
||||
scheme_rt_srcloc, /* 235 */
|
||||
scheme_rt_evt, /* 236 */
|
||||
scheme_rt_syncing, /* 237 */
|
||||
scheme_rt_comp_prefix, /* 238 */
|
||||
scheme_rt_user_input, /* 239 */
|
||||
scheme_rt_user_output, /* 240 */
|
||||
scheme_rt_compact_port, /* 241 */
|
||||
scheme_rt_read_special_dw, /* 242 */
|
||||
scheme_rt_regwork, /* 243 */
|
||||
scheme_rt_rx_lazy_string, /* 244 */
|
||||
scheme_rt_buf_holder, /* 245 */
|
||||
scheme_rt_parameterization, /* 246 */
|
||||
scheme_rt_print_params, /* 247 */
|
||||
scheme_rt_read_params, /* 248 */
|
||||
scheme_rt_native_code, /* 249 */
|
||||
scheme_rt_native_code_plus_case, /* 250 */
|
||||
scheme_rt_jitter_data, /* 251 */
|
||||
scheme_rt_module_exports, /* 252 */
|
||||
scheme_rt_delay_load_info, /* 253 */
|
||||
scheme_rt_marshal_info, /* 254 */
|
||||
scheme_rt_unmarshal_info, /* 255 */
|
||||
scheme_rt_runstack, /* 256 */
|
||||
scheme_rt_sfs_info, /* 257 */
|
||||
scheme_rt_validate_clearing, /* 258 */
|
||||
scheme_rt_avl_node, /* 259 */
|
||||
scheme_rt_lightweight_cont, /* 260 */
|
||||
scheme_rt_export_info, /* 261 */
|
||||
scheme_rt_cont_jmp, /* 262 */
|
||||
scheme_rt_letrec_check_frame, /* 263 */
|
||||
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 */
|
||||
#endif
|
||||
scheme_deferred_expr_type, /* 264 */
|
||||
scheme_deferred_expr_type, /* 265 */
|
||||
|
||||
_scheme_last_type_
|
||||
};
|
||||
|
|
|
|||
|
|
@ -357,6 +357,10 @@ 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[]);
|
||||
|
|
@ -530,6 +534,10 @@ 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);
|
||||
|
|
@ -1400,7 +1408,7 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
|
|||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
} else if (f) {
|
||||
f(o, data);
|
||||
}
|
||||
}
|
||||
|
|
@ -1462,7 +1470,6 @@ static void do_close_managed(Scheme_Custodian *m)
|
|||
else
|
||||
scheme_thread_block(0.0);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
void scheme_close_managed(Scheme_Custodian *m)
|
||||
|
|
@ -1474,6 +1481,97 @@ 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;
|
||||
|
|
@ -1514,6 +1612,67 @@ 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);
|
||||
|
|
@ -1607,7 +1766,7 @@ static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[])
|
|||
o = ex(o);
|
||||
}
|
||||
|
||||
if (o) {
|
||||
if (o && !SAME_TYPE(SCHEME_TYPE(o), scheme_custodian_tidy_type)) {
|
||||
hold[j] = o;
|
||||
j++;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -227,6 +227,7 @@ 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_cont_mark_set_type, "<continuation-mark-set>");
|
||||
set_name(scheme_cont_mark_chain_type, "<chain>");
|
||||
|
||||
|
|
@ -726,6 +727,8 @@ void scheme_register_traversers(void)
|
|||
GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj);
|
||||
|
||||
GC_REG_TRAV(scheme_environment_variables_type, small_object);
|
||||
|
||||
GC_REG_TRAV(scheme_custodian_tidy_type, twoptr_obj);
|
||||
}
|
||||
|
||||
END_XFORM_SKIP;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user