trim some fat from module-variable references

svn: r12833

collects/compiler/decompile.ss

@@ -57,7 +57,8 @@
        (values (append 
                 (map (lambda (tl)
                        (match tl
-                         [(? symbol?) '#%linkage]
+                         [#f '#%linkage]
+                         [(? symbol?) (string->symbol (format "_~a" tl))]
                          [(struct global-bucket (name)) 
                           (string->symbol (format "_~a" name))]
                          [(struct module-variable (modidx sym pos phase))

collects/compiler/zo-parse.ss

@@ -85,15 +85,10 @@
 (define (read-variable v)
   (if (symbol? v)
       (make-global-bucket v)
-      (let-values ([(phase modname varname)
+      (error "expected a symbol")))
-                    (match v
+
-                      [(list* phase modname varname)
+(define (do-not-read-variable v)
-                       (values phase modname varname)]
+  (error "should not get here"))
-                      [(list* modname varname)
-                       (values 0 modname varname)])])
-        (if (and (zero? phase) (eq? modname '#%kernel))
-            (error 'bucket "var ~a" varname)
-            (make-module-variable modname varname -1 phase)))))
 
 (define (read-compilation-top v)
   (match v
@@ -198,6 +193,7 @@
              ,rename ,max-let-depth ,dummy
              ,prefix ,kernel-exclusion ,reprovide-kernel?
              ,indirect-provides ,num-indirect-provides 
+             ,indirect-syntax-provides ,num-indirect-syntax-provides 
              ,indirect-et-provides ,num-indirect-et-provides 
              ,protects ,et-protects
              ,provide-phase-count . ,rest)
@@ -282,7 +278,7 @@
     (cons 'with-cont-mark-type read-with-cont-mark)
     (cons 'quote-syntax-type read-topsyntax)
     (cons 'variable-type read-variable)
-    (cons 'module-variable-type read-variable)
+    (cons 'module-variable-type do-not-read-variable)
     (cons 'compilation-top-type read-compilation-top)
     (cons 'case-lambda-sequence-type read-case-lambda)
     (cons 'begin0-sequence-type read-sequence)
@@ -719,7 +715,11 @@
            (let ([mod (read-compact cp)]
                  [var (read-compact cp)]
                  [pos (read-compact-number cp)])
-             (make-module-variable mod var pos 0))]
+             (let-values ([(mod-phase pos)
+                           (if (= pos -2)
+                                  (values 1 (read-compact-number cp))
+                                  (values 0 pos))])
+               (make-module-variable mod var pos mod-phase)))]
           [(local-unbox)
            (let* ([p* (read-compact-number cp)]
                   [p (if (< p* 0)

collects/games/cards/cards.scrbl

@@ -198,7 +198,8 @@ Removes @scheme[card] from the table.}
 @defmethod[(move-cards [cards (listof (is-a?/c card<%>))]
                        [x real?]
                        [y real?]
-                       [offset-proc (exact-nonnegative-integer? . -> . (values real? real?))
+                       [offset-proc (exact-nonnegative-integer? 
+                                     . -> . (values real? real?))
                                     (lambda (i) (values 0 0))])
             void?]{
 

collects/xml/xml.scrbl

@@ -103,7 +103,7 @@ Represents an element.}
 
 Returns @scheme[#t] if @scheme[v] is a @scheme[pcdata] instance,
 @scheme[element] instance, an @scheme[entity] instance,
-@scheme[comment], or @scheme[pcdata] instance.}
+@scheme[comment], or @scheme[cdata] instance.}
 
 @defstruct[(attribute source) ([name symbol?] [value string?])]{
 

src/mzscheme/gc2/backtrace.c

@@ -45,7 +45,7 @@ static void *print_out_pointer(const char *prefix, void *p,
   trace_page_t *page;
   const char *what;
 
-  page = find_page(p);
+  page = pagemap_find_page(GC->page_maps, p);
   if (!page || (trace_page_type(page) == TRACE_PAGE_BAD)) {
     GCPRINT(GCOUTF, "%s??? %p\n", prefix, p);
     return NULL;
@@ -94,7 +94,7 @@ static void print_traced_objects(int path_length_limit,
 				 GC_print_tagged_value_proc print_tagged_value)
 {
   int i;
-  avoid_collection++;
+  GC->dumping_avoid_collection++;
   GCPRINT(GCOUTF, "Begin Trace\n");
   for (i = 0; i < found_object_count; i++) {
     void *p;
@@ -107,5 +107,5 @@ static void print_traced_objects(int path_length_limit,
     }
   }
   GCPRINT(GCOUTF, "End Trace\n");
-  --avoid_collection;
+  --GC->dumping_avoid_collection;
 }

src/mzscheme/gc2/newgc.c

@@ -934,7 +934,7 @@ static void backtrace_new_page(NewGC *gc, mpage *page)
 
 static void free_backtrace(struct mpage *page)
 {
-  free_pages(page->backtrace, APAGE_SIZE);
+  free_pages(GC, page->backtrace, APAGE_SIZE);
 }
 
 static void *bt_source;
@@ -1590,6 +1590,11 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
   mark_tag = BTC_get_redirect_tag(gc, mark_tag);
 #endif
 
+#if MZ_GC_BACKTRACE
+  /* Keep tagged objects in tagged space: */
+  atomic = 0;
+#endif
+
   gc->mark_table[mark_tag]  = atomic ? (Mark_Proc)PAGE_ATOMIC : mark;
   gc->fixup_table[tag]      = fixup;
 }
@@ -2145,7 +2150,7 @@ static void mark_backpointers(NewGC *gc)
           pagemap_add(pagemap, work);
           if(work->big_page) {
             work->big_page = 2;
-            push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE));
+            push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE + sizeof(struct objhead)));
           } else {
             if(work->page_type != PAGE_ATOMIC) {
               void **start = PPTR(NUM(work->addr) + PREFIX_SIZE);

src/mzscheme/src/env.c

@@ -123,6 +123,8 @@ static Scheme_Object *write_toplevel(Scheme_Object *obj);
 static Scheme_Object *read_toplevel(Scheme_Object *obj);
 static Scheme_Object *write_variable(Scheme_Object *obj);
 static Scheme_Object *read_variable(Scheme_Object *obj);
+static Scheme_Object *write_module_variable(Scheme_Object *obj);
+static Scheme_Object *read_module_variable(Scheme_Object *obj);
 static Scheme_Object *write_local(Scheme_Object *obj);
 static Scheme_Object *read_local(Scheme_Object *obj);
 static Scheme_Object *read_local_unbox(Scheme_Object *obj);
@@ -561,8 +563,8 @@ static void make_kernel_env(void)
   scheme_install_type_reader(scheme_toplevel_type, read_toplevel);
   scheme_install_type_writer(scheme_variable_type, write_variable);
   scheme_install_type_reader(scheme_variable_type, read_variable);
-  scheme_install_type_writer(scheme_module_variable_type, write_variable);
+  scheme_install_type_writer(scheme_module_variable_type, write_module_variable);
-  scheme_install_type_reader(scheme_module_variable_type, read_variable);
+  scheme_install_type_reader(scheme_module_variable_type, read_module_variable);
   scheme_install_type_writer(scheme_local_type, write_local);
   scheme_install_type_reader(scheme_local_type, read_local);
   scheme_install_type_writer(scheme_local_unbox_type, write_local);
@@ -3319,7 +3321,7 @@ void scheme_optimize_info_done(Optimize_Info *info)
 Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
 {
   Resolve_Prefix *rp;
-  Scheme_Object **tls, **stxes, *simplify_cache;
+  Scheme_Object **tls, **stxes, *simplify_cache, *m;
   Scheme_Hash_Table *ht;
   int i;
 
@@ -3344,7 +3346,15 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
   if (ht) {
     for (i = 0; i < ht->size; i++) {
       if (ht->vals[i]) {
-	tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = ht->keys[i];
+        m = ht->keys[i];
+        if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) {
+          if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base)
+              && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) {
+            /* Reduce self-referece to just a symbol: */
+            m = ((Module_Variable *)m)->sym;
+          }
+        }
+	tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m;
       }
     }
   }
@@ -4941,92 +4951,54 @@ static Scheme_Object *read_toplevel(Scheme_Object *obj)
 }
 
 static Scheme_Object *write_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
+  /* #%kernel references are handled in print.c, instead */
-     are handled in print.c, instead */
 {
-  if (SAME_TYPE(scheme_variable_type, SCHEME_TYPE(obj))) {
+  Scheme_Object *sym;
-    Scheme_Object *sym;
+  Scheme_Env *home;
-    Scheme_Env *home;
+  Scheme_Module *m;
-    Scheme_Module *m;
     
-    sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key;
+  sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key;
     
-    home = ((Scheme_Bucket_With_Home *)obj)->home;
+  home = ((Scheme_Bucket_With_Home *)obj)->home;
-    m = home->module;
+  m = home->module;
     
-    /* If we get a writeable variable (instead of a module variable),
+  /* If we get a writeable variable (instead of a module variable),
-       it must be a reference to a module referenced directly by its
+     it must be a reference to a module referenced directly by its
-       a symbolic name (i.e., no path). */
+     a symbolic name (i.e., no path). */
     
-    if (m) {
+  if (m) {
-      sym = scheme_make_pair(m->modname, sym);
+    sym = scheme_make_pair(m->modname, sym);
-      if (home->mod_phase)
+    if (home->mod_phase)
-	sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym);
+      sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym);
-    }
-
-    return sym;
-  } else {
-    Module_Variable *mv = (Module_Variable *)obj;
-
-    return scheme_make_pair(scheme_make_integer(mv->mod_phase),
-			    scheme_make_pair(mv->modidx,
-					     mv->sym));
   }
+
+  return sym;
 }
 
 static Scheme_Object *read_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
+  /* #%kernel references are handled in read.c, instead */
-     are handled in read.c, instead */
 {
   Scheme_Env *env;
 
   env = scheme_get_env(NULL);
 
-  if (!SCHEME_SYMBOLP(obj)) {
+  if (!SCHEME_SYMBOLP(obj)) return NULL;
-    /* Find variable from module. */
-    Scheme_Object *modname, *varname;
-    int mod_phase = 0;
-
-    if (!SCHEME_PAIRP(obj)) return NULL;
-
-    modname = SCHEME_CAR(obj);
-    
-    if (SCHEME_INTP(modname)) {
-      mod_phase = SCHEME_INT_VAL(modname);
-      if (mod_phase != 1) return NULL;
-
-      obj = SCHEME_CDR(obj);
-
-      if (!SCHEME_PAIRP(obj)) return NULL;
-      modname = SCHEME_CAR(obj);
-    }
-
-    varname = SCHEME_CDR(obj);
-
-    if (SAME_OBJ(modname, kernel_symbol) && !mod_phase) {
-      return (Scheme_Object *)scheme_global_bucket(varname, scheme_get_kernel_env());
-    } else {
-      Module_Variable *mv;
-      Scheme_Object *insp;
-
-      insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
-      
-      mv = MALLOC_ONE_TAGGED(Module_Variable);
-      mv->so.type = scheme_module_variable_type;
-      
-      mv->modidx = modname;
-      mv->sym = varname;
-      mv->insp = insp;
-      mv->pos = -1;
-      mv->mod_phase = mod_phase;
-
-      return (Scheme_Object *)mv;
-    }
-  }
 
   return (Scheme_Object *)scheme_global_bucket(obj, env);
 }
 
+static Scheme_Object *write_module_variable(Scheme_Object *obj)
+{
+  scheme_signal_error("module variables should have been handled in print.c");
+  return NULL;
+}
+
+static Scheme_Object *read_module_variable(Scheme_Object *obj)
+{
+  scheme_signal_error("module variables should have been handled in read.c");
+  return NULL;
+}
+
 static Scheme_Object *write_local(Scheme_Object *obj)
 {
   return scheme_make_integer(SCHEME_LOCAL_POS(obj));
@@ -5128,9 +5100,16 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
     if (SCHEME_FALSEP(stx)) {
       stx = NULL;
     } else if (SCHEME_RPAIRP(stx)) {
-      rp->delay_info = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
+      struct Scheme_Load_Delay *d;
-      rp->delay_refcount++;
+      Scheme_Object *pr;
+      d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
       stx = SCHEME_CAR(stx);
+      pr = rp->delay_info_rpair;
+      if (!pr) {
+        pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d);
+        rp->delay_info_rpair = pr;
+      }
+      SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1);
     } else {
       if (!SCHEME_STXP(stx)) return NULL;
     }

src/mzscheme/src/eval.c

@@ -1721,20 +1721,23 @@ Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data)
 
 static Scheme_Object *link_module_variable(Scheme_Object *modidx,
 					   Scheme_Object *varname,
-					   Scheme_Object *insp,
+					   int check_access, Scheme_Object *insp,
 					   int pos, int mod_phase,
-					   Scheme_Env *env)
+					   Scheme_Env *env, 
+                                           Scheme_Object **exprs, int which)
 {
   Scheme_Object *modname;
   Scheme_Env *menv;
+  int self = 0;
 
   /* If it's a name id, resolve the name. */
   modname = scheme_module_resolve(modidx, 1);
 
   if (env->module && SAME_OBJ(env->module->modname, modname)
-      && (env->mod_phase == mod_phase))
+      && (env->mod_phase == mod_phase)) {
+    self = 1;
     menv = env;
-  else {
+  } else {
     menv = scheme_module_access(modname, env, mod_phase);
     
     if (!menv && env->phase) {
@@ -1757,22 +1760,57 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
       return NULL;
     }
 
-    if (!SAME_OBJ(menv, env)) {
+    if (check_access && !SAME_OBJ(menv, env)) {
       varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, 
                                                   insp, pos, 0, NULL, env);
     }
   }
 
+  if (exprs) {
+    if (self) {
+      exprs[which] = varname;
+    } else {
+      if (mod_phase != 0)
+        modname = scheme_make_pair(modname, scheme_make_integer(mod_phase));
+      modname = scheme_make_pair(varname, modname);
+      exprs[which] = modname;
+    }
+  }
+
   return (Scheme_Object *)scheme_global_bucket(varname, menv);
 }
 
-static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
+static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,
                                     Scheme_Object *src_modidx, 
                                     Scheme_Object *dest_modidx)
 {
-  if (SCHEME_SYMBOLP(expr)) {
+  Scheme_Object *expr = exprs[which];
+
+  if (SCHEME_FALSEP(expr)) {
     /* See scheme_make_environment_dummy */
     return (Scheme_Object *)scheme_global_bucket(begin_symbol, env);
+  } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) {
+    /* Simplified module reference */
+    Scheme_Object *modname, *varname;
+    int mod_phase = 0;
+    if (SCHEME_SYMBOLP(expr)) {
+      varname = expr;
+      modname = env->module->modname;
+      mod_phase = env->mod_phase;
+    } else {
+      varname = SCHEME_CAR(expr);
+      modname = SCHEME_CDR(expr);
+      if (SCHEME_PAIRP(modname)) {
+        mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));
+        modname = SCHEME_CAR(modname);
+      }
+    }
+    return link_module_variable(modname,
+                                varname,
+                                0, NULL,
+                                -1, mod_phase,
+                                env, 
+                                NULL, 0);
   } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
     Scheme_Bucket_With_Home *b = (Scheme_Bucket_With_Home *)expr;
     
@@ -1781,18 +1819,20 @@ static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
     else
       return link_module_variable(b->home->module->modname,
 				  (Scheme_Object *)b->bucket.bucket.key,
-				  b->home->module->insp,
+				  1, b->home->module->insp,
 				  -1, b->home->mod_phase,
-				  env);
+				  env, 
+                                  exprs, which);
   } else {
     Module_Variable *mv = (Module_Variable *)expr;
     
     return link_module_variable(scheme_modidx_shift(mv->modidx,
-						    src_modidx,
+                                                    src_modidx,
-						    dest_modidx),
+                                                    dest_modidx),
-				mv->sym, mv->insp,
+				mv->sym, 1, mv->insp,
 				mv->pos, mv->mod_phase,
-				env);
+				env,
+                                exprs, which);
   }
 }
 
@@ -8589,6 +8629,7 @@ static void *eval_k(void)
       v = _scheme_eval_linked_expr_wp(v, p);
   } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_compilation_top_type)) {
     Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)v;
+    Resolve_Prefix *rp;
     int depth;
 
     depth = top->max_let_depth + scheme_prefix_depth(top->prefix);
@@ -8604,6 +8645,9 @@ static void *eval_k(void)
 
     if (use_jit)
       v = scheme_jit_expr(v);
+    else
+      v = scheme_eval_clone(v);
+    rp = scheme_prefix_eval_clone(top->prefix);
 
     save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase);
 
@@ -9689,6 +9733,60 @@ local_eval(int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
+/*========================================================================*/
+/*                       cloning prefix information                       */
+/*========================================================================*/
+
+Scheme_Object *scheme_eval_clone(Scheme_Object *expr)
+{
+  /* Clone as much as necessary of `expr' so that prefixes are
+     cloned. Cloned prefixes, in turn, can be updated by linking to
+     reduce the overhead of cross-module references. */
+  if (SAME_TYPE(SCHEME_TYPE(expr), scheme_syntax_type)) {
+    int kind;
+    Scheme_Object *orig, *naya;
+    
+    kind = SCHEME_PINT_VAL(expr);
+    orig = SCHEME_IPTR_VAL(expr);
+    switch (kind) {
+    case MODULE_EXPD:
+      naya = scheme_module_eval_clone(orig);
+      break;
+    case DEFINE_SYNTAX_EXPD:
+    case DEFINE_FOR_SYNTAX_EXPD:
+      naya = scheme_syntaxes_eval_clone(orig);
+      break;
+    default:
+      naya = orig;
+      break;
+    }
+
+    if (SAME_OBJ(orig, naya))
+      return expr;
+    
+    return scheme_make_syntax_resolved(kind, naya);
+  } else
+    return expr;
+}
+
+Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp)
+{
+  Resolve_Prefix *naya;
+  Scheme_Object **tls;
+
+  if (!rp->num_toplevels)
+    return rp;
+
+  naya = MALLOC_ONE_TAGGED(Resolve_Prefix);
+  memcpy(naya, rp, sizeof(Resolve_Prefix));
+  
+  tls = MALLOC_N(Scheme_Object*, rp->num_toplevels);
+  memcpy(tls, rp->toplevels, sizeof(Scheme_Object *) * rp->num_toplevels);
+  naya->toplevels = tls;
+
+  return naya;
+}
+
 /*========================================================================*/
 /*        creating/pushing prefix for top-levels and syntax objects       */
 /*========================================================================*/
@@ -9725,7 +9823,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
     for (i = 0; i < rp->num_toplevels; i++) {
       v = rp->toplevels[i];
       if (genv)
-	v = link_toplevel(rp->toplevels[i], genv, src_modidx, now_modidx);
+	v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx);
       a[i] = v;
     }
 
