352.4

svn: r4038

src/mzscheme/gc2/gc2.h

@@ -131,6 +131,12 @@ GC2_EXTERN void *GC_malloc_one_small_tagged(size_t);
    Like GC_malloc_one_tagged, but the size must be less than 1kb,
    it must not be zero, and it must be a multiple of the word size. */
 
+GC2_EXTERN void *GC_malloc_one_small_dirty_tagged(size_t);
+/* 
+   Like GC_malloc_one_small_tagged, but the memory is not
+   zeroed. The client must set all words in the allocated
+   object before a GC can occur. */
+
 GC2_EXTERN void *GC_malloc_pair(void *car, void *cdr);
 /* 
    Like GC_malloc_one_tagged, but even more streamline. */

src/mzscheme/gc2/newgc.c

@@ -514,6 +514,30 @@ void *GC_malloc_one_small_tagged(size_t sizeb)
   }
 }
 
+void *GC_malloc_one_small_dirty_tagged(size_t sizeb)
+{
+  unsigned long newsize;
+
+  sizeb += WORD_SIZE;
+  sizeb = ALIGN_BYTES_SIZE(sizeb);
+  newsize = gen0_alloc_page->size + sizeb;
+
+  if(newsize > GEN0_PAGE_SIZE) {
+    return GC_malloc_one_tagged(sizeb - WORD_SIZE);
+  } else {
+    void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size);
+    struct objhead *info = (struct objhead *)retval;
+
+    *(void **)info = NULL; /* client promises the initialize the rest */
+
+    info->size = (sizeb >> gcLOG_WORD_SIZE);
+    gen0_alloc_page->size = newsize;
+    gen0_current_size += sizeb;
+    
+    return PTR(NUM(retval) + WORD_SIZE);
+  }
+}
+
 void *GC_malloc_pair(void *car, void *cdr)
 {
   size_t sizeb;

src/mzscheme/src/env.c

@@ -2735,7 +2735,7 @@ void scheme_optimize_info_used_top(Optimize_Info *info)
 void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value)
 {
   Scheme_Object *p;
-  
+
   p = scheme_make_vector(3, NULL);
   SCHEME_VEC_ELS(p)[0] = info->consts;
   SCHEME_VEC_ELS(p)[1] = scheme_make_integer(pos);
@@ -2818,8 +2818,11 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
 	else {
 	  *closure_offset = delta;
 	}
+      } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
+        /* Ok */
       } else if (closure_offset) {
-	return NULL;
+        /* Inlining can deal procdures and top-levels, but not other things. */
+        return NULL;
       } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) {
 	int pos;
 

src/mzscheme/src/eval.c

@@ -2013,30 +2013,36 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
   return scheme_optimize_lets((Scheme_Object *)lh, info, 1);
 }
 
+#if 0
+# define LOG_INLINE(x) x
+#else
+# define LOG_INLINE(x) /*empty*/
+#endif
+
 Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
 				   Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
 {
-  int offset;
+  int offset = 0;
 
   if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
     /* Check for inlining: */
     le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset);
-  } else if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) {
+    if (!le)
+      return NULL;
+  }
+
+  while (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) {
     if (info->top_level_consts) {
       int pos;
       pos = SCHEME_TOPLEVEL_POS(le);
       le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
-      if (le && !SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type))
+      if (!le)
-	le = NULL;
+	return NULL;
     } else
-      le = NULL;
+      return NULL;
-    offset = 0;
-  } else {
-    le = NULL;
-    offset = 0;
   }
 
-  if (le) {
+  if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
     Scheme_Closure_Data *data = (Scheme_Closure_Data *)le;
     int sz;
       
@@ -2045,9 +2051,15 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
       if ((sz >= 0) && (sz <= (info->inline_fuel * (argc + 2)))) {
 	le = scheme_optimize_clone(data->code, info, offset, argc);
 	if (le) {
-	  /* fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"); */
+	  LOG_INLINE(fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
 	  return apply_inlined(le, data, info, argc, app, app2, app3);
-	}
+	} else {
+          LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
+        }
+      } else {
+        LOG_INLINE(fprintf(stderr, "No fuel %s %d*%d/%d\n", data->name ? scheme_write_to_string(data->name, NULL) : "???", 
+                           sz, info->inline_fuel * (argc + 2),
+                           info->inline_fuel));
       }
     }
   }
@@ -2271,7 +2283,14 @@ int scheme_compiled_duplicate_ok(Scheme_Object *fb)
 	  || SCHEME_FALSEP(fb)
 	  || SCHEME_SYMBOLP(fb)
 	  || SCHEME_INTP(fb)
+	  || SCHEME_NULLP(fb)
 	  || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type)
+          /* Values that are hashed by the printer to avoid
+             duplication: */
+	  || SCHEME_CHAR_STRINGP(fb) 
+          || SCHEME_BYTE_STRINGP(fb)
+          || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
+          || SCHEME_NUMBERP(fb)
 	  || SCHEME_PRIMP(fb));
 }
 
@@ -2414,8 +2433,11 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
       pos = SCHEME_LOCAL_POS(expr);
 
       val = scheme_optimize_info_lookup(info, pos, NULL);
-      if (val)
+      if (val) {
+        if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type))
+          return scheme_optimize_expr(val, info);
 	return val;
+      }
 
       delta = scheme_optimize_info_get_shift(info, pos);
       if (delta)
@@ -2450,8 +2472,16 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
     if (info->top_level_consts) {
       int pos;
       Scheme_Object *c;
-      pos = SCHEME_TOPLEVEL_POS(expr);
+
-      c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
+      while (1) {
+        pos = SCHEME_TOPLEVEL_POS(expr);
+        c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
+        if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
+          expr = c;
+        else
+          break;
+      }
+
       if (c) {
 	if (scheme_compiled_duplicate_ok(c))
 	  return c;

src/mzscheme/src/jit.c

@@ -3117,6 +3117,26 @@ static int generate_closure(Scheme_Closure_Data *data,
   code = data->u.native_code;
 
   JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
+
+#ifdef JIT_PRECISE_GC
+  if (data->closure_size < 100) {
+    int sz;
+    sz = (sizeof(Scheme_Native_Closure)
+          + ((data->closure_size - 1) * sizeof(Scheme_Object *)));
+    jit_movi_l(JIT_R0, sz);
+    mz_prepare(1);
+    jit_pusharg_l(JIT_R0);
+    (void)mz_finish(GC_malloc_one_small_dirty_tagged);
+    jit_retval(JIT_R0);
+    retptr = mz_retain(code);
+    jit_movi_l(JIT_R1, scheme_native_closure_type); /* FIXME - this is little-endian */
+    jit_str_l(JIT_R0, JIT_R1); 
+    mz_load_retained(jitter, JIT_R1, retptr);
+    jit_stxi_p((long)&((Scheme_Native_Closure *)0x0)->code, JIT_R0, JIT_R1);
+    return 1;
+  }
+#endif
+
   mz_prepare(1);
   retptr = mz_retain(code);
 #ifdef JIT_PRECISE_GC

src/mzscheme/src/module.c

@@ -3206,7 +3206,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
 	n = scheme_list_length(vars);
 	cont = scheme_omittable_expr(e, n);
       
-	if ((n == 1) && scheme_compiled_propagate_ok(e)) {
+	if ((n == 1) && scheme_compiled_propagate_ok(e, info)) {
 	  Scheme_Toplevel *tl;
 
 	  tl = (Scheme_Toplevel *)SCHEME_CAR(vars);

src/mzscheme/src/print.c

@@ -1093,16 +1093,39 @@ print_substring(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Tab
 }
 
 static void print_escaped(PrintParams *pp, int notdisplay, 
-			  Scheme_Object *obj, Scheme_Hash_Table *ht)
+			  Scheme_Object *obj, Scheme_Hash_Table *ht,
+                          Scheme_Hash_Table *symtab)
 {
   char *r;
   long len;
+  Scheme_Object *idx;
+
+  if (symtab) {
+    idx = scheme_hash_get(symtab, obj);
+    if (idx) {
+      int l;
+      print_compact(pp, CPT_SYMREF);
+      l = SCHEME_INT_VAL(idx);
+      print_compact_number(pp, l);
+      return;
+    }
+  }
 
   print_substring(obj, notdisplay, 0, ht, NULL, NULL, pp, &r, &len);
 
-  print_compact(pp, CPT_ESCAPE);
+  if (symtab)
+    print_compact(pp, CPT_HASHED_ESCAPE);
+  else
+    print_compact(pp, CPT_ESCAPE);
   print_compact_number(pp, len);
   print_this_string(pp, r, 0, len);
+
+  if (symtab) {
+    int l = symtab->count;
+    idx = scheme_make_integer(l);
+    scheme_hash_set(symtab, obj, idx);	
+    print_compact_number(pp, l);
+  }
 }
 
 static void cannot_print(PrintParams *pp, int notdisplay, 
@@ -1234,7 +1257,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
     if (val) {
       if (val != 1) {
 	if (compact) {
-	  print_escaped(pp, notdisplay, obj, ht);
+	  print_escaped(pp, notdisplay, obj, ht, NULL);
 	  return 1;
 	} else {
 	  if (val > 0) {
@@ -1355,11 +1378,23 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
     {
       if (compact) {
 	int l;
+        Scheme_Object *idx;
 
-	print_compact(pp, CPT_BYTE_STRING);
+	idx = scheme_hash_get(symtab, obj);
-	l = SCHEME_BYTE_STRTAG_VAL(obj);
+        if (idx) {
-	print_compact_number(pp, l);
+          print_compact(pp, CPT_SYMREF);
-	print_this_string(pp, SCHEME_BYTE_STR_VAL(obj), 0, l);
+          l = SCHEME_INT_VAL(idx);
+          print_compact_number(pp, l);
+        } else {
+          print_compact(pp, CPT_BYTE_STRING);
+          l = SCHEME_BYTE_STRTAG_VAL(obj);
+          print_compact_number(pp, l);
+          print_this_string(pp, SCHEME_BYTE_STR_VAL(obj), 0, l);
+
+          idx = scheme_make_integer(symtab->count);
+          scheme_hash_set(symtab, obj, idx);
+          print_compact_number(pp, SCHEME_INT_VAL(idx));
+        }
       } else {
 	if (notdisplay) {
 	  always_scheme(pp, 0);
@@ -1374,8 +1409,27 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
     }
   else if (SCHEME_CHAR_STRINGP(obj))
     {
-      do_print_string(compact, notdisplay, pp, 
+      Scheme_Object *idx;
-		      SCHEME_CHAR_STR_VAL(obj), 0, SCHEME_CHAR_STRTAG_VAL(obj));
+      int l;
+
+      if (compact)
+        idx = scheme_hash_get(symtab, obj);
+      else
+        idx = NULL;
+
+      if (idx) {
+        print_compact(pp, CPT_SYMREF);
+        l = SCHEME_INT_VAL(idx);
+        print_compact_number(pp, l);
+      } else {
+        do_print_string(compact, notdisplay, pp, 
+                        SCHEME_CHAR_STR_VAL(obj), 0, SCHEME_CHAR_STRTAG_VAL(obj));
+        if (compact) {
+          idx = scheme_make_integer(symtab->count);
+          scheme_hash_set(symtab, obj, idx);
+          print_compact_number(pp, SCHEME_INT_VAL(idx));
+        }
+      }
       closed = 1;
     }
   else if (SCHEME_CHARP(obj))
@@ -1416,7 +1470,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
   else if (SCHEME_NUMBERP(obj))
     {
       if (compact) {
-	print_escaped(pp, notdisplay, obj, ht);
+	print_escaped(pp, notdisplay, obj, ht, symtab);
 	closed = 1;
       } else {
 	if (SCHEME_COMPLEXP(obj))
@@ -1768,7 +1822,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_regexp_type))
     {
        if (compact) {
-	 print_escaped(pp, notdisplay, obj, ht);
+	 print_escaped(pp, notdisplay, obj, ht, symtab);
        } else {
 	 Scheme_Object *src;
 	 src = scheme_regexp_source(obj);

src/mzscheme/src/read.c

@@ -4004,6 +4004,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 
     switch(cpt_branch[ch]) {
     case CPT_ESCAPE:
+    case CPT_HASHED_ESCAPE:
       {
 	int len;
 	Scheme_Object *ep;
@@ -4041,6 +4042,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	params.table = NULL;
 
 	v = read_inner(ep, NULL, port->ht, scheme_null, &params, 0);
+
+        if (ch == CPT_HASHED_ESCAPE) {
+          l = read_compact_number(port);
+          RANGE_CHECK(l, < port->symtab_size);
+          port->symtab[l] = v;
+        }
       }
       break;
     case CPT_SYMBOL:
@@ -4099,6 +4106,10 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
       RANGE_CHECK_GETS(l);
       s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
       v = scheme_make_immutable_sized_byte_string(s, l, l < BLK_BUF_SIZE);
+      
+      l = read_compact_number(port);
+      RANGE_CHECK(l, < port->symtab_size);
+      port->symtab[l] = v;
       break;
     case CPT_CHAR_STRING:
       {
@@ -4112,6 +4123,10 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	scheme_utf8_decode_all((const unsigned char *)s, el, us, 0);
 	us[l] = 0;
 	v = scheme_make_immutable_sized_char_string(us, l, 0);
+
+        l = read_compact_number(port);
+        RANGE_CHECK(l, < port->symtab_size);
+        port->symtab[l] = v;
       }
       break;
     case CPT_CHAR:

src/mzscheme/src/schcpt.h

@@ -33,10 +33,11 @@ enum {
   CPT_MODULE_VAR, /* 30 */
   CPT_PATH,
   CPT_CLOSURE,
+  CPT_HASHED_ESCAPE,
   _CPT_COUNT_
 };
 
-#define CPT_SMALL_NUMBER_START 33
+#define CPT_SMALL_NUMBER_START 34
 #define CPT_SMALL_NUMBER_END   60
 
 #define CPT_SMALL_SYMBOL_START 60

src/mzscheme/src/schpriv.h

@@ -1787,7 +1787,7 @@ Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, in
 Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info);
 
 int scheme_compiled_duplicate_ok(Scheme_Object *o);
-int scheme_compiled_propagate_ok(Scheme_Object *o);
+int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info);
 
 Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
 Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 352
-#define MZSCHEME_VERSION_MINOR 3
+#define MZSCHEME_VERSION_MINOR 4
 
-#define MZSCHEME_VERSION "352.3" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "352.4" _MZ_SPECIAL_TAG

src/mzscheme/src/syntax.c

@@ -203,7 +203,7 @@ static void register_traversers(void);
 
 #define max(a, b) (((a) > (b)) ? (a) : (b))
 
-#define MAX_PROC_INLINE_SIZE 32
+#define MAX_PROC_INLINE_SIZE 256
 
 /**********************************************************************/
 /*                          initialization                            */
@@ -2396,7 +2396,7 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
   return 0;
 }
 
-int scheme_compiled_propagate_ok(Scheme_Object *value)
+int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
 {
   if (scheme_compiled_duplicate_ok(value))
     return 1;
@@ -2408,6 +2408,16 @@ int scheme_compiled_propagate_ok(Scheme_Object *value)
       return 1;
   }
 
+  if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) {
+    if (info->top_level_consts) {
+      int pos;
+      pos = SCHEME_TOPLEVEL_POS(value);
+      value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
+      if (value)
+        return 1;
+    }
+  }
+
   return 0;
 }
 
@@ -2432,7 +2442,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
       lhs = SCHEME_TYPE(clv->value);
       if ((lhs == scheme_compiled_unclosed_procedure_type)
 	  || (lhs > _scheme_compiled_values_types_)) {
-	if (for_inline) {
+        if (for_inline) {
 	  /* Just drop the inline-introduced let */
 	  return scheme_optimize_expr(clv->value, info);
 	} else {
@@ -2488,6 +2498,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
     value = scheme_optimize_expr(pre_body->value, rhs_info);
 
     pre_body->value = value;
+  
     if ((pre_body->count == 1)
 	&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
 
@@ -2506,7 +2517,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
 	}
       }
 
-      if (value && (scheme_compiled_propagate_ok(value))) {
+      if (value && (scheme_compiled_propagate_ok(value, body_info))) {
 	scheme_optimize_propagate(body_info, pos, value);
 	did_set_value = 1;
       }