optimize away unneeded quoted syntax objects

svn: r5596

src/mzscheme/src/env.c

@@ -2994,10 +2994,46 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
   return rp;
 }
 
+Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri)
+{
+  /* Rewrite stxes list based on actual uses at resolve pass.
+     If we have no lifts, we can just srop unused stxes.
+     Otherwise, if any stxes go unused, we just have to replace them
+     with NULL. */
+  int i, cnt;
+  Scheme_Object **new_stxes, *v;
+
+  if (!rp->num_stxes)
+    return rp;
+
+  if (rp->num_lifts)
+    cnt = rp->num_stxes;
+  else
+    cnt = ri->stx_map->count;
+
+  new_stxes = MALLOC_N(Scheme_Object *, cnt);
+
+  for (i = 0; i < rp->num_stxes; i++) {
+    if (ri->stx_map)
+      v = scheme_hash_get(ri->stx_map, scheme_make_integer(i));
+    else
+      v = NULL;
+    if (v) {
+      new_stxes[SCHEME_INT_VAL(v)]  = rp->stxes[i];
+    }
+  }
+
+  rp->stxes = new_stxes;
+  rp->num_stxes = cnt;
+
+  return rp;
+}
+
 Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp)
 {
   Resolve_Info *naya;
   Scheme_Object *b;
+  Scheme_Hash_Table *ht;
 
   naya = MALLOC_ONE_RT(Resolve_Info);
 #ifdef MZTAG_REQUIRED
@@ -3008,6 +3044,9 @@ Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp)
   naya->next = NULL;
   naya->toplevel_pos = -1;
 
+  ht = scheme_make_hash_table(SCHEME_hash_ptr);
+  naya->stx_map = ht;
+
   b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
   naya->use_jit = SCHEME_TRUEP(b);
 
@@ -3026,6 +3065,7 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
   naya->type = scheme_rt_resolve_info;
 #endif
   naya->prefix = info->prefix;
+  naya->stx_map = info->stx_map;
   naya->next = info;
   naya->use_jit = info->use_jit;
   naya->enforce_const = info->enforce_const;
@@ -3245,6 +3285,22 @@ int scheme_resolve_is_toplevel_available(Resolve_Info *info)
   return 0;
 }
 
+int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info)
+{
+  Scheme_Hash_Table *ht;
+  Scheme_Object *v;
+
+  ht = info->stx_map;
+
+  v = scheme_hash_get(ht, scheme_make_integer(i));
+  if (!v) {
+    v = scheme_make_integer(ht->count);
+    scheme_hash_set(ht, scheme_make_integer(i), v);
+  }
+
+  return SCHEME_INT_VAL(v);
+}
+
 int scheme_resolve_quote_syntax_pos(Resolve_Info *info)
 {
   return info->prefix->num_toplevels;
@@ -4262,9 +4318,12 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
   i = rp->num_stxes;
   sv = scheme_make_vector(i, NULL);
   while (i--) {
-    ds = scheme_alloc_small_object();
-    ds->type = scheme_delay_syntax_type;
-    SCHEME_PTR_VAL(ds) = rp->stxes[i];
+    if (rp->stxes[i]) {
+      ds = scheme_alloc_small_object();
+      ds->type = scheme_delay_syntax_type;
+      SCHEME_PTR_VAL(ds) = rp->stxes[i];
+    } else
+      ds = scheme_false;
     SCHEME_VEC_ELS(sv)[i] = ds;
   }
 
@@ -4305,7 +4364,9 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
   a = MALLOC_N(Scheme_Object *, i);
   while (i--) {
     stx = SCHEME_VEC_ELS(sv)[i];
-    if (SCHEME_RPAIRP(stx)) {
+    if (SCHEME_FALSEP(stx)) {
+      stx = NULL;
+    } else if (SCHEME_RPAIRP(stx)) {
       rp->delay_info = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
       rp->delay_refcount++;
       stx = SCHEME_CAR(stx);

src/mzscheme/src/eval.c

@@ -789,7 +789,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
       || (vtype == scheme_local_unbox_type)
       || (vtype == scheme_unclosed_procedure_type)
       || (vtype == scheme_compiled_unclosed_procedure_type)
-      || (vtype == scheme_case_lambda_sequence_type))
+      || (vtype == scheme_case_lambda_sequence_type)
+      || (vtype == scheme_quote_syntax_type)
+      || (vtype == scheme_compiled_quote_syntax_type))
     return ((vals == 1) || (vals < 0));
 
   if ((vtype == scheme_compiled_quote_syntax_type)) {
@@ -1750,6 +1752,7 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
       int i, c, p;
 
       i = SCHEME_LOCAL_POS(expr);
+      i = scheme_resolve_quote_syntax_offset(i, info);
       c = scheme_resolve_toplevel_pos(info);
       p = scheme_resolve_quote_syntax_pos(info);
 
@@ -2542,7 +2545,9 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
       return scheme_optimize_expr(fb, info);
     else
       return scheme_optimize_expr(tb, info);
-  }
+  } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type)
+             || SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type))
+    return scheme_optimize_expr(tb, info);
 
   tb = scheme_optimize_expr(tb, info);
 