@@ -9733,7 +9831,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
       i = rp->num_toplevels;
       v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx, 
 					   genv ? genv->export_registry : NULL);
-      if (v || rp->delay_info) {
+      if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {
 	/* Put lazy-shift info in a[i]: */
         Scheme_Object **ls;
         ls = MALLOC_N(Scheme_Object *, 2);
@@ -9926,15 +10024,17 @@ int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
                                     int num_toplevels, int num_stxes, int num_lifts)
 {
   Scheme_Closure_Data *data = NULL;
+  Scheme_Type ty;
 
   while (1) {
-    if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) {
+    ty = SCHEME_TYPE(app_rator);
+    if (SAME_TYPE(ty, scheme_closure_type)) {
       data = SCHEME_COMPILED_CLOS_CODE(app_rator);
       break;
-    } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) {
+    } else if (SAME_TYPE(ty, scheme_unclosed_procedure_type)) {
       data = (Scheme_Closure_Data *)app_rator;
       break;
-    } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) {
+    } else if (SAME_TYPE(ty, scheme_toplevel_type)) {
       int p;
       p = SCHEME_TOPLEVEL_POS(app_rator);
       while (1) {

src/mzscheme/src/module.c

@@ -3942,6 +3942,9 @@ void scheme_run_module_exptime(Scheme_Env *menv, int set_ns)
     for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]);
     e = SCHEME_VEC_ELS(e)[1];
       
+    if (SCHEME_SYMBOLP(names))
+      names = scheme_make_pair(names, scheme_null);
+
     eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env,
                  rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx,
                  NULL);
