From 2d0f8f6c0fe1679cdf8f7a82cb89dc619d3a4b25 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sun, 10 Apr 2016 13:59:05 -0300 Subject: [PATCH] reduce (unbox (box x)) and extend reductions to unsafe-cXr Reduce (unbox (box x)) => x Extend the reductions for cXr to the unsafe versions, for example reduce (unsafe-car (cons x y)) => x Check and save types in unsafe operations --- .../tests/racket/optimize.rktl | 31 +++++++++++++++--- racket/src/racket/src/optimize.c | 32 +++++++++++++++---- 2 files changed, 52 insertions(+), 11 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 737185dda2..926dab8a1c 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -1228,6 +1228,27 @@ '(lambda (w z) (list w z)) #f) +(test-comp '(lambda (u v) (car (cons u v))) + '(lambda (u v) u)) +(test-comp '(lambda (u v) (unsafe-car (cons u v))) + '(lambda (u v) u)) +(test-comp '(lambda (u v) (car (unsafe-cons-list u v))) + '(lambda (u v) u)) + +(test-comp '(lambda (u v) (cdr (cons u v))) + '(lambda (u v) v)) +(test-comp '(lambda (u v) (unsafe-cdr (cons u v))) + '(lambda (u v) v)) +(test-comp '(lambda (u v) (cdr (unsafe-cons-list u v))) + '(lambda (u v) v)) + +(test-comp '(lambda (v) (unbox (box v))) + '(lambda (v) v)) +(test-comp '(lambda (v) (unsafe-unbox (box v))) + '(lambda (v) v)) +(test-comp '(lambda (v) (unsafe-unbox* (box v))) + '(lambda (v) v)) + (test-comp '(lambda (w z) (pair? (list))) '(lambda (w z) #f)) (test-comp '(lambda (w z) (null? (list))) @@ -2316,13 +2337,13 @@ (+ (unsafe-car z) (car z))) #f) -(test-comp '(lambda (z) +(test-comp '(lambda (z v) ;; It's ok to move an unsafe operation past a ;; safe one: - (let ([x (unsafe-car void)]) + (let ([x (unsafe-car v)]) (+ (car z) x))) - '(lambda (z) - (+ (car z) (unsafe-car void)))) + '(lambda (z v) + (+ (car z) (unsafe-car v)))) ;; Ok to reorder arithmetic that will not raise an error: (test-comp '(lambda (x y) @@ -2339,7 +2360,7 @@ (parameterize ([compile-context-preservation-enabled ;; Avoid different amounts of unrolling #t]) - ;; Inferece of loop variable as number should allow + ;; Inference of loop variable as number should allow ;; additions to be reordered: (test-comp '(lambda () (let loop ([n 0] [m 9]) diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 7fec7e66a7..9f07005020 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -3575,25 +3575,36 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz case scheme_application2_type: { Scheme_App2_Rec *app2 = (Scheme_App2_Rec *)rand; - if (IS_NAMED_PRIM(rator, "car")) { + if (IS_NAMED_PRIM(rator, "car") + || IS_NAMED_PRIM(rator, "unsafe-car")) { if (SAME_OBJ(scheme_list_proc, app2->rator)) { /* (car (list X)) */ alt = ensure_single_value(app2->rand); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "cdr") + || IS_NAMED_PRIM(rator, "unsafe-cdr")) { if (SAME_OBJ(scheme_list_proc, app2->rator)) { /* (cdr (list X)) */ alt = make_discarding_sequence(app2->rand, scheme_null, info); return replace_tail_inside(alt, inside, app->rand); } + } else if (IS_NAMED_PRIM(rator, "unbox") + || IS_NAMED_PRIM(rator, "unsafe-unbox") + || IS_NAMED_PRIM(rator, "unsafe-unbox*")) { + if (SAME_OBJ(scheme_box_proc, app2->rator)) { + /* (unbox (box X)) */ + alt = ensure_single_value(app2->rand); + return replace_tail_inside(alt, inside, app->rand); + } } break; } case scheme_application3_type: { Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)rand; - if (IS_NAMED_PRIM(rator, "car")) { + if (IS_NAMED_PRIM(rator, "car") + || IS_NAMED_PRIM(rator, "unsafe-car")) { if (SAME_OBJ(scheme_cons_proc, app3->rator) || SAME_OBJ(scheme_unsafe_cons_list_proc, app3->rator) || SAME_OBJ(scheme_list_proc, app3->rator) @@ -3602,7 +3613,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz alt = make_discarding_reverse_sequence(app3->rand2, app3->rand1, info); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "cdr") + || IS_NAMED_PRIM(rator, "unsafe-cdr")) { if (SAME_OBJ(scheme_cons_proc, app3->rator) || SAME_OBJ(scheme_unsafe_cons_list_proc, app3->rator) || SAME_OBJ(scheme_list_star_proc, app3->rator)) { @@ -3629,7 +3641,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz { Scheme_App_Rec *appr = (Scheme_App_Rec *)rand; Scheme_Object *r = appr->args[0]; - if (IS_NAMED_PRIM(rator, "car")) { + if (IS_NAMED_PRIM(rator, "car") + || IS_NAMED_PRIM(rator, "unsafe-car")) { if ((appr->args > 0) && (SAME_OBJ(scheme_list_proc, r) || SAME_OBJ(scheme_list_star_proc, r))) { @@ -3637,7 +3650,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz alt = make_discarding_app_sequence(appr, 0, NULL, info); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "cdr") + || IS_NAMED_PRIM(rator, "unsafe-cdr")) { /* (cdr ({list|list*} X Y ...)) */ if ((appr->args > 0) && (SAME_OBJ(scheme_list_proc, r) @@ -3716,12 +3730,18 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz check_known_variant(info, app_o, rator, rand, "fxnot", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, scheme_real_p_proc); check_known(info, app_o, rator, rand, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); + check_known(info, app_o, rator, rand, "unsafe-car", scheme_pair_p_proc, NULL); check_known(info, app_o, rator, rand, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); + check_known(info, app_o, rator, rand, "unsafe-cdr", scheme_pair_p_proc, NULL); check_known(info, app_o, rator, rand, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); + check_known(info, app_o, rator, rand, "unsafe-mcar", scheme_mpair_p_proc, NULL); check_known(info, app_o, rator, rand, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); + check_known(info, app_o, rator, rand, "unsafe-mcdr", scheme_mpair_p_proc, NULL); check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_bytes_len_proc); /* It's not clear that these are useful, since a chaperone check is needed anyway: */ check_known(info, app_o, rator, rand, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); + check_known(info, app_o, rator, rand, "unsafe-unbox", scheme_box_p_proc, NULL); + check_known(info, app_o, rator, rand, "unsafe-unbox*", scheme_box_p_proc, NULL); check_known(info, app_o, rator, rand, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)