macro-expansion performance tweaks

svn: r12972

collects/r5rs/main.ss

@@ -164,6 +164,8 @@
            ;; quote has to create mpairs:
            (syntax-local-lift-expression (let loop ([form #'form])
                                            (syntax-case form ()
+                                             [(a ...)
+                                              #`(mlist . #,(map loop (syntax->list #'(a ...))))]
                                              [(a . b)
                                               #`(mcons #,(loop #'a) #,(loop #'b))]
                                              [#(a ...)

collects/scheme/private/more-scheme.ss

@@ -210,6 +210,16 @@
 
   (define handler-prompt-key (make-continuation-prompt-tag))
 
+  (define (call-handled-body body-thunk)
+    (with-continuation-mark
+        break-enabled-key
+        false-thread-cell
+      (call-with-continuation-prompt
+       body-thunk
+       handler-prompt-key
+       ;; On escape, apply the handler thunk
+       (lambda (thunk) (thunk)))))
+
   (define-syntaxes (with-handlers with-handlers*)
     (let ([wh 
 	   (lambda (disable-break?)
@@ -222,44 +232,38 @@
 				[(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler) 
 									       (syntax->list #'(handler ...))))])
 		    (quasisyntax/loc stx
-		      (let ([pred-name pred] ...
+		      (let-values ([(pred-name) pred] ...
-			    [handler-name handler] ...)
+                                   [(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
-			  (with-continuation-mark
+			  (call-handled-body
-			      break-enabled-key
+                           (lambda ()
-			      false-thread-cell
+                             ;; Restore the captured break parameterization for
-			    (call-with-continuation-prompt
+                             ;;  evaluating the `with-handlers' body. In this
-			     (lambda ()
+                             ;;  special case, no check for breaks is needed,
-			       ;; Restore the captured break parameterization for
+                             ;;  because bpz is quickly restored past call/ec.
-			       ;;  evaluating the `with-handlers' body. In this
+                             ;;  Thus, `with-handlers' can evaluate its body in
-			       ;;  special case, no check for breaks is needed,
+                             ;;  tail position.
-			       ;;  because bpz is quickly restored past call/ec.
+                             (with-continuation-mark 
-			       ;;  Thus, `with-handlers' can evaluate its body in
+                                 break-enabled-key
-			       ;;  tail position.
+                                 bpz
-			       (with-continuation-mark 
+                               (with-continuation-mark 
-				   break-enabled-key
+                                   exception-handler-key
-				   bpz
+                                   (lambda (e)
-                                 (with-continuation-mark 
+                                     ;; Deliver a thunk to the escape handler:
-                                     exception-handler-key
+                                     (abort-current-continuation
-                                     (lambda (e)
+                                      handler-prompt-key
-                                       ;; Deliver a thunk to the escape handler:
+                                      (lambda ()
-                                       (abort-current-continuation
+                                        (#,(if disable-break?
-                                        handler-prompt-key
+                                               #'select-handler/no-breaks
-                                        (lambda ()
+                                               #'select-handler/breaks-as-is)
-                                          (#,(if disable-break?
+                                         e bpz
-                                                 #'select-handler/no-breaks
+                                         (list (cons pred-name handler-name) ...)))))
-                                                 #'select-handler/breaks-as-is)
+                                 (let-values ()
-                                           e bpz
+                                   expr1 expr ...)))))))))])))])
-                                           (list (cons pred-name handler-name) ...)))))
-                                   (let ()
-                                     expr1 expr ...))))
-                             handler-prompt-key
-			     ;; On escape, apply the handler thunk
-			     (lambda (thunk) (thunk))))))))])))])
       (values (wh #t) (wh #f))))
 
   (define (call-with-exception-handler exnh thunk)

src/mzscheme/src/env.c

@@ -4731,6 +4731,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
   Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym;
   Scheme_Lift_Capture_Proc cp;  
   Scheme_Object *orig_expr;
+  char buf[24];
 
   expr = argv[0];
   if (!SCHEME_STXP(expr))
@@ -4753,7 +4754,13 @@ local_lift_expr(int argc, Scheme_Object *argv[])
   
   expr = scheme_add_remove_mark(expr, local_mark);
 
-  id_sym = scheme_intern_exact_parallel_symbol("lifted", 6);
+  /* We don't really need a new symbol each time, since the mark
+     will generate new bindings. But lots of things work better or faster
+     when different bindings have different symbols. Use env->genv->id_counter
+     to help keep name generation deterministic within a module. */
+  sprintf(buf, "lifted.%d", env->genv->id_counter++);
+  id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
+
   id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0);
   id = scheme_add_remove_mark(id, scheme_new_mark());
 

src/mzscheme/src/module.c

@@ -4083,6 +4083,18 @@ static void *eval_module_body_k(void)
   return NULL;
 }
 
+#if 0
+# define LOG_RUN_DECLS long start_time
+# define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds())
+# define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \
+                                  scheme_write_to_string(mod->modname, NULL), \
+                                  scheme_get_process_milliseconds() - start_time))
+#else
+# define LOG_RUN_DECLS /* empty */
+# define LOG_START_RUN(mod) /* empty */
+# define LOG_END_RUN(mod) /* empty */
+#endif
+
 static void eval_module_body(Scheme_Env *menv)
 {
   Scheme_Thread *p;
@@ -4092,6 +4104,7 @@ static void eval_module_body(Scheme_Env *menv)
   int i, cnt;
   int volatile save_phase_shift;
   mz_jmp_buf newbuf, * volatile savebuf;
+  LOG_RUN_DECLS;
 
   menv->running = 1;
   menv->ran = 1;
@@ -4104,6 +4117,8 @@ static void eval_module_body(Scheme_Env *menv)
     return;
   }
 