@@ -4602,7 +4605,7 @@ module_execute(Scheme_Object *data)
   return scheme_void;
 }
 
-static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec)
+static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp)
 {
   Scheme_Object *vec2;
   int i;
@@ -4613,23 +4616,35 @@ static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec)
     SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i];
   }
   SCHEME_VEC_ELS(vec2)[1] = naya;
+  SCHEME_VEC_ELS(vec2)[3] = (Scheme_Object *)rp;
 
   return vec2;
 }
 
-static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
+static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit)
 {
   Scheme_Object *orig, *naya = NULL;
+  Resolve_Prefix *orig_rp, *rp;
   int i, cnt;
 
   cnt = SCHEME_VEC_SIZE(orig_l);
   for (i = 0; i < cnt; i++) {
     orig = SCHEME_VEC_ELS(orig_l)[i];
-    if (in_vec)
+    if (in_vec) {
+      orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
+      rp = scheme_prefix_eval_clone(orig_rp);
       orig = SCHEME_VEC_ELS(orig)[1];
+    } else {
+      orig_rp = rp = NULL;
+    }
 
-    naya = scheme_jit_expr(orig);
+    if (jit)
-    if (!SAME_OBJ(orig, naya))
+      naya = scheme_jit_expr(orig);
+    else
+      naya = orig;
+
+    if (!SAME_OBJ(orig, naya)
+        || !SAME_OBJ(orig_rp, rp))
       break;
   }
 
@@ -4641,16 +4656,27 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
       SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j];
     }
     if (in_vec)
