From f08649a00772def158bb0c7de05193c362166734 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 5 May 2009 23:08:24 +0000 Subject: [PATCH] further improve procedure? and procedure-arity-includes? optimization on procedure names bound in a module top-level svn: r14725 --- collects/mzlib/port.ss | 11 ++- collects/tests/mzscheme/optimize.ss | 48 +++++---- src/mzscheme/src/eval.c | 63 ++++++++++-- src/mzscheme/src/module.c | 23 ++++- src/mzscheme/src/schpriv.h | 2 + src/mzscheme/src/stypes.h | 145 ++++++++++++++-------------- src/mzscheme/src/syntax.c | 40 ++++++++ src/mzscheme/src/type.c | 1 + 8 files changed, 223 insertions(+), 110 deletions(-) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index 60a5107359..3d7c1102c8 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -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) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 6e8138786d..24022e8808 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -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) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 62933db232..221c02b906 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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 ]) ); 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; } } } diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 195996cb99..d91c263ca4 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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); } } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 3aaeeaeab0..d21b68f054 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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 *); diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index bc774cc6e9..2fad5a151d 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -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_ }; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index a22f31b344..837b08d7de 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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 ]) ), 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)) { diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index fdcad81833..bffa739a18 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -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;