@@ -3798,6 +3803,8 @@ static void *compile_k(void)
 
       o = scheme_merge_expression_resolve_lifts(o, rp, ri);
 
+      rp = scheme_remap_prefix(rp, ri);
+
       top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
       top->so.type = scheme_compilation_top_type;
       top->max_let_depth = ri->max_let_depth;
@@ -8435,7 +8442,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
       if ((c < 0) || (p < 0) || (d >= depth)
 	  || (stack[d] != VALID_TOPLEVELS) 
 	  || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0)))
-	  || (num_stxes && (p == num_toplevels)))
+	  || ((p >= num_toplevels) && (p < num_toplevels + num_stxes + (num_stxes ? 1 : 0))))
 	scheme_ill_formed_code(port);
       
       if ((proc_with_refs_ok != 1) 

src/mzscheme/src/module.c

@@ -3416,7 +3416,6 @@ module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
 
   rp = scheme_resolve_prefix(0, m->comp_prefix, 1);
   m->comp_prefix = NULL;
-  m->prefix = rp;
 
   b = scheme_resolve_expr(m->dummy, old_rslv);
   m->dummy = b;
@@ -3439,6 +3438,10 @@ module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
   m->body = b;
   rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]);
 
+  rp = scheme_remap_prefix(rp, rslv);
+
+  m->prefix = rp;
+
   /* Exp-time body was resolved during compilation */
 
   return scheme_make_syntax_resolved(MODULE_EXPD, data);
@@ -4290,6 +4293,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
           scheme_enable_expression_resolve_lifts(ri);
 	  m = scheme_resolve_expr(m, ri);
           m = scheme_merge_expression_resolve_lifts(m, rp, ri);
+          rp = scheme_remap_prefix(rp, ri);
 
 	  /* Add code with names and lexical depth to exp-time body: */
 	  vec = scheme_make_vector(5, NULL);

src/mzscheme/src/mzmark.c

@@ -2636,6 +2636,7 @@ static int mark_resolve_info_MARK(void *p) {
   Resolve_Info *i = (Resolve_Info *)p;
   
   gcMARK(i->prefix);
+  gcMARK(i->stx_map);
   gcMARK(i->old_pos);
   gcMARK(i->new_pos);
   gcMARK(i->old_stx_pos);
@@ -2652,6 +2653,7 @@ static int mark_resolve_info_FIXUP(void *p) {
   Resolve_Info *i = (Resolve_Info *)p;
   
   gcFIXUP(i->prefix);
+  gcFIXUP(i->stx_map);
   gcFIXUP(i->old_pos);
   gcFIXUP(i->new_pos);
   gcFIXUP(i->old_stx_pos);

src/mzscheme/src/mzmarksrc.c

@@ -1050,6 +1050,7 @@ mark_resolve_info {
   Resolve_Info *i = (Resolve_Info *)p;
   
   gcMARK(i->prefix);
+  gcMARK(i->stx_map);
   gcMARK(i->old_pos);
   gcMARK(i->new_pos);
   gcMARK(i->old_stx_pos);

src/mzscheme/src/schpriv.h

@@ -1689,6 +1689,7 @@ typedef struct Resolve_Info
   int size, oldsize, count, pos;
   int max_let_depth; /* filled in by sub-expressions */
   Resolve_Prefix *prefix;
+  Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */
   mzshort toplevel_pos; /* -1 mean consult next */
   mzshort *old_pos;
   mzshort *new_pos;
@@ -1956,6 +1957,7 @@ int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be
 Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info);
 
 Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify);
+Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri);
 
 Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp);
 Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapcount);
@@ -1998,6 +2000,7 @@ int scheme_env_uses_toplevel(Optimize_Info *frame);
 
 int scheme_resolve_toplevel_pos(Resolve_Info *info);
 int scheme_resolve_is_toplevel_available(Resolve_Info *info);
+int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info);
 int scheme_resolve_quote_syntax_pos(Resolve_Info *info);
 Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr);
 Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info);

src/mzscheme/src/stxobj.c

@@ -1384,6 +1384,9 @@ Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i)
   Resolve_Prefix *rp;
 
   rename = o[0];
+
+  if (!rename) return scheme_false; /* happens only with corrupted .zo! */
+
   rp = (Resolve_Prefix *)o[1];
 
   if (SCHEME_INTP(rp->stxes[i])) {

src/mzscheme/src/syntax.c

@@ -4726,6 +4726,8 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In
     names = scheme_resolve_list(names, einfo);
   val = scheme_resolve_expr(val, einfo);
 
+  rp = scheme_remap_prefix(rp, einfo);
+
   base_stack_depth = scheme_make_integer(einfo->max_let_depth);
 
   len = scheme_list_length(names);
@@ -4989,6 +4991,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
   ri = scheme_resolve_info_create(rp);
   a = scheme_resolve_expr(a, ri);
 
+  rp = scheme_remap_prefix(rp, ri);
+
   /* To JIT:
        if (ri->use_jit) a = scheme_jit_expr(a);
      but it's not likely that a let-syntax-bound macro is going