-      naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i]);
+      naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
     SCHEME_VEC_ELS(new_l)[i] = naya;
     for (i++; i < cnt; i++) {
       orig = SCHEME_VEC_ELS(orig_l)[i];
-      if (in_vec)
-        orig = SCHEME_VEC_ELS(orig)[1];
-      naya = scheme_jit_expr(orig);
       if (in_vec) {
-	if (!SAME_OBJ(orig, naya))
+        orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
-	  naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i]);
+        rp = scheme_prefix_eval_clone(orig_rp);
+        orig = SCHEME_VEC_ELS(orig)[1];        
+      } else {
+        orig_rp = rp = NULL;
+      }
+
+      if (jit)
+        naya = scheme_jit_expr(orig);
+      else
+        naya = orig;
+
+      if (in_vec) {
+	if (!SAME_OBJ(orig, naya)
+            || !SAME_OBJ(rp, orig_rp))
+	  naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
 	else
 	  naya = SCHEME_VEC_ELS(orig_l)[i];
       }
@@ -4661,25 +4687,44 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
     return orig_l;
 }
 
-static Scheme_Object *module_jit(Scheme_Object *data)
+static Scheme_Object *do_module_clone(Scheme_Object *data, int jit)
 {
   Scheme_Module *m = (Scheme_Module *)data;
   Scheme_Object *l1, *l2;
+  Resolve_Prefix *rp;
+  
+  rp = scheme_prefix_eval_clone(m->prefix);
 
-  l1 = jit_vector(m->body, 0);
+  if (jit)
-  l2 = jit_vector(m->et_body, 1);
+    l1 = jit_vector(m->body, 0, jit);
+  else
+    l1 = m->body;
+  l2 = jit_vector(m->et_body, 1, jit);
 
-  if (SAME_OBJ(l1, m->body) && SAME_OBJ(l2, m->body))
+  if (SAME_OBJ(l1, m->body) 
+      && SAME_OBJ(l2, m->body)
+      && SAME_OBJ(rp, m->prefix))
     return data;
   
   m = MALLOC_ONE_TAGGED(Scheme_Module);
   memcpy(m, data, sizeof(Scheme_Module));
   m->body = l1;
   m->et_body = l2;
+  m->prefix = rp;
 
   return (Scheme_Object *)m;
 }
 