+  LOG_START_RUN(menv->module);
+
   save_runstack = scheme_push_prefix(menv, m->prefix,
 				     m->me->src_modidx, menv->link_midx,
 				     0, menv->phase);
@@ -4149,6 +4164,8 @@ static void eval_module_body(Scheme_Env *menv)
 
     scheme_pop_prefix(save_runstack);
   }
+
+  LOG_END_RUN(menv->module);
 }
 
 void scheme_run_module(Scheme_Env *menv, int set_ns)
@@ -5218,6 +5235,18 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info)
   return data;
 }
 
+#if 0
+# define LOG_EXPAND_DECLS long start_time
+# define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds())
+# define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \
+                                     scheme_write_to_string(mod->modname, NULL), \
+                                     scheme_get_process_milliseconds() - start_time))
+#else
+# define LOG_EXPAND_DECLS /* empty */
+# define LOG_START_EXPAND(mod) /* empty */
+# define LOG_END_EXPAND(mod) /* empty */
+#endif
+
 static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, 
 				Scheme_Compile_Expand_Info *rec, int drec)
 {
@@ -5229,6 +5258,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
   Scheme_Object *mbval, *orig_ii;
   int saw_mb, check_mb = 0;
   int restore_confusing_name = 0;
+  LOG_EXPAND_DECLS;
 
   if (!scheme_is_toplevel(env))
     scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
@@ -5256,6 +5286,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
   rmp = scheme_intern_resolved_module_path(rmp);
   m->modname = rmp;
 
+  LOG_START_EXPAND(m);
+
   if (SAME_OBJ(m->modname, kernel_modname)) {
     /* Too confusing. Give it a different name while compiling. */
     Scheme_Object *k2;
@@ -5492,6 +5524,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
     menv->rename_set = NULL;
   }
 
+  LOG_END_EXPAND(m);
+
   SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
   return fm;
 }

src/mzscheme/src/stxobj.c

@@ -2318,7 +2318,7 @@ static Scheme_Object *make_mapped_k(void)
 
 static void make_mapped(Scheme_Cert *cert)
 {
-  Scheme_Cert *stop;
+  Scheme_Cert *stop, *c2;
   Scheme_Object *pr;
   Scheme_Hash_Table *ht;
 
@@ -2349,7 +2349,18 @@ static void make_mapped(Scheme_Cert *cert)
       make_mapped(stop);
   }
 
-  ht = scheme_make_hash_table_equal();
+  /* Check whether an `eq?' table will work: */
+  for (c2 = cert; c2 != stop; c2 = c2->next) {
+    if (c2->key)
+      break;
+    if (!SCHEME_INTP(c2->mark))
+      break;
+  }
+
+  if (c2 == stop)
+    ht = scheme_make_hash_table(SCHEME_hash_ptr);
+  else
+    ht = scheme_make_hash_table_equal();
 
   pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop);
   cert->mapped = pr;