From 8ccce66af7b96a141d661b8af36cb974be77a9d4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:50:22 +0000 Subject: [PATCH] round out inlining and optimization of simple allocating primitives svn: r12539 --- collects/tests/mzscheme/optimize.ss | 41 +++++++++++++++++----- collects/texpict/utils.ss | 4 +-- src/mred/wxme/wx_mpbrd.cxx | 1 - src/mzscheme/src/eval.c | 30 ++++++++++++---- src/mzscheme/src/jit.c | 54 ++++++++++++++++++++++++----- src/mzscheme/src/list.c | 23 +++++++++--- src/mzscheme/src/read.c | 8 +++++ src/mzscheme/src/schpriv.h | 6 ++++ src/mzscheme/src/vector.c | 8 +++++ 9 files changed, 143 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 0ed2853c66..98894a67c0 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -350,6 +350,9 @@ (un0 '(1) 'list 1) (bin0 '(1 2) 'list 1 2) (tri0 '(1 2 3) 'list (lambda () 1) 2 3 void) + (un0 '1 'list* 1) + (bin0 '(1 . 2) 'list* 1 2) + (tri0 '(1 2 . 3) 'list* (lambda () 1) 2 3 void) (un0 '#&1 'box 1) (let ([test-setter @@ -443,17 +446,19 @@ (list a b c d e f))]) 10)) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j i]) j)) - (normalize-depth '(let* ([i (cons 0 1)]) i))) +;; We use nonsense `display' and `write' where we used to use `cons' and +;; `list', because the old ones now get optimized away: +(test-comp (normalize-depth '(let* ([i (display 0 1)][j i]) j)) + (normalize-depth '(let* ([i (display 0 1)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i]) g)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i]) g)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i][h g]) h)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i][h g]) h)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][g i][h (car g)][m h]) m)) - (normalize-depth '(let* ([i (cons 0 1)][h (car i)]) h))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][g i][h (car g)][m h]) m)) + (normalize-depth '(let* ([i (display 0 1)][h (car i)]) h))) ; (require #%kernel) ; @@ -685,6 +690,26 @@ (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) +(let ([test-dropped + (lambda (cons-name . args) + (test-comp `(let ([x 5]) + (let ([y (,cons-name ,@args)]) + x)) + 5))]) + (test-dropped 'cons 1 2) + (test-dropped 'mcons 1 2) + (test-dropped 'box 1) + (let ([test-multi + (lambda (cons-name) + (test-dropped cons-name 1 2) + (test-dropped cons-name 1 2 3) + (test-dropped cons-name 1) + (test-dropped cons-name))]) + (test-multi 'list) + (test-multi 'list*) + (test-multi 'vector) + (test-multi 'vector-immutable))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index f787dd868f..ff0305dadc 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -286,9 +286,9 @@ w h)))) - (define (filled-rounded-rectangle w h [corner-radius 0.25] #:angle [angle 0]) + (define (filled-rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0]) (let ([dc-path (new dc-path%)]) - (send dc-path rounded-rectangle 0 0 w h (- corner-radius)) + (send dc-path rounded-rectangle 0 0 w h corner-radius) (send dc-path rotate angle) (let-values ([(x y w h) (send dc-path get-bounding-box)]) (dc (λ (dc dx dy) diff --git a/src/mred/wxme/wx_mpbrd.cxx b/src/mred/wxme/wx_mpbrd.cxx index b038ab87f1..17f6bb9730 100644 --- a/src/mred/wxme/wx_mpbrd.cxx +++ b/src/mred/wxme/wx_mpbrd.cxx @@ -317,7 +317,6 @@ void wxMediaPasteboard::OnDefaultEvent(wxMouseEvent *event) if (!admin) return; - /* First, find clicked-on snip: */ x = event->x; y = event->y; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1a169a3daa..1aff3b6e8a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -889,8 +889,12 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ...) */ - if (SAME_OBJ(scheme_void_proc, app->args[0])) { + /* ({void,list,list*,vector,vector-immutable} ...) */ + if (SAME_OBJ(scheme_void_proc, app->args[0]) + || SAME_OBJ(scheme_list_proc, app->args[0]) + || SAME_OBJ(scheme_list_star_proc, app->args[0]) + || SAME_OBJ(scheme_vector_proc, app->args[0]) + || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { int i; @@ -905,10 +909,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } if ((vtype == scheme_application2_type)) { - /* (values ) or (void ) */ + /* ({values,void,list,list*,vector,vector-immutable,box} ) */ Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; if (SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_void_proc, app->rator)) { + || SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator) + || SAME_OBJ(scheme_box_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info)) @@ -928,8 +937,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ) */ - if (SAME_OBJ(scheme_void_proc, app->rator)) { + /* ({void,cons,list,list*,vector,vector-immutable) ) */ + if (SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_cons_proc, app->rator) + || SAME_OBJ(scheme_mcons_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) @@ -2507,7 +2522,8 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf } } - if (SAME_OBJ(scheme_values_func, app->rator) + if ((SAME_OBJ(scheme_values_func, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator)) && scheme_omittable_expr(app->rand, 1, -1, 0, info)) { info->preserves_marks = 1; info->single_result = 1; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 0e04244bbe..3c4c239c2e 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1256,8 +1256,7 @@ static void *malloc_double(void) #endif #ifdef CAN_INLINE_ALLOC -static void *make_list_code; -# define make_list make_list_code +static void *make_list_code, *make_list_star_code; #else static Scheme_Object *make_list(long n) { @@ -1270,6 +1269,17 @@ static Scheme_Object *make_list(long n) return l; } +static Scheme_Object *make_list_star(long n) +{ + GC_CAN_IGNORE Scheme_Object **rs = MZ_RUNSTACK; + GC_CAN_IGNORE Scheme_Object *l = rs[--n]; + + while (n--) { + l = cons(rs[n], l); + } + + return l; +} #endif #if !defined(CAN_INLINE_ALLOC) @@ -4077,6 +4087,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, NULL, app, NULL); + } else if (IS_NAMED_PRIM(rator, "list*")) { + /* on a single argument, `list*' is identity */ + mz_runstack_skipped(jitter, 1); + generate_non_tail(app->rand, jitter, 0, 1); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + return 1; } else if (IS_NAMED_PRIM(rator, "list")) { mz_runstack_skipped(jitter, 1); generate_non_tail(app->rand, jitter, 0, 1); @@ -4553,7 +4570,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i (void)jit_movi_p(JIT_R0, scheme_void); return 1; - } else if (IS_NAMED_PRIM(rator, "cons")) { + } else if (IS_NAMED_PRIM(rator, "cons") + || IS_NAMED_PRIM(rator, "list*")) { LOG_IT(("inlined cons\n")); generate_two_args(app->rand1, app->rand2, jitter, 1); @@ -4748,8 +4766,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, app, NULL, NULL); - } else if (IS_NAMED_PRIM(rator, "list")) { + } else if (IS_NAMED_PRIM(rator, "list") + || IS_NAMED_PRIM(rator, "list*")) { int c = app->num_args; + int star; + + star = IS_NAMED_PRIM(rator, "list*"); if (c) generate_app(app, NULL, c, jitter, 0, 0, 1); @@ -4757,13 +4779,19 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int #ifdef CAN_INLINE_ALLOC jit_movi_l(JIT_R2, c); - (void)jit_calli(make_list_code); + if (star) + (void)jit_calli(make_list_star_code); + else + (void)jit_calli(make_list_code); #else JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); jit_movi_l(JIT_R0, c); mz_prepare(1); jit_pusharg_l(JIT_R0); - (void)mz_finish(make_list); + if (star) + (void)mz_finish(make_list_star); + else + (void)mz_finish(make_list); jit_retval(JIT_R0); #endif @@ -7252,13 +7280,21 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) #ifdef CAN_INLINE_ALLOC /* *** make_list_code *** */ /* R2 has length, args are on runstack */ - { + for (i = 0; i < 2; i++) { jit_insn *ref, *refnext; - make_list_code = jit_get_ip().ptr; + if (i == 0) + make_list_code = jit_get_ip().ptr; + else + make_list_star_code = jit_get_ip().ptr; mz_prolog(JIT_R1); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); - (void)jit_movi_p(JIT_R0, &scheme_null); + if (i == 0) + (void)jit_movi_p(JIT_R0, &scheme_null); + else { + jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE); + jit_ldxr_p(JIT_R0, JIT_RUNSTACK, JIT_R2); + } __START_SHORT_JUMPS__(1); ref = jit_beqi_l(jit_forward(), JIT_R2, 0); diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 30254661a6..21d1d6d8df 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -27,7 +27,11 @@ /* globals */ Scheme_Object scheme_null[1]; +Scheme_Object *scheme_cons_proc; +Scheme_Object *scheme_mcons_proc; Scheme_Object *scheme_list_proc; +Scheme_Object *scheme_list_star_proc; +Scheme_Object *scheme_box_proc; /* locals */ static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]); @@ -155,7 +159,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("mpair?", p, env); + REGISTER_SO(scheme_cons_proc); p = scheme_make_noncm_prim(cons_prim, "cons", 2, 2); + scheme_cons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("cons", p, env); @@ -167,7 +173,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("cdr", p, env); + REGISTER_SO(scheme_mcons_proc); p = scheme_make_noncm_prim(mcons_prim, "mcons", 2, 2); + scheme_mcons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("mcons", p, env); @@ -205,11 +213,14 @@ scheme_init_list (Scheme_Env *env) | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant ("list", p, env); - scheme_add_global_constant ("list*", - scheme_make_immed_prim(list_star_prim, - "list*", - 1, -1), - env); + REGISTER_SO(scheme_list_star_proc); + p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1); + scheme_list_star_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); + scheme_add_global_constant ("list*", p, env); + scheme_add_global_constant("immutable?", scheme_make_folding_prim(immutablep, "immutable?", @@ -409,7 +420,9 @@ scheme_init_list (Scheme_Env *env) 1, 1, 1), env); + REGISTER_SO(scheme_box_proc); p = scheme_make_immed_prim(box, BOX, 1, 1); + scheme_box_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant(BOX, p, env); diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index f80452e61e..473c2b1f15 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -4371,6 +4371,8 @@ static Scheme_Object *read_compact_k(void) return read_compact(port, p->ku.k.i1); } +int dump_info = 0; + static Scheme_Object *read_compact(CPort *port, int use_stack) { #define BLK_BUF_SIZE 32 @@ -4396,6 +4398,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) ZO_CHECK(port->pos < port->size); ch = CP_GETC(port); + if (dump_info) + printf("%d %d %d\n", ch, port->pos, need_car); + switch(cpt_branch[ch]) { case CPT_ESCAPE: { @@ -4451,6 +4456,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) case CPT_SYMREF: l = read_compact_number(port); RANGE_CHECK(l, < port->symtab_size); + if (dump_info) + printf("%d\n", l); v = port->symtab[l]; if (!v) { long save_pos = port->pos; @@ -5261,6 +5268,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, len = symtabsize; for (j = 1; j < len; j++) { if (!symtab[j]) { + if (dump_info) printf("at %ld %ld\n", j, rp->pos); v = read_compact(rp, 0); symtab[j] = v; } else { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 1846ad86b3..9ea3f36d3a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -260,7 +260,13 @@ 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_void_proc; +extern Scheme_Object *scheme_cons_proc; +extern Scheme_Object *scheme_mcons_proc; extern Scheme_Object *scheme_list_proc; +extern Scheme_Object *scheme_list_star_proc; +extern Scheme_Object *scheme_vector_proc; +extern Scheme_Object *scheme_vector_immutable_proc; +extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_current_inspector_proc; diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index bf51aeae25..0d7ac3df36 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -25,6 +25,10 @@ #include "schpriv.h" +/* globals */ +Scheme_Object *scheme_vector_proc; +Scheme_Object *scheme_vector_immutable_proc; + /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]); @@ -53,13 +57,17 @@ scheme_init_vector (Scheme_Env *env) 1, 2), env); + REGISTER_SO(scheme_vector_proc); p = scheme_make_immed_prim(vector, "vector", 0, -1); + scheme_vector_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("vector", p, env); + REGISTER_SO(scheme_vector_immutable_proc); p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1); + scheme_vector_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);