+static Scheme_Object *module_jit(Scheme_Object *data)
+{
+  return do_module_clone(data, 1);
+}
+
+Scheme_Object *scheme_module_eval_clone(Scheme_Object *data)
+{
+  return do_module_clone(data, 0);
+}
+
 static void module_validate(Scheme_Object *data, Mz_CPort *port, 
                             char *stack, Validate_TLS tls,
 			    int depth, int letlimit, int delta, 
@@ -6115,7 +6160,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 
 	  /* Add code with names and lexical depth to exp-time body: */
 	  vec = scheme_make_vector(5, NULL);
-	  SCHEME_VEC_ELS(vec)[0] = names;
+	  SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names)))
+                                    ? SCHEME_CAR(names)
+                                    : names);
 	  SCHEME_VEC_ELS(vec)[1] = m;
 	  SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth);
 	  SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
@@ -6125,6 +6172,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
           m = scheme_sfs(m, NULL, ri->max_let_depth);
 	  if (ri->use_jit)
 	    m = scheme_jit_expr(m);
+          rp = scheme_prefix_eval_clone(rp);
 	
 	  eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, 
                        (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,

src/mzscheme/src/mzmark.c

@@ -2191,7 +2191,7 @@ static int resolve_prefix_val_MARK(void *p) {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcMARK(rp->toplevels);
   gcMARK(rp->stxes);
-  gcMARK(rp->delay_info);
+  gcMARK(rp->delay_info_rpair);
 
   return
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@@ -2201,7 +2201,7 @@ static int resolve_prefix_val_FIXUP(void *p) {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcFIXUP(rp->toplevels);
   gcFIXUP(rp->stxes);
-  gcFIXUP(rp->delay_info);
+  gcFIXUP(rp->delay_info_rpair);
 
   return
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));

src/mzscheme/src/mzmarksrc.c

@@ -870,7 +870,7 @@ resolve_prefix_val {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcMARK(rp->toplevels);
   gcMARK(rp->stxes);
-  gcMARK(rp->delay_info);
+  gcMARK(rp->delay_info_rpair);
 
  size:
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));

