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

bytecode compiler convert (apply f .... (list arg ...))

Browse Source
This commit is contained in:
Matthew Flatt 2010-06-01 18:21:49 -06:00
parent a0d82d07a6
commit 61d39f2568
5 changed files with 194 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/racket/private/pre-base.rkt
View File

@ -27,12 +27,32 @@
stx))
(datum->syntax stx (cdr (syntax-e stx)) stx stx)))
(define-values (new-apply)
(define-values (new-apply-proc)
(make-keyword-procedure
(lambda (kws kw-args proc args . rest)
(keyword-apply proc kws kw-args (apply list* args rest)))
apply))
(define-syntaxes (new-apply)
;; Convert (apply ...) without keyword args to primitive `apply',
;; so that oher optimizations are available.
(lambda (stx)
(let-values ([(here) (quote-syntax here)])
(if (symbol? (syntax-e stx))
(datum->syntax here 'new-apply-proc stx stx)
(let-values ([(l) (syntax->list stx)])
(let-values ([(app) (if (if l
(ormap (lambda (x) (keyword? (syntax-e x))) l)
#t)
'new-apply-proc
'apply)])
(datum->syntax
stx
(cons (datum->syntax here app (car l) (car l))
(cdr (syntax-e stx)))
stx
stx)))))))
(define-values (new-keyword-apply)
(make-keyword-procedure
(lambda (kws kw-args proc orig-kws orig-kw-args args . rest)

25
collects/tests/racket/optimize.rktl
View File

@ -935,6 +935,31 @@
'(module m mzscheme
(printf "pre\n")))
(let ([try-equiv
(lambda (extras)
(lambda (a b)
(test-comp `(module m racket
(define (f x)
(apply x ,@extras ,a)))
`(module m racket
(define (f x)
(x ,@extras ,@b))))))])
(map (lambda (try-equiv)
(try-equiv '(list) '())
(try-equiv '(quote ()) '())
(try-equiv '(list 1) '(1))
(try-equiv '(quote (1)) '(1))
(try-equiv '(list 1 2) '(1 2))
(try-equiv '(quote (1 2)) '(1 2))
(try-equiv '(list 1 2 3) '(1 2 3))
(try-equiv '(quote (1 2 3)) '(1 2 3))
(try-equiv '(list 1 2 3 4 5 6) '(1 2 3 4 5 6))
(try-equiv '(quote (1 2 3 4 5 6)) '(1 2 3 4 5 6)))
(list
(try-equiv null)
(try-equiv '(0))
(try-equiv '(0 1)))))
(test-comp '(module m mzscheme
(define (q x)
;; Single-use bindings should be inlined always:

150
src/racket/src/eval.c
View File

@ -257,6 +257,10 @@ static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Com
static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags);
static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags);
static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags);
#define cons(x,y) scheme_make_pair(x,y)
typedef void (*DW_PrePost_Proc)(void *);
@ -3350,14 +3354,106 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
return result;
}
static Scheme_Object *finish_optimize_app(Scheme_Object *o, Optimize_Info *info, int context, int rator_flags)
{
switch(SCHEME_TYPE(o)) {
case scheme_application_type:
return finish_optimize_application((Scheme_App_Rec *)o, info, context, rator_flags);
case scheme_application2_type:
return finish_optimize_application2((Scheme_App2_Rec *)o, info, context, rator_flags);
case scheme_application3_type:
return finish_optimize_application3((Scheme_App3_Rec *)o, info, context, rator_flags);
default:
scheme_signal_error("internal error: finish optimize app");
return NULL;
}
}
static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Scheme_Object *last_rand)
{
if (SAME_OBJ(rator, scheme_apply_proc)) {
switch(SCHEME_TYPE(last_rand)) {
case scheme_application_type:
rator = ((Scheme_App_Rec *)last_rand)->args[0];
break;
case scheme_application2_type:
rator = ((Scheme_App2_Rec *)last_rand)->rator;
break;
case scheme_application3_type:
rator = ((Scheme_App3_Rec *)last_rand)->rator;
break;
case scheme_pair_type:
if (scheme_is_list(last_rand))
rator = scheme_list_proc;
else
rator = NULL;
break;
case scheme_null_type:
rator = scheme_list_proc;
break;
default:
rator = NULL;
break;
}
if (rator && SAME_OBJ(rator, scheme_list_proc)) {
/* Convert (apply f arg1 ... (list arg2 ...))
to (f arg1 ... arg2 ...) */
Scheme_Object *l = scheme_null;
int i;
switch(SCHEME_TYPE(last_rand)) {
case scheme_application_type:
for (i = ((Scheme_App_Rec *)last_rand)->num_args; i--; ) {
l = scheme_make_pair(((Scheme_App_Rec *)last_rand)->args[i+1], l);
}
break;
case scheme_application2_type:
l = scheme_make_pair(((Scheme_App2_Rec *)last_rand)->rand, l);
break;
case scheme_application3_type:
l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand2, l);
l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand1, l);
break;
case scheme_pair_type:
l = last_rand;
break;
case scheme_null_type:
l = scheme_null;
break;
}
switch(SCHEME_TYPE(expr)) {
case scheme_application_type:
for (i = ((Scheme_App_Rec *)expr)->num_args - 1; i--; ) {
l = scheme_make_pair(((Scheme_App_Rec *)expr)->args[i+1], l);
}
break;
default:
case scheme_application3_type:
l = scheme_make_pair(((Scheme_App3_Rec *)expr)->rand1, l);
break;
}
return make_application(l);
}
}
return NULL;
}
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_Object *le;
Scheme_App_Rec *app;
int i, n, all_vals = 1, rator_flags = 0, sub_context = 0;
int i, n, rator_flags = 0, sub_context = 0;
app = (Scheme_App_Rec *)o;
/* Check for (apply ... (list ...)) early: */
le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]);
if (le) return scheme_optimize_expr(le, info, context);
le = check_app_let_rator(o, app->args[0], info, app->num_args, context);
if (le) return le;
@ -3383,8 +3479,22 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
if (le)
return le;
}
}
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
/* Check for (apply ... (list ...)) after some optimizations: */
le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]);
if (le) return finish_optimize_app(le, info, context, rator_flags);
return finish_optimize_application(app, info, context, rator_flags);
}
static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags)
{
Scheme_Object *le;
int all_vals = 1, i;
for (i = app->num_args; i--; ) {
if (SCHEME_TYPE(app->args[i+1]) < _scheme_compiled_values_types_)
all_vals = 0;
}
@ -3492,9 +3602,16 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
le = scheme_optimize_expr(app->rand, info, sub_context);
app->rand = le;
return finish_optimize_application2(app, info, context, rator_flags);
}
static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags)
{
Scheme_Object *le;
info->size += 1;
if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
if (SCHEME_TYPE(app->rand) > _scheme_compiled_values_types_) {
le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
if (le)
return le;
@ -3589,11 +3706,14 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
{
Scheme_App3_Rec *app;
Scheme_Object *le;
int all_vals = 1;
int rator_flags = 0, sub_context = 0;
app = (Scheme_App3_Rec *)o;
/* Check for (apply ... (list ...)) early: */
le = direct_apply((Scheme_Object *)app, app->rator, app->rand2);
if (le) return scheme_optimize_expr(le, info, context);
le = check_app_let_rator(o, app->rator, info, 2, context);
if (le) return le;
@ -3619,9 +3739,6 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
le = scheme_optimize_expr(app->rand1, info, sub_context);
app->rand1 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
all_vals = 0;
/* 2nd arg */
if (scheme_wants_flonum_arguments(app->rator, 1, 0))
@ -3632,13 +3749,26 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
le = scheme_optimize_expr(app->rand2, info, sub_context);
app->rand2 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
all_vals = 0;
/* Check for (apply ... (list ...)) after some optimizations: */
le = direct_apply((Scheme_Object *)app, app->rator, app->rand2);
if (le) return finish_optimize_app(le, info, context, rator_flags);
/* Fold or continue */
return finish_optimize_application3(app, info, context, rator_flags);
}
static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags)
{
Scheme_Object *le;
int all_vals = 1;
info->size += 1;
if (SCHEME_TYPE(app->rand1) < _scheme_compiled_values_types_)
all_vals = 0;
if (SCHEME_TYPE(app->rand2) < _scheme_compiled_values_types_)
all_vals = 0;
if (all_vals) {
le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
if (le)

13
src/racket/src/fun.c
View File

@ -84,6 +84,7 @@ READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' *
READ_ONLY Scheme_Object *scheme_procedure_p_proc;
READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
READ_ONLY Scheme_Object *scheme_void_proc;
READ_ONLY Scheme_Object *scheme_apply_proc;
READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
READ_ONLY Scheme_Object *scheme_tail_call_waiting;
@ -234,12 +235,12 @@ scheme_init_fun (Scheme_Env *env)
scheme_procedure_p_proc = o;
scheme_add_global_constant("apply",
scheme_make_prim_w_arity2(apply,
"apply",
2, -1,
0, -1),
env);
REGISTER_SO(scheme_apply_proc);
scheme_apply_proc = scheme_make_prim_w_arity2(apply,
"apply",
2, -1,
0, -1);
scheme_add_global_constant("apply", scheme_apply_proc, env);
scheme_add_global_constant("map",
scheme_make_noncm_prim(map,
"map",

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

@ -318,6 +318,7 @@ void scheme_init_os_thread_like(void *);
/* constants */
/*========================================================================*/
extern Scheme_Object *scheme_apply_proc;
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc;