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

improve inling to support ((let (....) (lambda ....)) arg ...) patterns; allow nested 'let's for local flonum binding (which fixes a problem where unsafe flonum operations could end up much slower than safe ones)

Browse Source 
svn: r17972
This commit is contained in:
Matthew Flatt 2010-02-05 00:16:06 +00:00
parent 318833f422
commit 3812f8ca72
7 changed files with 348 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/compiler/decompile.ss
View File

@ -307,7 +307,12 @@
null)
,@(if (null? captures)
null
`('(captures: ,@captures)))
`('(captures: ,@(map (lambda (c t)
(if (eq? t 'flonum)
`(flonum ,c)
c))
captures
closure-types))))
,(decompile-expr body globs
(append captures
(append vars rest-vars))

47
collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss
View File

@ -6,8 +6,14 @@
#lang scheme/base
(require scheme/cmdline
scheme/flonum
scheme/unsafe/ops)
scheme/require (for-syntax scheme/base)
(rename-in
(filtered-in
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
scheme/unsafe/ops)
[fx->fl ->fl])
(only-in scheme/flonum make-flvector))
(define (Approximate n)
(let ([u (make-flvector n 1.0)]
@ -21,37 +27,33 @@
;; v.Bv /(v.v) eigenvalue of v
(let loop ([i 0][vBv 0.0][vv 0.0])
(if (= i n)
(unsafe-flsqrt (unsafe-fl/ vBv vv))
(let ([vi (unsafe-flvector-ref v i)])
(loop (unsafe-fx+ 1 i)
(unsafe-fl+ vBv (unsafe-fl* (unsafe-flvector-ref u i) vi))
(unsafe-fl+ vv (unsafe-fl* vi vi))))))))
(flsqrt (fl/ vBv vv))
(let ([vi (flvector-ref v i)])
(loop (add1 i)
(fl+ vBv (fl* (flvector-ref u i) vi))
(fl+ vv (fl* vi vi))))))))
;; return element i,j of infinite matrix A
(define (A i j)
(unsafe-fl/ 1.0
(unsafe-fl+
(unsafe-fl* (unsafe-fx->fl (unsafe-fx+ i j))
(unsafe-fl/ (unsafe-fx->fl
(unsafe-fx+ i (unsafe-fx+ j 1)))
2.0))
(unsafe-fx->fl (unsafe-fx+ i 1)))))
(fl/ 1.0 (fl+ (fl* (->fl (+ i j))
(fl/ (->fl (+ i (+ j 1))) 2.0))
(->fl (+ i 1)))))
;; multiply vector v by matrix A
(define (MultiplyAv n v Av)
(for ([i (in-range n)])
(unsafe-flvector-set! Av i
(for/fold ([r 0.0])
([j (in-range n)])
(unsafe-fl+ r (unsafe-fl* (A i j) (unsafe-flvector-ref v j)))))))
(flvector-set! Av i
(for/fold ([r 0.0])
([j (in-range n)])
(fl+ r (fl* (A i j) (flvector-ref v j)))))))
;; multiply vector v by matrix A transposed
(define (MultiplyAtv n v Atv)
(for ([i (in-range n)])
(unsafe-flvector-set! Atv i
(for/fold ([r 0.0])
([j (in-range n)])
(unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-flvector-ref v j)))))))
(flvector-set! Atv i
(for/fold ([r 0.0])
([j (in-range n)])
(fl+ r (fl* (A j i) (flvector-ref v j)))))))
;; multiply vector v by matrix A and then by matrix A transposed
(define (MultiplyAtAv n v AtAv)
@ -63,4 +65,3 @@
(real->decimal-string
(Approximate (command-line #:args (n) (string->number n)))
9))

13
collects/tests/mzscheme/optimize.ss
View File

@ -670,6 +670,19 @@
(test-comp '(let ([x (list 3 4)]) x)
'(let ([f (lambda (a . b) b)])
(f 5 3 4)))
(test-comp '(lambda (g)
((let ([r (read)])
(lambda () (+ r r)))))
'(lambda (g)
(let ([r (read)])
(+ r r))))
(test-comp '(lambda (g)
((let ([r (read)])
(lambda (x) (+ r r)))
g))
'(lambda (g)
(let ([r (read)])
(+ r r))))
(test-comp '(let ([x 1][y 2]) x)
'1)

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

@ -2431,7 +2431,8 @@ Scheme_Object *scheme_no_potential_size(Scheme_Object *v)
static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info,
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int context)
int context,
int nested_count, Scheme_Object *orig, Scheme_Object *le_prev, long prev_offset)
{
Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *lv, *prev = NULL;
@ -2441,13 +2442,20 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
expected = data->num_params;
if (!expected) {
info = scheme_optimize_info_add_frame(info, 0, 0, 0);
info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
info->inline_fuel >>= 1;
if (nested_count) info->vclock++;
p = scheme_optimize_expr(p, info, context);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
if (!nested_count)
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info);
return p;
if (le_prev) {
*((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p;
return orig;
} else
return p;
}
lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
@ -2506,7 +2514,13 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
else
lh->body = p;
return scheme_optimize_lets((Scheme_Object *)lh, info, 1, context);
p = scheme_optimize_lets((Scheme_Object *)lh, info, 1 + nested_count, context);
if (le_prev) {
*((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p;
return orig;
} else
return p;
}
#if 0
@ -2517,24 +2531,45 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
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 *_flags, int context)
int *_flags, int context, int optimized_rator)
/* If not app, app2, or app3, just return a known procedure, if any,
and do not check arity. */
{
int offset = 0, single_use = 0, psize = 0;
Scheme_Object *bad_app = NULL;
Scheme_Object *bad_app = NULL, *prev = NULL, *orig_le = le;
long prev_offset = 0;
int nested_count = 0;
if (info->inline_fuel < 0)
return NULL;
/* Move inside `let' bindings, so we can convert ((let (....) proc) arg ...)
to (let (....) (proc arg ...)) */
while (optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_let_void_type)) {
Scheme_Let_Header *lh;
int i;
lh = (Scheme_Let_Header *)le;
prev = le;
prev_offset = (long)&(((Scheme_Let_Header *)0x0)->body);
le = lh->body;
for (i = 0; i < lh->num_clauses; i++) {
prev = le;
prev_offset = (long)&(((Scheme_Compiled_Let_Value *)0x0)->body);
le = ((Scheme_Compiled_Let_Value *)le)->body;
}
nested_count += lh->count;
}
if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
/* Found a `((lambda' */
single_use = 1;
}
if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
if (!optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* Check for inlining: */
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0, 0, &psize);
if (SCHEME_LOCAL_POS(le) >= nested_count)
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le) - nested_count, &offset, &single_use, 0, 0, &psize);
}
if (le) {
@ -2574,10 +2609,16 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
threshold = info->inline_fuel * (2 + argc);
if ((sz >= 0) && (single_use || (sz <= threshold))) {
le = scheme_optimize_clone(0, data->code, info, offset, data->num_params);
Optimize_Info *sub_info;
if (nested_count)
sub_info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
else
sub_info = info;
le = scheme_optimize_clone(0, data->code, sub_info, offset, data->num_params);
if (le) {
LOG_INLINE(fprintf(stderr, "Inline %d %d %s\n", sz, single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???"));
return apply_inlined(le, data, info, argc, app, app2, app3, context);
return apply_inlined(le, data, info, argc, app, app2, app3, context,
nested_count, orig_le, prev, prev_offset);
} else {
LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
}
@ -3058,31 +3099,43 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf
int scheme_expr_produces_flonum(Scheme_Object *expr)
{
switch (SCHEME_TYPE(expr)) {
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
return produces_unboxed(app->args[0], NULL, app->num_args, 0);
while (1) {
switch (SCHEME_TYPE(expr)) {
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
return produces_unboxed(app->args[0], NULL, app->num_args, 0);
}
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator, NULL, 1, 0);
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator, NULL, 2, 0);
}
break;
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *lh = (Scheme_Let_Header *)expr;
int i;
expr = lh->body;
for (i = 0; i < lh->num_clauses; i++) {
expr = ((Scheme_Compiled_Let_Value *)expr)->body;
}
/* check expr again */
}
break;
default:
if (SCHEME_FLOATP(expr))
return 1;
return 0;
}
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator, NULL, 1, 0);
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator, NULL, 2, 0);
}
break;
default:
if (SCHEME_FLOATP(expr))
return 1;
break;
}
return 0;
}
static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info)
@ -3239,12 +3292,11 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
for (i = 0; i < n; i++) {
if (!i) {
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context);
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 0);
if (le)
return le;
}
sub_context = 0;
if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0))
sub_context = OPT_CONTEXT_FLONUM_ARG;
@ -3253,12 +3305,10 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
app->args[i] = le;
if (!i) {
if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context);
if (le)
return le;
}
/* Maybe found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 1);
if (le)
return le;
}
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
@ -3349,16 +3399,16 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
le = check_app_let_rator(o, app->rator, info, 1, context);
if (le) return le;
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context);
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 0);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context);
{
/* Maybe found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 1);
if (le)
return le;
}
@ -3421,20 +3471,20 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
le = check_app_let_rator(o, app->rator, info, 2, context);
if (le) return le;
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context);
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 0);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context);
{
/* Maybe found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 1);
if (le)
return le;
}
/* 1st arg */
if (scheme_wants_flonum_arguments(app->rator, 0, 0))
@ -3570,7 +3620,7 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
if (rev) {
int rator2_flags;
Scheme_Object *o_f;
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context);
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context, 0);
if (o_f) {
f_is_proc = rev;
@ -3920,7 +3970,9 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
pos = SCHEME_LOCAL_POS(expr);
val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 1, context, NULL);
val = scheme_optimize_info_lookup(info, pos, NULL, NULL,
(context & OPT_CONTEXT_NO_SINGLE) ? 0 : 1,
context, NULL);
if (val) {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) {
Scheme_Once_Used *o = (Scheme_Once_Used *)val;
@ -4008,7 +4060,8 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY);
}
}
info->vclock += 1;
if (!c)
info->vclock += 1;
}
} else {
info->vclock += 1;
@ -11255,7 +11308,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0,
vc, 1);
vc, 1, 0);
}
} else {
scheme_validate_expr(port, code,
@ -11263,7 +11316,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0,
vc, 1);
vc, 1, 0);
}
}
@ -11287,7 +11340,8 @@ static Scheme_Object *validate_k(void)
scheme_validate_expr(port, expr, stack, tls,
args[0], args[1], args[2],
args[3], args[4], args[5],
app_rator, args[6], args[7], vc, args[8]);
app_rator, args[6], args[7], vc, args[8],
args[9]);
return scheme_true;
}
@ -11435,7 +11489,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr,
}
scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 1);
NULL, 0, 0, vc, 1, 0);
}
@ -11551,6 +11605,19 @@ static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct V
}
}
static void no_flo(int need_flonum, Mz_CPort *port)
{
if (need_flonum) scheme_ill_formed_code(port);
}
static void check_flo(Scheme_Object *expr, int need_flonum, Mz_CPort *port)
{
if (need_flonum) {
if (!scheme_expr_produces_flonum(expr))
scheme_ill_formed_code(port);
}
}
#define CAN_RESET_STACK_SLOT 0
#if !CAN_RESET_STACK_SLOT
# define WHEN_CAN_RESET_STACK_SLOT(x) 0
@ -11564,7 +11631,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored,
struct Validate_Clearing *vc, int tailpos)
struct Validate_Clearing *vc, int tailpos,
int need_flonum)
{
Scheme_Type type;
int did_one = 0, vc_merge = 0, vc_merge_start = 0;
@ -11576,7 +11644,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
void **pr;
int *args;
args = MALLOC_N_ATOMIC(int, 8);
args = MALLOC_N_ATOMIC(int, 10);
p->ku.k.p1 = (void *)port;
p->ku.k.p2 = (void *)expr;
@ -11591,6 +11659,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
args[5] = num_lifts;
args[6] = proc_with_refs_ok;
args[7] = result_ignored;
args[8] = tailpos;
args[9] = need_flonum;
pr = MALLOC_N(void*, 3);
pr[0] = (void *)args;
@ -11626,6 +11696,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int d = c + delta;
int p = SCHEME_TOPLEVEL_POS(expr);
no_flo(need_flonum, port);
if ((c < 0) || (p < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS)
|| (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0)))
@ -11670,6 +11742,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
if ((q < 0) || (p >= depth))
scheme_ill_formed_code(port);
if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM)
no_flo(need_flonum, port);
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) {
if (stack[p] != VALID_FLONUM)
@ -11712,6 +11787,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int q = SCHEME_LOCAL_POS(expr);
int p = q + delta;
no_flo(need_flonum, port);
if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX)
&& (stack[p] != VALID_BOX_NOCLEAR)))
scheme_ill_formed_code(port);
@ -11735,6 +11812,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
{
Scheme_Syntax_Validater f;
int p = SCHEME_PINT_VAL(expr);
no_flo(need_flonum, port);
if ((p < 0) || (p >= _COUNT_EXPD_))
scheme_ill_formed_code(port);
@ -11749,6 +11828,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
int i, n;
check_flo(expr, need_flonum, port);
n = app->num_args + 1;
delta -= (n - 1);
@ -11758,7 +11839,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < n; i++) {
scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
i ? app->args[0] : NULL, i + 1, 0, vc, 0);
i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0);
}
if (tailpos)
@ -11768,6 +11849,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
check_flo(expr, need_flonum, port);
delta -= 1;
if (delta < 0)
@ -11775,9 +11858,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0);
NULL, 1, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0);
app->rator, 2, 0, vc, 0, 0);
if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack);
@ -11786,6 +11869,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
check_flo(expr, need_flonum, port);
delta -= 2;
if (delta < 0)
@ -11794,11 +11879,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta+1] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0);
NULL, 1, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0);
app->rator, 2, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 3, 0, vc, 0);
app->rator, 3, 0, vc, 0, 0);
if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack);
@ -11809,12 +11894,14 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Sequence *seq = (Scheme_Sequence *)expr;
int cnt;
int i;
no_flo(need_flonum, port);
cnt = seq->count;
for (i = 0; i < cnt - 1; i++) {
scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 1, vc, 0);
NULL, 0, 1, vc, 0, 0);
}
expr = seq->array[cnt - 1];
@ -11826,9 +11913,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Branch_Rec *b;
int vc_pos, vc_ncpos;
no_flo(need_flonum, port);
b = (Scheme_Branch_Rec *)expr;
scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
/* This is where letlimit is useful. It prevents let-assignment in the
"then" branch that could permit bad code in the "else" branch (or the
same thing with either branch affecting later code in a sequence). */
@ -11836,7 +11925,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
vc_pos = vc->stackpos;
vc_ncpos = vc->ncstackpos;
scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, result_ignored, vc, tailpos);
NULL, 0, result_ignored, vc, tailpos, 0);
/* Rewind clears and noclears, but also save the clears,
so that the branches' effects can be merged. */
@ -11869,11 +11958,13 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_with_cont_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr;
no_flo(need_flonum, port);
scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
expr = wcm->body;
goto top;
}
@ -11886,6 +11977,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int p = qs->midpoint;
int d = c + delta;
no_flo(need_flonum, port);
if ((c < 0) || (p < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS)
|| (p != num_toplevels)
@ -11895,6 +11988,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
break;
case scheme_unclosed_procedure_type:
{
no_flo(need_flonum, port);
validate_unclosed_procedure(port, expr, stack, tls,
depth, delta, num_toplevels, num_stxes, num_lifts,
app_rator, proc_with_refs_ok, -1);
@ -11904,9 +11998,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)expr;
int q, p, c, i;
scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
/* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */
c = lv->count;
@ -11953,7 +12047,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
memset(stack + delta, VALID_UNINIT, c);
}
expr = lv->body;
goto top;
}
@ -12001,7 +12094,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_UNINIT;
scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM);
#if !CAN_RESET_STACK_SLOT
if (stack[delta] != VALID_UNINIT)
@ -12021,9 +12114,10 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
default:
/* All values are definitely ok, except pre-closed closures.
Such a closure can refer back to itself, so we use a flag
to track cycles. */
to track cycles. Also check need_flonum. */
if (SAME_TYPE(type, scheme_closure_type)) {
Scheme_Closure_Data *data;
no_flo(need_flonum, port);
expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr);
data = (Scheme_Closure_Data *)expr;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) {
@ -12033,6 +12127,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
did_one = 0;
goto top;
}
} else if (need_flonum) {
if (!SCHEME_FLOATP(expr))
no_flo(need_flonum, port);
}
break;
}
@ -12065,7 +12162,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
depth, delta, delta,
num_toplevels, num_stxes, num_lifts,
NULL, skip_refs_check ? 1 : 0, 0,
make_clearing_stack(), 0);
make_clearing_stack(), 0, 0);
}
void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta)

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