src/mzscheme/src/print.c

@@ -2358,8 +2358,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
         symtab_set(pp, mt, obj);
       }
     }
-  else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type)
+  else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type))
-	   && !((Module_Variable *)obj)->mod_phase)
     {
       Scheme_Object *idx;
 
@@ -2378,7 +2377,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
           print(mv->modidx, notdisplay, 1, ht, mt, pp);
         }
 	print(mv->sym, notdisplay, 1, ht, mt, pp);
-	print_compact_number(pp, mv->pos);
+        if (((Module_Variable *)obj)->mod_phase) {
+          /* mod_phase must be 1 */
+          print_compact_number(pp, -2);
+        }
+        print_compact_number(pp, mv->pos);
 
         symtab_set(pp, mt, obj);
       }

src/mzscheme/src/read.c

@@ -4357,7 +4357,7 @@ static Scheme_Object *read_compact_svector(CPort *port, int l)
   return o;
 }
 
-static int cpt_branch[256];
+static unsigned char cpt_branch[256];
 
 static Scheme_Object *read_compact(CPort *port, int use_stack);
 
@@ -4377,8 +4377,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
   unsigned int l;
   char *s, buffer[BLK_BUF_SIZE];
   int ch;
-  int need_car = 0, proper = 0;
+  Scheme_Object *v;
-  Scheme_Object *v, *first = NULL, *last = NULL;
 
 #ifdef DO_STACK_CHECK
   {
@@ -4392,7 +4391,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
   }
 #endif
 
