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

round out inlining and optimization of simple allocating primitives

Browse Source 
svn: r12539
This commit is contained in:
Matthew Flatt 2008-11-20 13:50:22 +00:00
parent 93a13222dc
commit 8ccce66af7
9 changed files with 143 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

4
collects/texpict/utils.ss
View File

@ -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)

1
src/mred/wxme/wx_mpbrd.cxx
View File

@ -317,7 +317,6 @@ void wxMediaPasteboard::OnDefaultEvent(wxMouseEvent *event)
if (!admin)
return;
/* First, find clicked-on snip: */
x = event->x;
y = event->y;

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

@ -889,8 +889,12 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1;
}
}
/* (void <omittable> ...) */
if (SAME_OBJ(scheme_void_proc, app->args[0])) {
/* ({void,list,list*,vector,vector-immutable} <omittable> ...) */
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 <omittable>) or (void <omittable>) */
/* ({values,void,list,list*,vector,vector-immutable,box} <omittable>) */
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 <omittable> <omittable>) */
if (SAME_OBJ(scheme_void_proc, app->rator)) {
/* ({void,cons,list,list*,vector,vector-immutable) <omittable> <omittable>) */
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;

54
src/mzscheme/src/jit.c
View File

@ -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);

23
src/mzscheme/src/list.c
View File

@ -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);

8
src/mzscheme/src/read.c
View File

@ -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 {

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

@ -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;

8
src/mzscheme/src/vector.c
View File

@ -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);