diff --git a/collects/scheme/private/more-scheme.ss b/collects/scheme/private/more-scheme.ss index 3f89be4be1..35f3f25886 100644 --- a/collects/scheme/private/more-scheme.ss +++ b/collects/scheme/private/more-scheme.ss @@ -210,16 +210,35 @@ (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 (lambda (disable-break?) @@ -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) diff --git a/collects/scribblings/reference/cont.scrbl b/collects/scribblings/reference/cont.scrbl index ddaead02b8..bbfc74f87a 100644 --- a/collects/scribblings/reference/cont.scrbl +++ b/collects/scribblings/reference/cont.scrbl @@ -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.} diff --git a/collects/tests/mzscheme/prompt.ss b/collects/tests/mzscheme/prompt.ss index fc6e51364c..6ed95f6ca1 100644 --- a/collects/tests/mzscheme/prompt.ss +++ b/collects/tests/mzscheme/prompt.ss @@ -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 diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index c225a70f47..51cfe16b99 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -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 diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index f5f304012e..de0bf2d706 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -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 */ diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index e40a8a8080..9ae24f51ca 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -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; - - if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos) - && (num_rands < MAX_SHARED_CALL_RANDS)) { + 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 (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) { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 0ff2debbc0..231003d3e1 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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 { diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 00c61b81ee..4484b91f90 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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)