-  while (1) {
+  {
     ZO_CHECK(port->pos < port->size);
     ch = CP_GETC(port);
 
@@ -4530,30 +4529,22 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
       SCHEME_SET_IMMUTABLE(v);
       break;
     case CPT_PAIR:
-      if (need_car) {
+      {
 	Scheme_Object *car, *cdr;
 	car = read_compact(port, 0);
 	cdr = read_compact(port, 0);
 	v = scheme_make_pair(car, cdr);
-      } else {
-	need_car = 1;
-	continue;
       }
       break;
     case CPT_LIST:
       l = read_compact_number(port);
-      if (need_car) {
+      if (l == 1) {
-	if (l == 1) {
+        Scheme_Object *car, *cdr;
-	  Scheme_Object *car, *cdr;
+        car = read_compact(port, 0);
-	  car = read_compact(port, 0);
+        cdr = read_compact(port, 0);
-	  cdr = read_compact(port, 0);
+        v = scheme_make_pair(car, cdr);
-	  v = scheme_make_pair(car, cdr);
+      } else
-	} else
+        v = read_compact_list(l, 0, 0, port);
-	  v = read_compact_list(l, 0, 0, port);
-      } else {
-	need_car = l;
-	continue;
-      }
       break;
     case CPT_VECTOR:
       {
@@ -4761,7 +4752,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	mv->modidx = mod;
 	mv->insp = port->insp;
 	mv->sym = var;
-	mv->pos = pos;
+        if (pos == -2) {
+          mv->mod_phase = 1;
+          pos = read_compact_number(port);
+          mv->pos = pos;
+        } else
+          mv->pos = pos;
 
 	v = (Scheme_Object *)mv;
       }
@@ -4887,21 +4883,15 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
       {
 	int ppr = CPT_BETWEEN(ch, SMALL_PROPER_LIST);
 	l = ch - (ppr ? CPT_SMALL_PROPER_LIST_START : CPT_SMALL_LIST_START);
-      	if (need_car) {
+      	if (l == 1) {
-	  if (l == 1) {
+          Scheme_Object *car, *cdr;
-	    Scheme_Object *car, *cdr;
+          car = read_compact(port, 0);
-	    car = read_compact(port, 0);
+          cdr = (ppr
-	    cdr = (ppr
+                 ? scheme_null
-		   ? scheme_null
+                 : read_compact(port, 0));
-		   : read_compact(port, 0));
+          v = scheme_make_pair(car, cdr);
-	    v = scheme_make_pair(car, cdr);
+        } else
-	  } else
+          v = read_compact_list(l, ppr, /* use_stack */ 0, port);
-	    v = read_compact_list(l, ppr, /* use_stack */ 0, port);
-	} else {
-	  proper = ppr;
-	  need_car = l;
-	  continue;
-	}
       }
       break;
     case CPT_SMALL_APPLICATION_START:
@@ -4975,28 +4965,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 
     if (!v)
       scheme_ill_formed_code(port);
-
-    if (need_car) {
-      Scheme_Object *pair;
-
-      pair = scheme_make_pair(v, scheme_null);
-
-      if (last)
-	SCHEME_CDR(last) = pair;
-      else
-	first = pair;
-      last = pair;
-      --need_car;
-      if (!need_car && proper)
-	break;
-    } else {
-      if (last)
-	SCHEME_CDR(last) = v;
-      break;
-    }
   }
 
-  return first ? first : v;
+  return v;
 }
 
 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port)

