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

svn: r12979

collects/scheme/private/more-scheme.ss

@@ -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
-       ;; On escape, apply the handler thunk
+                  e))
-       (lambda (thunk) (thunk)))))
+             (body-thunk))))
+       handler-prompt-key
+       handle-proc
+       bpz body-thunk)))
   
   (define-syntaxes (with-handlers with-handlers*)
     (let ([wh 
@@ -237,33 +256,16 @@
                         ;; 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
-                           (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) ...)))))
+                              (list (cons pred-name handler-name) ...)))
-                                 (let-values ()
+                           (lambda ()
-                                   expr1 expr ...)))))))))])))])
+                             expr1 expr ...))))))])))])
       (values (wh #t) (wh #f))))
 
   (define (call-with-exception-handler exnh thunk)

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
+Applies @scheme[proc] to the given @scheme[arg]s with the current
-prompt. The prompt is tagged by @scheme[prompt-tag], which must be a
+continuation extended by a prompt. The prompt is tagged by
-result from either @scheme[default-continuation-prompt-tag] (the
+@scheme[prompt-tag], which must be a result from either
-default) or @scheme[make-continuation-prompt-tag]. The result of
+@scheme[default-continuation-prompt-tag] (the default) or
-@scheme[thunk] is the result of the
+@scheme[make-continuation-prompt-tag]. The result of @scheme[proc] is
-@scheme[call-with-continuation-prompt] call.
+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
+accepts a single @scheme[_abort-thunk] argument and calls
-@scheme[(call-with-continuation-prompt abort-thunk prompt-tag #f)];
+@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.}
 

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
 

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

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 */
 

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,8 +2526,8 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
 	  }
 	}
       }
-    } else if ((t == scheme_toplevel_type)
+    } else if (t == scheme_toplevel_type) {
-	       && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST)) {
+      if (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST) {
         /* We can re-order evaluation of the rator. */
         reorder_ok = 1;
 
@@ -2504,11 +2536,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
 
           p = extract_global(rator, jitter->nc);
           p = ((Scheme_Bucket *)p)->val;
-	if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) {
+          if (can_direct_native(p, num_rands, &extract_case)) {
-	  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)
@@ -2520,6 +2548,14 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
             }
           }
         }
+      } 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) {

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
+/* always defined as the same kind of value (e.g., proc with a particular arity): */
-#define GLOB_IS_PERMANENT 8
+#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 {

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;
   }
 
@@ -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)