@ -3958,7 +3958,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
int directly;
jitter->unbox++;
if (can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0))
directly = 1;
directly = 2;
else if (can_unbox_directly(arg))
directly = 1;
else
@ -4255,35 +4255,51 @@ static int can_unbox_directly(Scheme_Object *obj)
{
Scheme_Type t;
t = SCHEME_TYPE(obj);
switch (t) {
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "->fl")
|| IS_NAMED_PRIM(app->rator, "fx->fl"))
while (1) {
t = SCHEME_TYPE(obj);
switch (t) {
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "->fl")
|| IS_NAMED_PRIM(app->rator, "fx->fl"))
return 1;
}
return 0;
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "flvector-ref")) return 1;
}
return 0;
}
break;
case scheme_let_value_type:
obj = ((Scheme_Let_Value *)obj)->body;
break;
case scheme_let_one_type:
obj = ((Scheme_Let_One *)obj)->body;
break;
case scheme_let_void_type:
obj = ((Scheme_Let_Void *)obj)->body;
break;
case scheme_letrec_type:
obj = ((Scheme_Letrec *)obj)->body;
break;
default:
return 0;
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "flvector-ref")) return 1;
}
}
break;
}
return 0;
}
static jit_insn *generate_arith_slow_path(mz_jit_state *jitter, Scheme_Object *rator,
@ -4901,11 +4917,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
}
if (inlined_flonum1)
can_direct1 = 1;
can_direct1 = 2;
else
can_direct1 = can_unbox_directly(rand);
if (inlined_flonum2)
can_direct2 = 1;
can_direct2 = 2;
else
can_direct2 = can_unbox_directly(rand2);
@ -7855,23 +7871,26 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
}
}
if ((which == 3)
&& (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0)
|| can_unbox_directly(app->args[3]))) {
# if !defined(INLINE_FP_OPS) || !defined(CAN_INLINE_ALLOC)
/* Error handling will have to box flonum, so don't unbox if
that cannot be done inline: */
if (!unsafe)
flonum_arg = 0;
else
# endif
if (which == 3) {
if (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0))
flonum_arg = 2;
else if (can_unbox_directly(app->args[3]))
flonum_arg = 1;
else
flonum_arg = 0;
} else
flonum_arg = 0;
# if !defined(INLINE_FP_OPS) || !defined(CAN_INLINE_ALLOC)
/* Error handling will have to box flonum, so don't unbox if
that cannot be done inline: */
if (flonum_arg && !unsafe)
flonum_arg = 0;
# endif
if (flonum_arg) {
jitter->unbox++;
generate_unboxed(app->args[3], jitter, 1, 0);
generate_unboxed(app->args[3], jitter, flonum_arg, 0);
--jitter->unbox;
} else {
generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */
@ -8697,12 +8716,16 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
}
static int generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway)
/* de-sync's; if refslow, failure jumps conditionally with non-flonum in R0 */
/* de-sync's; if refslow, failure jumps conditionally with non-flonum in R0;
inlined_ok == 2 => can generate directly; inlined_ok == 1 => non-tail unbox */
{
int saved;
if (inlined_ok) {
return generate(obj, jitter, 0, 1, JIT_R0, NULL);
if (inlined_ok == 2)
return generate(obj, jitter, 0, 1, JIT_R0, NULL);
else
return generate_non_tail(obj, jitter, 0, 1, 0);
}
if (!jitter->unbox || jitter->unbox_depth)
@ -9625,11 +9648,16 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
case scheme_let_value_type:
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos, to_unbox = 0;
START_JIT_DATA();
LOG_IT(("let...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
if (lv->count == 1) {
/* Expect one result: */
generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
@ -9707,16 +9735,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
}
case scheme_let_void_type:
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)obj;
int c = lv->count;
int c = lv->count, to_unbox = 0;
START_JIT_DATA();
LOG_IT(("letv...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_rs_dec(c);
CHECK_RUNSTACK_OVERFLOW();
stack_safety(jitter, c, 0);
@ -9742,16 +9778,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
}
case scheme_letrec_type:
{
Scheme_Letrec *l = (Scheme_Letrec *)obj;
int i, nsrs, prepped = 0;
int i, nsrs, prepped = 0, to_unbox = 0;
START_JIT_DATA();
LOG_IT(("letrec...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_rs_sync();
/* Create unfinished closures */
@ -9803,16 +9847,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
jitter->need_set_rs = nsrs;
}
if (to_unbox)
jitter->unbox = to_unbox;
return generate(l->body, jitter, is_tail, multi_ok, orig_target, for_branch);
}
case scheme_let_one_type:
{
Scheme_Let_One *lv = (Scheme_Let_One *)obj;
int flonum;
int flonum, to_unbox = 0;
START_JIT_DATA();
LOG_IT(("leto...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_runstack_skipped(jitter, 1);
#ifdef USE_FLONUM_UNBOXING
@ -9824,12 +9876,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
PAUSE_JIT_DATA();
if (flonum) {
#ifdef USE_FLONUM_UNBOXING
if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)
|| can_unbox_directly(lv->value)) {
if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)) {
jitter->unbox++;
generate_unboxed(lv->value, jitter, 2, 0);
} else {
if (0) /* validator should ensure that this is ok */
if (!can_unbox_directly(lv->value))
scheme_signal_error("internal error: bad FLONUM annotation on let");
jitter->unbox++;
generate_unboxed(lv->value, jitter, 1, 0);
} else {
scheme_signal_error("internal error: bad FLONUM annotation on let");
}
#endif
} else
@ -9864,6 +9919,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
mz_RECORD_STATUS(mz_RS_R0_HAS_RUNSTACK0);
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
}
case scheme_with_cont_mark_type:

6
src/mzscheme/src/schpriv.h
View File

@ -2308,8 +2308,9 @@ Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, in
#define OPT_CONTEXT_FLONUM_ARG 0x1
#define OPT_CONTEXT_BOOLEAN 0x2
#define OPT_CONTEXT_NO_SINGLE 0x4
#define scheme_optimize_result_context(c) (c & (~OPT_CONTEXT_FLONUM_ARG))
#define scheme_optimize_result_context(c) (c & (~(OPT_CONTEXT_FLONUM_ARG | OPT_CONTEXT_NO_SINGLE)))
#define scheme_optimize_tail_context(c) scheme_optimize_result_context(c)
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
@ -2613,7 +2614,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, struct Validate_Clearing *vc, int tailpos);
int result_ignored, struct Validate_Clearing *vc,
int tailpos, int need_flonum);
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, Validate_TLS tls,
int depth, int delta,

31
src/mzscheme/src/syntax.c
View File

@ -988,7 +988,7 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, !!only_var, 0, vc, 0);
NULL, !!only_var, 0, vc, 0, 0);
}
static Scheme_Object *
@ -1533,7 +1533,7 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
scheme_validate_toplevel(tl, port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts,
0);
@ -2178,11 +2178,11 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, f, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
scheme_validate_expr(port, e, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
}
/**********************************************************************/
@ -2348,7 +2348,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac
scheme_ill_formed_code(port);
scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
}
}
@ -2740,7 +2740,7 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, tailpos);
NULL, 0, 0, vc, tailpos, 0);
}
/**********************************************************************/
@ -3030,7 +3030,7 @@ static int worth_lifting(Scheme_Object *v)
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context)
{
Optimize_Info *body_info, *rhs_info;
Optimize_Info *sub_info, *body_info, *rhs_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
@ -3053,7 +3053,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
&& !SCHEME_LOCAL_POS(b->test)
&& !SCHEME_LOCAL_POS(b->tbranch)) {
Scheme_Branch_Rec *b3;
Optimize_Info *sub_info;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type;
@ -3099,9 +3098,15 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
}
}
body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
if (for_inline > 1) {
info->vclock++;
sub_info = scheme_optimize_info_add_frame(info, for_inline - 1, for_inline - 1, 0);
} else
sub_info = info;
body_info = scheme_optimize_info_add_frame(sub_info, head->count, head->count, 0);
if (for_inline) {
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count + (for_inline - 1), 0);
body_info->inline_fuel >>= 1;
} else
rhs_info = body_info;
@ -3514,6 +3519,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
/* Optimized away all clauses? */
if (!head->num_clauses) {
scheme_optimize_info_done(body_info);
if (for_inline > 1) scheme_optimize_info_done(sub_info);
return head->body;
}
@ -3579,6 +3585,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
}
scheme_optimize_info_done(body_info);
if (for_inline > 1) scheme_optimize_info_done(sub_info);
return form;
}
@ -4898,7 +4905,7 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, seq->array[i], stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, i > 0, vc, 0);
NULL, 0, i > 0, vc, 0, 0);
}
}
@ -5246,7 +5253,7 @@ static void splice_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, data, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0);
NULL, 0, 0, vc, 0, 0);
}
/**********************************************************************/