further improve procedure? and procedure-arity-includes? optimization on procedure names bound in a module top-level
svn: r14725
This commit is contained in:
Matthew Flatt
parent
4623a1ac07
commit
f08649a007
|
|
@ -1,6 +1,7 @@
|
|||
#lang mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require mzlib/etc
|
||||
(require (for-syntax scheme/base)
|
||||
mzlib/etc
|
||||
scheme/contract
|
||||
mzlib/list
|
||||
"private/port.ss")
|
||||
|
|
@ -1064,13 +1065,13 @@
|
|||
(define-syntax (newline-rx stx)
|
||||
(syntax-case stx ()
|
||||
[(_ str)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
#'here
|
||||
(byte-regexp (string->bytes/latin-1
|
||||
(format "^(?:(.*?)~a)|(.*?$)" (syntax-e #'str)))))]))
|
||||
|
||||
(define read-bytes-line-evt
|
||||
(opt-lambda (input-port [mode 'linefeed])
|
||||
(lambda (input-port [mode 'linefeed])
|
||||
(wrap-evt
|
||||
(regexp-match-evt (case mode
|
||||
[(linefeed) (newline-rx "\n")]
|
||||
|
|
@ -1085,7 +1086,7 @@
|
|||
(if (and l (zero? (bytes-length l))) eof l)))))))
|
||||
|
||||
(define read-line-evt
|
||||
(opt-lambda (input-port [mode 'linefeed])
|
||||
(lambda (input-port [mode 'linefeed])
|
||||
(wrap-evt
|
||||
(read-bytes-line-evt input-port mode)
|
||||
(lambda (s)
|
||||
|
|
|
|||
|
|
@ -694,25 +694,35 @@
|
|||
(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 ([check (lambda (proc arities non-arities)
|
||||
(test-comp `(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print (procedure? f)))
|
||||
`(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print #t)))
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print #t))))
|
||||
arities)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m scheme/base
|
||||
(define f ,proc)
|
||||
(print #f))))
|
||||
non-arities))])
|
||||
(check '(lambda (x) x) '(1) '(0 2))
|
||||
(check '(lambda (x . y) x) '(1 2 3) '(0))
|
||||
(check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3))
|
||||
(check '(lambda (x [y #f]) y) '(1 2) '(0 3)))
|
||||
|
||||
(let ([test-dropped
|
||||
(lambda (cons-name . args)
|
||||
|
|
|
|||
|
|
@ -2589,9 +2589,23 @@ static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *r
|
|||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) {
|
||||
c = SCHEME_BOX_VAL(c);
|
||||
|
||||
while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) {
|
||||
/* This must be (let ([x <proc>]) <proc>); see scheme_is_statically_proc() */
|
||||
Scheme_Let_Header *lh = (Scheme_Let_Header *)c;
|
||||
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
|
||||
c = lv->body;
|
||||
}
|
||||
}
|
||||
|
||||
if (c && SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c)))
|
||||
if (c
|
||||
&& (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c))
|
||||
|| (SAME_TYPE(scheme_compiled_syntax_type, SCHEME_TYPE(c))
|
||||
&& (SCHEME_PINT_VAL(c) == CASE_LAMBDA_EXPD))))
|
||||
return c;
|
||||
|
||||
return NULL;
|
||||
|
|
@ -2727,16 +2741,45 @@ 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;
|
||||
Scheme_Object *proc;
|
||||
Scheme_Case_Lambda *cl;
|
||||
int i, cnt;
|
||||
|
||||
proc = lookup_constant_proc(info, app->rand1);
|
||||
if (proc) {
|
||||
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
|
||||
cnt = 1;
|
||||
cl = NULL;
|
||||
} else {
|
||||
return (data->num_params == n) ? scheme_true : scheme_false;
|
||||
cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(proc);
|
||||
cnt = cl->count;
|
||||
}
|
||||
|
||||
for (i = 0; i < cnt; i++) {
|
||||
if (cl) proc = cl->array[i];
|
||||
|
||||
if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
|
||||
Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc;
|
||||
int n = SCHEME_INT_VAL(app->rand2), ok;
|
||||
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
|
||||
ok = ((data->num_params - 1) <= n);
|
||||
} else {
|
||||
ok = (data->num_params == n);
|
||||
}
|
||||
if (ok) {
|
||||
info->preserves_marks = 1;
|
||||
info->single_result = 1;
|
||||
return scheme_true;
|
||||
}
|
||||
} else {
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (i == cnt) {
|
||||
info->preserves_marks = 1;
|
||||
info->single_result = 1;
|
||||
return scheme_false;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4983,7 +4983,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
simultaneous definitions: */
|
||||
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_syntax_type)
|
||||
&& (SCHEME_PINT_VAL(e) == DEFINE_VALUES_EXPD)) {
|
||||
int n;
|
||||
int n, cnst = 0, sproc = 0;
|
||||
|
||||
e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
|
||||
|
||||
|
|
@ -4993,7 +4993,16 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
n = scheme_list_length(vars);
|
||||
cont = scheme_omittable_expr(e, n, -1, 0, info);
|
||||
|
||||
if ((n == 1) && scheme_compiled_propagate_ok(e, info)) {
|
||||
if (n == 1) {
|
||||
if (scheme_compiled_propagate_ok(e, info))
|
||||
cnst = 1;
|
||||
else if (scheme_is_statically_proc(e, info)) {
|
||||
cnst = 1;
|
||||
sproc = 1;
|
||||
}
|
||||
}
|
||||
|
||||
if (cnst) {
|
||||
Scheme_Toplevel *tl;
|
||||
|
||||
tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
|
||||
|
|
@ -5001,7 +5010,9 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) {
|
||||
Scheme_Object *e2;
|
||||
|
||||
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
|
||||
if (sproc) {
|
||||
e2 = scheme_make_noninline_proc(e);
|
||||
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
|
||||
e2 = scheme_optimize_clone(1, e, info, 0, 0);
|
||||
if (e2) {
|
||||
Scheme_Object *pr;
|
||||
|
|
@ -5011,7 +5022,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
else
|
||||
cl_first = pr;
|
||||
cl_last = pr;
|
||||
}
|
||||
} else
|
||||
e2 = scheme_make_noninline_proc(e);
|
||||
} else {
|
||||
e2 = e;
|
||||
}
|
||||
|
|
@ -5102,6 +5114,9 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
|
|||
if (rpos) {
|
||||
e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
|
||||
e = SCHEME_CDR(e);
|
||||
if (!scheme_compiled_propagate_ok(e, info)
|
||||
&& scheme_is_statically_proc(e, info))
|
||||
e = scheme_make_noninline_proc(e);
|
||||
scheme_hash_set(info->top_level_consts, rpos, e);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2207,6 +2207,8 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
|
|||
|
||||
int scheme_compiled_duplicate_ok(Scheme_Object *o);
|
||||
int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info);
|
||||
int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info);
|
||||
Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e);
|
||||
|
||||
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
|
||||
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
|
||||
|
|
|
|||
|
|
@ -169,84 +169,85 @@ enum {
|
|||
scheme_log_reader_type, /* 151 */
|
||||
scheme_free_id_info_type, /* 152 */
|
||||
scheme_rib_delimiter_type, /* 153 */
|
||||
scheme_noninline_proc_type, /* 154 */
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_, /* 154 */
|
||||
_scheme_last_normal_type_, /* 155 */
|
||||
|
||||
scheme_rt_weak_array, /* 155 */
|
||||
scheme_rt_weak_array, /* 156 */
|
||||
|
||||
scheme_rt_comp_env, /* 156 */
|
||||
scheme_rt_constant_binding, /* 157 */
|
||||
scheme_rt_resolve_info, /* 158 */
|
||||
scheme_rt_optimize_info, /* 159 */
|
||||
scheme_rt_compile_info, /* 160 */
|
||||
scheme_rt_cont_mark, /* 161 */
|
||||
scheme_rt_saved_stack, /* 162 */
|
||||
scheme_rt_reply_item, /* 163 */
|
||||
scheme_rt_closure_info, /* 164 */
|
||||
scheme_rt_overflow, /* 165 */
|
||||
scheme_rt_overflow_jmp, /* 166 */
|
||||
scheme_rt_meta_cont, /* 167 */
|
||||
scheme_rt_dyn_wind_cell, /* 168 */
|
||||
scheme_rt_dyn_wind_info, /* 169 */
|
||||
scheme_rt_dyn_wind, /* 170 */
|
||||
scheme_rt_dup_check, /* 171 */
|
||||
scheme_rt_thread_memory, /* 172 */
|
||||
scheme_rt_input_file, /* 173 */
|
||||
scheme_rt_input_fd, /* 174 */
|
||||
scheme_rt_oskit_console_input, /* 175 */
|
||||
scheme_rt_tested_input_file, /* 176 */
|
||||
scheme_rt_tested_output_file, /* 177 */
|
||||
scheme_rt_indexed_string, /* 178 */
|
||||
scheme_rt_output_file, /* 179 */
|
||||
scheme_rt_load_handler_data, /* 180 */
|
||||
scheme_rt_pipe, /* 181 */
|
||||
scheme_rt_beos_process, /* 182 */
|
||||
scheme_rt_system_child, /* 183 */
|
||||
scheme_rt_tcp, /* 184 */
|
||||
scheme_rt_write_data, /* 185 */
|
||||
scheme_rt_tcp_select_info, /* 186 */
|
||||
scheme_rt_namespace_option, /* 187 */
|
||||
scheme_rt_param_data, /* 188 */
|
||||
scheme_rt_will, /* 189 */
|
||||
scheme_rt_struct_proc_info, /* 190 */
|
||||
scheme_rt_linker_name, /* 191 */
|
||||
scheme_rt_param_map, /* 192 */
|
||||
scheme_rt_finalization, /* 193 */
|
||||
scheme_rt_finalizations, /* 194 */
|
||||
scheme_rt_cpp_object, /* 195 */
|
||||
scheme_rt_cpp_array_object, /* 196 */
|
||||
scheme_rt_stack_object, /* 197 */
|
||||
scheme_rt_preallocated_object, /* 198 */
|
||||
scheme_thread_hop_type, /* 199 */
|
||||
scheme_rt_srcloc, /* 200 */
|
||||
scheme_rt_evt, /* 201 */
|
||||
scheme_rt_syncing, /* 202 */
|
||||
scheme_rt_comp_prefix, /* 203 */
|
||||
scheme_rt_user_input, /* 204 */
|
||||
scheme_rt_user_output, /* 205 */
|
||||
scheme_rt_compact_port, /* 206 */
|
||||
scheme_rt_read_special_dw, /* 207 */
|
||||
scheme_rt_regwork, /* 208 */
|
||||
scheme_rt_buf_holder, /* 209 */
|
||||
scheme_rt_parameterization, /* 210 */
|
||||
scheme_rt_print_params, /* 211 */
|
||||
scheme_rt_read_params, /* 212 */
|
||||
scheme_rt_native_code, /* 213 */
|
||||
scheme_rt_native_code_plus_case, /* 214 */
|
||||
scheme_rt_jitter_data, /* 215 */
|
||||
scheme_rt_module_exports, /* 216 */
|
||||
scheme_rt_delay_load_info, /* 217 */
|
||||
scheme_rt_marshal_info, /* 218 */
|
||||
scheme_rt_unmarshal_info, /* 219 */
|
||||
scheme_rt_runstack, /* 220 */
|
||||
scheme_rt_sfs_info, /* 221 */
|
||||
scheme_rt_validate_clearing, /* 222 */
|
||||
scheme_rt_rb_node, /* 223 */
|
||||
scheme_rt_comp_env, /* 157 */
|
||||
scheme_rt_constant_binding, /* 158 */
|
||||
scheme_rt_resolve_info, /* 159 */
|
||||
scheme_rt_optimize_info, /* 160 */
|
||||
scheme_rt_compile_info, /* 161 */
|
||||
scheme_rt_cont_mark, /* 162 */
|
||||
scheme_rt_saved_stack, /* 163 */
|
||||
scheme_rt_reply_item, /* 164 */
|
||||
scheme_rt_closure_info, /* 165 */
|
||||
scheme_rt_overflow, /* 166 */
|
||||
scheme_rt_overflow_jmp, /* 167 */
|
||||
scheme_rt_meta_cont, /* 168 */
|
||||
scheme_rt_dyn_wind_cell, /* 169 */
|
||||
scheme_rt_dyn_wind_info, /* 170 */
|
||||
scheme_rt_dyn_wind, /* 171 */
|
||||
scheme_rt_dup_check, /* 172 */
|
||||
scheme_rt_thread_memory, /* 173 */
|
||||
scheme_rt_input_file, /* 174 */
|
||||
scheme_rt_input_fd, /* 175 */
|
||||
scheme_rt_oskit_console_input, /* 176 */
|
||||
scheme_rt_tested_input_file, /* 177 */
|
||||
scheme_rt_tested_output_file, /* 178 */
|
||||
scheme_rt_indexed_string, /* 179 */
|
||||
scheme_rt_output_file, /* 180 */
|
||||
scheme_rt_load_handler_data, /* 181 */
|
||||
scheme_rt_pipe, /* 182 */
|
||||
scheme_rt_beos_process, /* 183 */
|
||||
scheme_rt_system_child, /* 184 */
|
||||
scheme_rt_tcp, /* 185 */
|
||||
scheme_rt_write_data, /* 186 */
|
||||
scheme_rt_tcp_select_info, /* 187 */
|
||||
scheme_rt_namespace_option, /* 188 */
|
||||
scheme_rt_param_data, /* 189 */
|
||||
scheme_rt_will, /* 190 */
|
||||
scheme_rt_struct_proc_info, /* 191 */
|
||||
scheme_rt_linker_name, /* 192 */
|
||||
scheme_rt_param_map, /* 193 */
|
||||
scheme_rt_finalization, /* 194 */
|
||||
scheme_rt_finalizations, /* 195 */
|
||||
scheme_rt_cpp_object, /* 196 */
|
||||
scheme_rt_cpp_array_object, /* 197 */
|
||||
scheme_rt_stack_object, /* 198 */
|
||||
scheme_rt_preallocated_object, /* 199 */
|
||||
scheme_thread_hop_type, /* 200 */
|
||||
scheme_rt_srcloc, /* 201 */
|
||||
scheme_rt_evt, /* 202 */
|
||||
scheme_rt_syncing, /* 203 */
|
||||
scheme_rt_comp_prefix, /* 204 */
|
||||
scheme_rt_user_input, /* 205 */
|
||||
scheme_rt_user_output, /* 206 */
|
||||
scheme_rt_compact_port, /* 207 */
|
||||
scheme_rt_read_special_dw, /* 208 */
|
||||
scheme_rt_regwork, /* 209 */
|
||||
scheme_rt_buf_holder, /* 210 */
|
||||
scheme_rt_parameterization, /* 211 */
|
||||
scheme_rt_print_params, /* 212 */
|
||||
scheme_rt_read_params, /* 213 */
|
||||
scheme_rt_native_code, /* 214 */
|
||||
scheme_rt_native_code_plus_case, /* 215 */
|
||||
scheme_rt_jitter_data, /* 216 */
|
||||
scheme_rt_module_exports, /* 217 */
|
||||
scheme_rt_delay_load_info, /* 218 */
|
||||
scheme_rt_marshal_info, /* 219 */
|
||||
scheme_rt_unmarshal_info, /* 220 */
|
||||
scheme_rt_runstack, /* 221 */
|
||||
scheme_rt_sfs_info, /* 222 */
|
||||
scheme_rt_validate_clearing, /* 223 */
|
||||
scheme_rt_rb_node, /* 224 */
|
||||
#endif
|
||||
|
||||
scheme_place_type, /* 224 */
|
||||
scheme_engine_type, /* 225 */
|
||||
scheme_place_type, /* 225 */
|
||||
scheme_engine_type, /* 226 */
|
||||
|
||||
_scheme_last_type_
|
||||
};
|
||||
|
|
|
|||
|
|
@ -2837,6 +2837,46 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
|
|||
return 0;
|
||||
}
|
||||
|
||||
int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
|
||||
{
|
||||
while (1) {
|
||||
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type))
|
||||
return 1;
|
||||
else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_syntax_type)) {
|
||||
if (SCHEME_PINT_VAL(value) == CASE_LAMBDA_EXPD)
|
||||
return 1;
|
||||
else
|
||||
break;
|
||||
} else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) {
|
||||
/* Look for (let ([x <proc>]) <proc>), which is generated for optional arguments. */
|
||||
Scheme_Let_Header *lh = (Scheme_Let_Header *)value;
|
||||
if (lh->num_clauses == 1) {
|
||||
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
|
||||
if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL)) {
|
||||
value = lv->body;
|
||||
info = NULL;
|
||||
} else
|
||||
break;
|
||||
} else
|
||||
break;
|
||||
} else
|
||||
break;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
|
||||
{
|
||||
Scheme_Object *ni;
|
||||
|
||||
ni = scheme_alloc_small_object();
|
||||
ni->type = scheme_noninline_proc_type;
|
||||
SCHEME_PTR_VAL(ni) = e;
|
||||
|
||||
return ni;
|
||||
}
|
||||
|
||||
static int is_values_apply(Scheme_Object *e)
|
||||
{
|
||||
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
|
||||
|
|
|
|||
|
|
@ -621,6 +621,7 @@ void scheme_register_traversers(void)
|
|||
GC_REG_TRAV(scheme_rt_runstack, runstack_val);
|
||||
|
||||
GC_REG_TRAV(scheme_rib_delimiter_type, small_object);
|
||||
GC_REG_TRAV(scheme_noninline_proc_type, small_object);
|
||||
}
|
||||
|
||||
END_XFORM_SKIP;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user