sync to trunk

svn: r17276

collects/redex/private/matcher.ss

@@ -1592,6 +1592,7 @@ before the pattern compiler is invoked.
                       compiled-pattern?))
  
  (set-cache-size! (-> (and/c integer? positive?) void?))
+ (cache-size (and/c integer? positive?))
  
  (make-bindings ((listof bind?) . -> . bindings?))
  (bindings-table (bindings? . -> . (listof bind?)))

collects/redex/private/reduction-semantics.ss

@@ -1425,7 +1425,15 @@
     (values
      (wrap
       (letrec ([cache (make-hash)]
+               [cache-entries 0]
                [not-in-cache (gensym)]
+               [cache-result (λ (arg res case)
+                               (when (caching-enabled?)
+                                 (when (>= cache-entries cache-size)
+                                   (set! cache (make-hash))
+                                   (set! cache-entries 0))
+                                 (hash-set! cache arg (cons res case))
+                                 (set! cache-entries (add1 cache-entries))))]
                [log-coverage (λ (id)
                                (when id
                                  (for-each 
@@ -1452,7 +1460,7 @@
                            [(null? cases) 
                             (if relation?
                                 (begin 
-                                  (hash-set! cache exp (cons #f #f))
+                                  (cache-result exp #f #f)
                                   #f)
                                 (redex-error name "no clauses matched for ~s" `(,name . ,exp)))]
                            [else
@@ -1470,7 +1478,7 @@
                                        (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
                                      (cond
                                        [ans 
-                                        (hash-set! cache exp (cons #t id))
+                                        (cache-result exp #t id)
                                         (log-coverage id)
                                         #t]
                                        [else
@@ -1499,7 +1507,7 @@
                                                          "codomain test failed for ~s, call was ~s"
                                                          ans 
                                                          `(,name ,@exp)))
-                                          (hash-set! cache exp (cons ans id))
+                                          (cache-result exp ans id)
                                           (log-coverage id)
                                           ans)]))])))]))]
                       [else 

collects/redex/redex.scrbl

@@ -369,28 +369,19 @@ clause is followed by an ellipsis.  Nested ellipses produce
 nested lists.
 }
 
-@defproc[(set-cache-size! [size positive-integer?]) void?]{
+@defparam[caching-enabled? on? boolean?]{
-
+  When this parameter is @scheme[#t] (the default), Redex caches the results of 
-Changes the cache size; the default size is @scheme[350].
+  pattern matching and metafunction evaluation. There is a separate cache for
-
+  each pattern and metafunction; when one fills (see @scheme[set-cache-size!]),
-The cache is per-pattern (ie, each pattern has a cache of size at most
+  Redex evicts all of the entries in that cache.
-350 (by default)) and is a simple table that maps expressions to how
+                                         
-they matched the pattern (ie, the bindings for the pattern
+  Caching should be disabled when matching a pattern that depends on values
-variables). When the cache gets full, it is thrown away and a new
+  other than the in-scope pattern variables or evaluating a metafunction
-cache is started.
+  that reads or writes mutable external state.
 }
 
-@defparam[caching-enabled? on? boolean?]{
+@defproc[(set-cache-size! [size positive-integer?]) void?]{                                                           
-  This is a parameter that controls whether or not a cache
+Changes the size of the per-pattern and per-metafunction caches. The default size is @scheme[350].
-  is consulted (and updated) while matching and while evaluating
-  metafunctions.
-
-  If it is @scheme[#t], then side-conditions and the right-hand sides
-  of metafunctions are assumed to only depend on the values of the
-  pattern variables in scope (and thus not on any other external
-  state).
-
-  Defaults to @scheme[#t].
 }
 
 @section{Terms}
@@ -921,7 +912,7 @@ or if the contract is violated.
 
 Note that metafunctions are assumed to always return the same results
 for the same inputs, and their results are cached, unless
-@scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a
+@scheme[caching-enabled?] is set to @scheme[#f]. Accordingly, if a
 metafunction is called with the same inputs twice, then its body is
 only evaluated a single time.
 

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "10dec2009")
+#lang scheme/base (provide stamp) (define stamp "12dec2009")

collects/scribblings/reference/exns.scrbl

@@ -57,7 +57,7 @@ exception handler obtains control, and the handler itself is
 
 @defproc*[([(error [sym symbol?]) any]
            [(error [msg string?][v any/c] ...) any]
-           [(error [src symbol?][format string?][v any/c] ...) any])]{
+           [(error [src symbol?][frmat string?][v any/c] ...) any])]{
 
 Raises the exception @scheme[exn:fail], which contains an error
 string. The different forms produce the error string in different
@@ -74,11 +74,11 @@ ways:
  @scheme[error-value->string-handler]). A space is inserted before
  each @scheme[v].}
 
- @item{@scheme[(error src format v ...)] creates a
+ @item{@scheme[(error src frmat v ...)] creates a
  message string equivalent to the string created by
 
   @schemeblock[
-  (format (string-append "~s: " format) src v ...)
+  (format (string-append "~s: " frmat) src v ...)
   ]}
 
 ]

src/configure

@@ -7100,7 +7100,7 @@ fi
 LFS_CFLAGS=`getconf LFS_CFLAGS 2> /dev/null`
 if test "${LFS_CFLAGS}" != "" ; then
   echo "Large-file support: ${LFS_CFLAGS}"
-  PREFLAGS="${PREFLAGS} ${LFS_CFLAGS}"
+  MZOPTIONS="${MZOPTIONS} ${LFS_CFLAGS}"
 fi
 
 ###### Get data sizes, stack direction, and endianness #######

src/mzscheme/configure.ac

@@ -914,7 +914,7 @@ fi
 LFS_CFLAGS=`getconf LFS_CFLAGS 2> /dev/null`
 if test "${LFS_CFLAGS}" != "" ; then
   echo "Large-file support: ${LFS_CFLAGS}"
-  PREFLAGS="${PREFLAGS} ${LFS_CFLAGS}"  
+  MZOPTIONS="${MZOPTIONS} ${LFS_CFLAGS}"  
 fi
 
 ###### Get data sizes, stack direction, and endianness #######

src/mzscheme/src/env.c

@@ -3166,7 +3166,7 @@ Optimize_Info *scheme_optimize_info_create()
 #ifdef MZTAG_REQUIRED
   info->type = scheme_rt_optimize_info;
 #endif
-  info->inline_fuel = 16;
+  info->inline_fuel = 32;
   
   return info;
 }

src/mzscheme/src/eval.c

@@ -2552,14 +2552,14 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
       all_vals = 0;
   }
 
+  info->size += 1;
+
   if (all_vals) {
     le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info);
     if (le)
       return le;
   }
 
-  info->size += 1;
-
   info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
   info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
   if (rator_flags & CLOS_RESULT_TENTATIVE) {
@@ -2723,14 +2723,14 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 
   /* Fold or continue */
 
+  info->size += 1;
+
   if (all_vals) {
     le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
     if (le)
       return le;
   }
 
-  info->size += 1;
-
   /* Check for (call-with-values (lambda () M) N): */
   if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
     if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) {
@@ -3154,8 +3154,10 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
 
       val = scheme_optimize_info_lookup(info, pos, NULL, NULL);
       if (val) {
-        if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type))
+        if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) {
+          info->size -= 1;
           return scheme_optimize_expr(val, info);
+        }
 	return val;
       }
 
@@ -3189,6 +3191,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
   case scheme_compiled_let_void_type:
     return scheme_optimize_lets(expr, info, 0);
   case scheme_compiled_toplevel_type:
+    info->size += 1;
     if (info->top_level_consts) {
       int pos;
       Scheme_Object *c;
@@ -3226,6 +3229,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
     scheme_optimize_info_used_top(info);
     return expr;
   case scheme_compiled_quote_syntax_type:
+    info->size += 1;
     scheme_optimize_info_used_top(info);
     return expr;
   case scheme_variable_type:

src/mzscheme/src/jit.c

@@ -2251,9 +2251,9 @@ static void ts_on_demand(void) XFORM_SKIP_PROC
 #ifdef MZ_PRECISE_GC
 static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC
 {
-  unsigned long ret;
-
   if (scheme_use_rtcall) {
+    unsigned long ret;
+  
     jit_future_storage[0] = p;
     jit_future_storage[1] = p2;
     ret = scheme_rtcall_alloc("[acquire_gc_page]", FSRC_OTHER);
@@ -2265,8 +2265,7 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC
     return p;
   }
 
-  ret = prepare_retry_alloc(p, p2);
+  return prepare_retry_alloc(p, p2);
-  return ret;
 }
 #endif