suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sync to trunk

Browse Source 
svn: r17276
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-12 23:58:10 +00:00
parent a1f647121d
commit 04afe9c5cb
10 changed files with 43 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/redex/private/matcher.ss
View File

@ -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?)))

14
collects/redex/private/reduction-semantics.ss
View File

@ -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

33
collects/redex/redex.scrbl
View File

@ -369,28 +369,19 @@ clause is followed by an ellipsis. Nested ellipses produce
nested lists.
}
@defproc[(set-cache-size! [size positive-integer?]) void?]{
Changes the cache size; the default size is @scheme[350].
The cache is per-pattern (ie, each pattern has a cache of size at most
350 (by default)) and is a simple table that maps expressions to how
they matched the pattern (ie, the bindings for the pattern
variables). When the cache gets full, it is thrown away and a new
cache is started.
@defparam[caching-enabled? on? boolean?]{
When this parameter is @scheme[#t] (the default), Redex caches the results of
pattern matching and metafunction evaluation. There is a separate cache for
each pattern and metafunction; when one fills (see @scheme[set-cache-size!]),
Redex evicts all of the entries in that cache.
Caching should be disabled when matching a pattern that depends on values
other than the in-scope pattern variables or evaluating a metafunction
that reads or writes mutable external state.
}
@defparam[caching-enabled? on? boolean?]{
This is a parameter that controls whether or not a cache
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].
@defproc[(set-cache-size! [size positive-integer?]) void?]{
Changes the size of the per-pattern and per-metafunction caches. The default size is @scheme[350].
}
@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.

2
collects/repos-time-stamp/stamp.ss
View File

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

6
collects/scribblings/reference/exns.scrbl
View File

@ -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 ...)
]}
]

2
src/configure vendored
View File

@ -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 #######

2
src/mzscheme/configure.ac
View File

@ -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 #######

2
src/mzscheme/src/env.c
View File

@ -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;
}

14
src/mzscheme/src/eval.c
View File

@ -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:

7
src/mzscheme/src/jit.c
View File

@ -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 ret;
return prepare_retry_alloc(p, p2);
}
#endif