src/mzscheme/src/schpriv.h

@@ -1863,8 +1863,7 @@ typedef struct Resolve_Prefix
   int num_toplevels, num_stxes, num_lifts;
   Scheme_Object **toplevels;
   Scheme_Object **stxes; /* simplified */
-  int delay_refcount;
+  Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */
-  struct Scheme_Load_Delay *delay_info;
 } Resolve_Prefix;
 
 typedef struct Resolve_Info
@@ -2394,6 +2393,11 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
 				   int src_phase, int now_phase);
 void scheme_pop_prefix(Scheme_Object **rs);
 
+Scheme_Object *scheme_eval_clone(Scheme_Object *expr);
+Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp);
+Scheme_Object *scheme_module_eval_clone(Scheme_Object *data);
+Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *form);
+
 Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env);
 Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy);
 

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.5"
+#define MZSCHEME_VERSION "4.1.3.6"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/mzscheme/src/stxobj.c

@@ -1823,12 +1823,18 @@ Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
 void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, long i)
 {
   Scheme_Object *stx;
+  int c;
+
   stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]),
-                                 rp->delay_info);
+                                 (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair));
   rp->stxes[i] = stx;
-  --rp->delay_refcount;
+  c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair));
-  if (!rp->delay_refcount)
+  --c;
-    rp->delay_info = NULL;
+  SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c);
+  if (!c) {
+    SCHEME_CDR(rp->delay_info_rpair) = NULL;
+    rp->delay_info_rpair = NULL;
+  } 
 }
 
 Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i)

src/mzscheme/src/syntax.c

@@ -5294,29 +5294,44 @@ define_for_syntaxes_execute(Scheme_Object *form)
   return do_define_syntaxes_execute(form, NULL, 1);
 }
 
-static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr)
+static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr, int jit)
 {
-  Scheme_Object *naya;
+  Resolve_Prefix *rp, *orig_rp;
+  Scheme_Object *naya, *rhs;
   
-  naya = scheme_jit_expr(SCHEME_VEC_ELS(expr)[0]);
+  rhs = SCHEME_VEC_ELS(expr)[0];
+  if (jit)
+    naya = scheme_jit_expr(rhs);
+  else
+    naya = rhs;
+
+  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
+  rp = scheme_prefix_eval_clone(orig_rp);
   
-  if (SAME_OBJ(naya, expr))
+  if (SAME_OBJ(naya, rhs)
+      && SAME_OBJ(orig_rp, rp))
     return expr;
   else {
     expr = clone_vector(expr, 0);
     SCHEME_VEC_ELS(expr)[0] = naya;
+    SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
     return expr;
   }
 }
 
 static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr)
 {
-  return do_define_syntaxes_jit(expr);
+  return do_define_syntaxes_jit(expr, 1);
 }
 
 static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr)
 {
-  return do_define_syntaxes_jit(expr);
+  return do_define_syntaxes_jit(expr, 1);
+}
+
+Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr)
+{
+  return do_define_syntaxes_jit(expr, 0);
 }
 
 static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
@@ -5611,10 +5626,9 @@ define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Exp
 Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env)
 { 
   /* Get a prefixed-based accessor for a dummy top-level bucket. It's
-     used to "link" to the right environment at run time. The `begin'
+     used to "link" to the right environment at run time. The #f as
-     symbol is arbitrary; the top-level/prefix support handles a symbol
+     a toplevel is handled in the prefix linker specially. */
-     as a "toplevel" specially. */
+  return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0);
-  return scheme_register_toplevel_in_prefix(begin_symbol, env, NULL, 0);
 }
 
 Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy)