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

add propagated arguments to 'call-with-continuation-prompt'; streamline 'with-handlers' expansion; speed up slightly some JITted cross-module function calls

Browse Source 
svn: r12979
This commit is contained in:
Matthew Flatt 2009-01-02 21:57:31 +00:00
parent de4158dfa5
commit b2d0a37f7b
8 changed files with 159 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/scheme/private/more-scheme.ss
View File

@ -210,15 +210,34 @@
(define handler-prompt-key (make-continuation-prompt-tag))
(define (call-handled-body body-thunk)
(define (call-handled-body bpz handle-proc body-thunk)
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(with-continuation-mark
break-enabled-key
false-thread-cell
(call-with-continuation-prompt
body-thunk
(lambda (bpz body-thunk)
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(with-continuation-mark
exception-handler-key
(lambda (e)
;; Deliver the exception to the escape handler:
(abort-current-continuation
handler-prompt-key
e))
(body-thunk))))
handler-prompt-key
;; On escape, apply the handler thunk
(lambda (thunk) (thunk)))))
handle-proc
bpz body-thunk)))
(define-syntaxes (with-handlers with-handlers*)
(let ([wh
@ -234,36 +253,19 @@
(quasisyntax/loc stx
(let-values ([(pred-name) pred] ...
[(handler-name) handler] ...)
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(call-handled-body
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
(call-handled-body
bpz
(lambda (e)
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))
(lambda ()
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(with-continuation-mark
exception-handler-key
(lambda (e)
;; Deliver a thunk to the escape handler:
(abort-current-continuation
handler-prompt-key
(lambda ()
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))))
(let-values ()
expr1 expr ...)))))))))])))])
expr1 expr ...))))))])))])
(values (wh #t) (wh #f))))
(define (call-with-exception-handler exnh thunk)

21
collects/scribblings/reference/cont.scrbl
View File

@ -43,17 +43,18 @@ between the application and the current continuation.
@defproc[(call-with-continuation-prompt
[thunk (-> any)]
[proc procedure?]
[prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)]
[handler (or/c procedure? #f) #f])
[handler (or/c procedure? #f) #f]
[arg any/c] ...)
any]{
Calls @scheme[thunk] with the current continuation extended by a
prompt. The prompt is tagged by @scheme[prompt-tag], which must be a
result from either @scheme[default-continuation-prompt-tag] (the
default) or @scheme[make-continuation-prompt-tag]. The result of
@scheme[thunk] is the result of the
@scheme[call-with-continuation-prompt] call.
Applies @scheme[proc] to the given @scheme[arg]s with the current
continuation extended by a prompt. The prompt is tagged by
@scheme[prompt-tag], which must be a result from either
@scheme[default-continuation-prompt-tag] (the default) or
@scheme[make-continuation-prompt-tag]. The result of @scheme[proc] is
the result of the @scheme[call-with-continuation-prompt] call.
The @scheme[handler] argument specifies a handler procedure to be
called in tail position with respect to the
@ -62,8 +63,8 @@ is the target of a @scheme[abort-current-continuation] call with
@scheme[prompt-tag]; the remaining arguments of
@scheme[abort-current-continuation] are supplied to the handler
procedure. If @scheme[handler] is @scheme[#f], the default handler
accepts a single @scheme[abort-thunk] argument and calls
@scheme[(call-with-continuation-prompt abort-thunk prompt-tag #f)];
accepts a single @scheme[_abort-thunk] argument and calls
@scheme[(call-with-continuation-prompt _abort-thunk prompt-tag #f)];
that is, the default handler re-installs the prompt and continues with
a given thunk.}

11
collects/tests/mzscheme/prompt.ss
View File

@ -8,6 +8,17 @@
(define (test-breaks-ok)
(err/rt-test (break-thread (current-thread)) exn:break?))
(test (void) call-with-continuation-prompt void)
(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag))
(test (void) call-with-continuation-prompt void (default-continuation-prompt-tag) list)
(test '() call-with-continuation-prompt list (default-continuation-prompt-tag) void)
(test '(1) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1)
(test '(1 2) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2)
(test '(1 2 3) call-with-continuation-prompt list (default-continuation-prompt-tag) void 1 2 3)
(test '(1 2 3 4 5 6 7 8 9 10) call-with-continuation-prompt list (default-continuation-prompt-tag) void
1 2 3 4 5 6 7 8 9 10)
;;----------------------------------------
;; cc variants

1
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,5 +1,6 @@
Version 4.1.3.8
Added procedure-rename
Added extra arguments to call-with-continuation-prompt
Version 4.1.3.7
Added equal?/recur

25
src/mzscheme/src/fun.c
View File

@ -318,7 +318,7 @@ scheme_init_fun (Scheme_Env *env)
REGISTER_SO(call_with_prompt_proc);
call_with_prompt_proc = scheme_make_prim_w_arity2(call_with_prompt,
"call-with-continuation-prompt",
1, 3,
1, -1,
0, -1);
scheme_add_global_constant("call-with-continuation-prompt",
call_with_prompt_proc,
@ -6124,12 +6124,28 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
Scheme_Object *proc = in_argv[0], *prompt_tag;
Scheme_Prompt *prompt;
int argc, handler_argument_error = 0;
Scheme_Object **argv, *a[1], *handler;
# define QUICK_PROMPT_ARGS 3
Scheme_Object **argv, *a[QUICK_PROMPT_ARGS], *handler;
Scheme_Cont_Frame_Data cframe;
Scheme_Dynamic_Wind *prompt_dw;
int cc_count = scheme_cont_capture_count;
scheme_check_proc_arity("call-with-continuation-prompt", 0, 0, in_argc, in_argv);
argc = in_argc - 3;
if (argc <= 0) {
argc = 0;
argv = NULL;
} else {
int i;
if (argc <= QUICK_PROMPT_ARGS)
argv = a;
else
argv = MALLOC_N(Scheme_Object *, argc);
for (i = 0; i < argc; i++) {
argv[i] = in_argv[i+3];
}
}
scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
if (in_argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) {
scheme_wrong_type("call-with-continuation-prompt", "continuation-prompt-tag",
@ -6146,9 +6162,6 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
} else
handler = scheme_false;
argv = NULL;
argc = 0;
do {
/* loop implements the default prompt handler */

83
src/mzscheme/src/jit.c
View File

@ -2451,6 +2451,37 @@ static int generate_nontail_self_setup(mz_jit_state *jitter)
return 0;
}
static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case)
{
if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) {
if (((Scheme_Native_Closure *)p)->code->closure_size < 0) {
/* case-lambda */
int cnt, i;
mzshort *arities;
cnt = ((Scheme_Native_Closure *)p)->code->closure_size;
cnt = -(cnt + 1);
arities = ((Scheme_Native_Closure *)p)->code->u.arities;
for (i = 0; i < cnt; i++) {
if (arities[i] == num_rands) {
*extract_case = (long)&((Scheme_Native_Closure *)0x0)->vals[i];
return 1;
}
}
} else {
/* not a case-lambda... */
if (scheme_native_arity_check(p, num_rands)
/* If it also accepts num_rands + 1, then it has a vararg,
so don't try direct_native. */
&& !scheme_native_arity_check(p, num_rands + 1)) {
return 1;
}
}
}
return 0;
}
static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands,
mz_jit_state *jitter, int is_tail, int multi_ok, int no_call)
{
@ -2460,6 +2491,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
Scheme_Object *rator, *v, *arg;
int reorder_ok = 0;
int args_already_in_place = 0;
long extract_case = 0; /* when direct_native, non-0 => offset to extract case-lambda case */
START_JIT_DATA();
rator = (alt_rands ? alt_rands[0] : app->args[0]);
@ -2494,32 +2526,36 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
}
}
} else if ((t == scheme_toplevel_type)
&& (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST)) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
} else if (t == scheme_toplevel_type) {
if (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
if (jitter->nc) {
Scheme_Object *p;
if (jitter->nc) {
Scheme_Object *p;
p = extract_global(rator, jitter->nc);
p = ((Scheme_Bucket *)p)->val;
if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) {
if (scheme_native_arity_check(p, num_rands)
/* If it also accepts num_rands + 1, then it has a vararg,
so don't try direct_native. */
&& !scheme_native_arity_check(p, num_rands + 1)) {
direct_native = 1;
p = extract_global(rator, jitter->nc);
p = ((Scheme_Bucket *)p)->val;
if (can_direct_native(p, num_rands, &extract_case)) {
direct_native = 1;
if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos)
&& (num_rands < MAX_SHARED_CALL_RANDS)) {
if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos)
&& (num_rands < MAX_SHARED_CALL_RANDS)) {
if (is_tail)
direct_self = 1;
else if (jitter->self_nontail_code)
nontail_self = 1;
}
}
}
}
}
}
} else if (jitter->nc) {
Scheme_Object *p;
p = extract_global(rator, jitter->nc);
if (((Scheme_Bucket_With_Flags *)p)->flags & GLOB_IS_CONSISTENT) {
if (can_direct_native(((Scheme_Bucket *)p)->val, num_rands, &extract_case))
direct_native = 1;
}
}
} else if (SAME_TYPE(t, scheme_closure_type)) {
Scheme_Closure_Data *data;
@ -2543,7 +2579,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
#ifdef JIT_PRECISE_GC
/* We can get this closure's pointer back frmo the Scheme stack. */
/* We can get this closure's pointer back from the Scheme stack. */
if (nontail_self)
direct_self = 1;
#endif
@ -2693,6 +2729,11 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
else
scheme_indirect_call_count++;
if (direct_native && extract_case) {
/* extract case from case-lambda */
jit_ldxi_p(JIT_V1, JIT_V1, extract_case);
}
if (no_call) {
/* leave actual call to inlining code */
} else if (!(direct_self && is_tail)
@ -2748,7 +2789,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
code = generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, nontail_self);
shared_non_tail_code[dp][num_rands][mo] = code;
}
LOG_IT(("<-non-tail %d %d %d %d\n", dp, num_rands, mo));
LOG_IT(("<-non-tail %d %d %d\n", dp, num_rands, mo));
code = shared_non_tail_code[dp][num_rands][mo];
if (nontail_self) {

8
src/mzscheme/src/schpriv.h
View File

@ -514,11 +514,15 @@ extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator);
/* hash tables and globals */
/*========================================================================*/
/* a primitive constant: */
#define GLOB_IS_CONST 1
#define GLOB_IS_PRIMITIVE 4
#define GLOB_IS_PERMANENT 8
/* always defined as the same kind of value (e.g., proc with a particular arity): */
#define GLOB_IS_CONSISTENT 2
/* a kernel constant: */
#define GLOB_HAS_REF_ID 16
/* can cast to Scheme_Bucket_With_Home: */
#define GLOB_HAS_HOME_PTR 32
/* Scheme-level constant (cannot be changed further): */
#define GLOB_IS_IMMUTATED 64
typedef struct {

19
src/mzscheme/src/syntax.c
View File

@ -681,26 +681,27 @@ void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v)
static Scheme_Object *
define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
Resolve_Prefix *rp, Scheme_Env *dm_env, Scheme_Dynamic_State *dyn_state)
Resolve_Prefix *rp, Scheme_Env *dm_env,
Scheme_Dynamic_State *dyn_state)
{
Scheme_Object *name, *macro, *vals, *var;
Scheme_Object *name, *macro, *vals_expr, *vals, *var;
int i, g, show_any;
Scheme_Bucket *b;
Scheme_Object **save_runstack = NULL;
vals = SCHEME_VEC_ELS(vec)[0];
vals_expr = SCHEME_VEC_ELS(vec)[0];
if (dm_env) {
scheme_prepare_exp_env(dm_env);
save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1);
vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals, dyn_state);
vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state);
if (defmacro == 2)
dm_env = NULL;
else
scheme_pop_prefix(save_runstack);
} else {
vals = _scheme_eval_linked_expr_multi(vals);
vals = _scheme_eval_linked_expr_multi(vals_expr);
dm_env = NULL;
}
@ -735,7 +736,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
}
}
}
@ -767,7 +768,11 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
int flags = GLOB_IS_IMMUTATED;
if (SCHEME_PROCP(vals_expr)
|| SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type))
flags |= GLOB_IS_CONSISTENT;
((Scheme_Bucket_With_Flags *)b)->flags |= flags;
}
if (defmacro)