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

some improvement in eliminating procedure? and procedure-arity-includes? statically

Browse Source 
svn: r14723
This commit is contained in:
Matthew Flatt 2009-05-05 19:22:55 +00:00
parent 19ba4a4f18
commit 4623a1ac07
5 changed files with 82 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/port.ss
View File

@ -1,7 +1,7 @@
#lang mzscheme
(require mzlib/etc
mzlib/contract
scheme/contract
mzlib/list
"private/port.ss")

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

@ -694,6 +694,26 @@
(define (q x)
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
(test-comp '(module m mzscheme
(define (f x) x)
(procedure? f))
'(module m mzscheme
(define (f x) x)
#t))
(test-comp '(module m mzscheme
(define (f x) x)
(procedure-arity-includes? f 1))
'(module m mzscheme
(define (f x) x)
#t))
(test-comp '(module m mzscheme
(define (f x) x)
(procedure-arity-includes? f 2))
'(module m mzscheme
(define (f x) x)
#f))
(let ([test-dropped
(lambda (cons-name . args)
(test-comp `(let ([x 5])

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

@ -2564,6 +2564,39 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
return (Scheme_Object *)app;
}
static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand)
{
Scheme_Object *c = NULL;
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand)))
c = rand;
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
int offset;
Scheme_Object *expr;
expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0);
c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL);
}
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) {
int pos;
while (1) {
pos = SCHEME_TOPLEVEL_POS(rand);
c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
rand = c;
else
break;
}
}
}
if (c && SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c)))
return c;
return NULL;
}
static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
{
Scheme_App2_Rec *app;
@ -2598,21 +2631,11 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
}
if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(app->rand))) {
if (lookup_constant_proc(info, app->rand)) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_true;
}
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) {
int offset;
Scheme_Object *expr;
expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(app->rand), 0);
if (scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL)) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_true;
}
}
}
if ((SAME_OBJ(scheme_values_func, app->rator)
@ -2702,6 +2725,24 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
}
}
if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) {
if (SCHEME_INTP(app->rand2)) {
Scheme_Closure_Data *data;
data = (Scheme_Closure_Data *)lookup_constant_proc(info, app->rand1);
if (data) {
int n = SCHEME_INT_VAL(app->rand2);
info->preserves_marks = 1;
info->single_result = 1;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
return ((data->num_params - 1) <= n) ? scheme_true : scheme_false;
} else {
return (data->num_params == n) ? scheme_true : scheme_false;
}
}
}
}
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {

11
src/mzscheme/src/fun.c
View File

@ -81,6 +81,7 @@ int scheme_defining_primitives; /* set to 1 during start-up */
Scheme_Object scheme_void[1]; /* the void constant */
Scheme_Object *scheme_values_func; /* the function bound to `values' */
Scheme_Object *scheme_procedure_p_proc;
Scheme_Object *scheme_procedure_arity_includes_proc;
Scheme_Object *scheme_void_proc;
Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
Scheme_Object *scheme_reduced_procedure_struct;
@ -226,6 +227,7 @@ scheme_init_fun (Scheme_Env *env)
REGISTER_SO(cached_dv_stx);
REGISTER_SO(cached_ds_stx);
REGISTER_SO(scheme_procedure_p_proc);
REGISTER_SO(scheme_procedure_arity_includes_proc);
REGISTER_SO(offstack_cont);
REGISTER_SO(offstack_overflow);
@ -488,11 +490,14 @@ scheme_init_fun (Scheme_Env *env)
"procedure-arity?",
1, 1, 1),
env);
scheme_procedure_arity_includes_proc = scheme_make_folding_prim(procedure_arity_includes,
"procedure-arity-includes?",
2, 2, 1);
scheme_add_global_constant("procedure-arity-includes?",
scheme_make_folding_prim(procedure_arity_includes,
"procedure-arity-includes?",
2, 2, 1),
scheme_procedure_arity_includes_proc,
env);
scheme_add_global_constant("procedure-reduce-arity",
scheme_make_prim_w_arity(procedure_reduce_arity,
"procedure-reduce-arity",

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

@ -267,6 +267,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_cons_proc;
extern Scheme_Object *scheme_mcons_proc;