diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 782676f7aa..a9d5b5a1fb 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -20,6 +20,7 @@ (namespace-require 'racket/extflonum) (namespace-require 'racket/fixnum) (namespace-require 'racket/unsafe/undefined) + #;(namespace-require '(rename '#%kernel k:map map)) (eval '(define-values (prop:thing thing? thing-ref) (make-struct-type-property 'thing))) (eval '(struct rock (x) #:property prop:thing 'yes)) @@ -1245,6 +1246,29 @@ '(lambda (w z) #t) #f) +(test-comp '(lambda (x) (car x) #t) + '(lambda (x) (car x) (pair? x))) +(test-comp '(lambda (x) (cdr x) #t) + '(lambda (x) (cdr x) (pair? x))) +(test-comp '(lambda (x) (cadr x) #t) + '(lambda (x) (cadr x) (pair? x))) +(test-comp '(lambda (x) (vector-ref x 0) #t) + '(lambda (x) (vector-ref x 0) (vector? x))) +(test-comp '(lambda (x) (vector-set! x 0 #t) #t) + '(lambda (x) (vector-set! x 0 #t) (vector? x))) +(test-comp '(lambda (f) (procedure-arity-includes? f 5) #t) + '(lambda (f) (procedure-arity-includes? f 5) (procedure? f))) +(test-comp '(lambda (f l) (f l) #t) + '(lambda (f l) (f l) (procedure? f))) + +; Test the map primitive instead of the redefined version in private/map.rkt +(test-comp '(module ? '#%kernel + (display #t) + (display (lambda (f l) (map f l) #t))) + '(module ? '#%kernel + (display (primitive? map)) + (display (lambda (f l) (map f l) (procedure? f))))) + (test-comp '(lambda (w z) (let ([x (list* w z)] [y (list* z w)]) @@ -1345,6 +1369,11 @@ (begin (random) #t) (begin (random) #f)))) +(test-comp '(lambda (w) (car w) #t) + '(lambda (w) (car w) (pair? w))) +(test-comp '(lambda (w) (cadr w) #t) + '(lambda (w) (cadr w) (pair? w))) + (test-comp '(lambda (w f) (list (car (let ([x (random)]) (f x x) w)) diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 46ec52c24c..25aad22c35 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -2749,9 +2749,64 @@ static int appn_flags(Scheme_Object *rator, Optimize_Info *info) return 0; } +static void check_known(Optimize_Info *info, Scheme_Object *app, + Scheme_Object *rator, Scheme_Object *rand, int id_offset, + const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) +/* Replace the rator with an unsafe version if we know that it's ok. Alternatively, + the rator implies a check, so add type information for subsequent expressions. + If the rand has alredy a different type, mark that this will generate an error. + If unsafe is NULL then rator has no unsafe vesion, so only check the type. */ +{ + if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, who)) { + Scheme_Object *pred; + + pred = expr_implies_predicate(rand, info, id_offset, 5); + if (pred) { + if (SAME_OBJ(pred, expect_pred)) { + if (unsafe) + reset_rator(app, unsafe); + } else { + info->escapes = 1; + } + } else { + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) { + int pos = SCHEME_LOCAL_POS(rand); + if (pos >= id_offset) { + pos -= id_offset; + if (!optimize_is_mutated(info, pos)) + add_type(info, pos, expect_pred); + } + } + } + } +} + +static void check_known_rator(Optimize_Info *info, Scheme_Object *rator, int id_offset) +/* Check that rator is a procedure or add type information for subsequent expressions. */ +{ + Scheme_Object *pred; + + pred = expr_implies_predicate(rator, info, id_offset, 5); + if (pred) { + if (!SAME_OBJ(pred, scheme_procedure_p_proc)) + info->escapes = 1; + } else { + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { + int pos = SCHEME_LOCAL_POS(rator); + if (pos >= id_offset) { + pos -= id_offset; + if (!optimize_is_mutated(info, pos)) + add_type(info, pos, scheme_procedure_p_proc); + } + } + } +} + static Scheme_Object *finish_optimize_any_application(Scheme_Object *app, Scheme_Object *rator, int argc, Optimize_Info *info, int context) { + check_known_rator(info, rator, 0); + if (context & OPT_CONTEXT_BOOLEAN) if (rator_implies_predicate(rator, argc)) return make_discarding_sequence(app, scheme_true, info, 0); @@ -2799,6 +2854,23 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_ if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc)) return scheme_null; + + if (SCHEME_PRIMP(app->args[0])) { + Scheme_Object *app_o = (Scheme_Object *)app, *rator = app->args[0]; + + if (app->num_args >= 1) { + Scheme_Object *rand1 = app->args[1]; + + check_known(info, app_o, rator, rand1, 0, "vector-set!", scheme_vector_p_proc, NULL); + + check_known(info, app_o, rator, rand1, 0, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); + + check_known(info, app_o, rator, rand1, 0, "map", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "for-each", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "andmap", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "ormap", scheme_procedure_p_proc, NULL); + } + } register_local_argument_types(app, NULL, NULL, info); @@ -2858,35 +2930,6 @@ static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *r return NULL; } -static void check_known2(Optimize_Info *info, Scheme_App2_Rec *app, - Scheme_Object *rand, int id_offset, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) -/* Replace the rator with an unsafe version if we know that it's ok. Alternatively, - the rator implies a check, so add type information for subsequent expressions. - If the rand has alredy a different type, mark that this will generate an error. */ -{ - if (IS_NAMED_PRIM(app->rator, who)) { - Scheme_Object *pred; - - pred = expr_implies_predicate(rand, info, id_offset, 5); - if (pred) { - if (SAME_OBJ(pred, expect_pred)) - app->rator = unsafe; - else - info->escapes = 1; - } else { - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) { - int pos = SCHEME_LOCAL_POS(rand); - if (pos >= id_offset) { - pos -= id_offset; - if (!optimize_is_mutated(info, pos)) - add_type(info, pos, expect_pred); - } - } - } - } -} - static Scheme_Object *try_reduce_predicate(Scheme_Object *rator, Scheme_Object *rand, Optimize_Info *info, int id_offset) /* Change (pair? (list X complex-Y Z)) => (begin complex-Y #t), etc. @@ -3000,6 +3043,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags) { int flags; + Scheme_Object *rator = app->rator; Scheme_Object *rand, *inside = NULL, *alt; int id_offset = 0; @@ -3008,7 +3052,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz /* Path for direct constant folding */ if (SCHEME_TYPE(app->rand) > _scheme_compiled_values_types_) { Scheme_Object *le; - le = try_optimize_fold(app->rator, NULL, (Scheme_Object *)app, info); + le = try_optimize_fold(rator, NULL, (Scheme_Object *)app, info); if (le) return le; } @@ -3021,16 +3065,16 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if (SCHEME_TYPE(rand) > _scheme_compiled_values_types_) { Scheme_Object *le; - le = try_optimize_fold(app->rator, scheme_make_pair(rand, scheme_null), NULL, info); + le = try_optimize_fold(rator, scheme_make_pair(rand, scheme_null), NULL, info); if (le) return replace_tail_inside(le, inside, app->rand); } - if (!is_nonmutating_primitive(app->rator, 1)) + if (!is_nonmutating_primitive(rator, 1)) info->vclock += 1; - if (!is_noncapturing_primitive(app->rator, 1)) + if (!is_noncapturing_primitive(rator, 1)) info->kclock += 1; - if (!is_nonsaving_primitive(app->rator, 1)) + if (!is_nonsaving_primitive(rator, 1)) info->sclock += 1; info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); @@ -3040,8 +3084,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz info->single_result = -info->single_result; } - if ((SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator)) + if ((SAME_OBJ(scheme_values_func, rator) + || SAME_OBJ(scheme_list_star_proc, rator)) && ((context & OPT_CONTEXT_SINGLED) || scheme_omittable_expr(rand, 1, -1, 0, info, info, 0, id_offset, ID_OMIT) || single_valued_noncm_expression(rand, 5))) { @@ -3050,20 +3094,18 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz return replace_tail_inside(rand, inside, app->rand); } - /* Check for things like (cXr (cons X Y)): */ - if (SCHEME_PRIMP(app->rator) - && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) { - + if (SCHEME_PRIMP(rator)) { + /* Check for things like (cXr (cons X Y)): */ switch (SCHEME_TYPE(rand)) { case scheme_application2_type: { Scheme_App2_Rec *app2 = (Scheme_App2_Rec *)rand; if (SAME_OBJ(scheme_list_proc, app2->rator)) { - if (IS_NAMED_PRIM(app->rator, "car")) { + if (IS_NAMED_PRIM(rator, "car")) { /* (car (list X)) */ alt = make_discarding_sequence(scheme_void, app2->rand, info, id_offset); return replace_tail_inside(alt, inside, app->rand); - } else if (IS_NAMED_PRIM(app->rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "cdr")) { /* (cdr (list X)) */ alt = make_discarding_sequence(app2->rand, scheme_null, info, id_offset); return replace_tail_inside(alt, inside, app->rand); @@ -3074,7 +3116,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz case scheme_application3_type: { Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)rand; - if (IS_NAMED_PRIM(app->rator, "car")) { + if (IS_NAMED_PRIM(rator, "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) @@ -3083,7 +3125,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz alt = make_discarding_reverse_sequence(app3->rand2, app3->rand1, info, id_offset); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(app->rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "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)) { @@ -3097,7 +3139,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz alt = make_discarding_sequence(app3->rand1, alt, info, id_offset); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(app->rator, "cadr")) { + } else if (IS_NAMED_PRIM(rator, "cadr")) { if (SAME_OBJ(scheme_list_proc, app3->rator)) { /* (cadr (list X Y)) */ alt = make_discarding_sequence(app3->rand1, app3->rand2, info, id_offset); @@ -3110,7 +3152,7 @@ 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(app->rator, "car")) { + if (IS_NAMED_PRIM(rator, "car")) { if ((appr->args > 0) && (SAME_OBJ(scheme_list_proc, r) || SAME_OBJ(scheme_list_star_proc, r))) { @@ -3118,7 +3160,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz alt = make_discarding_app_sequence(appr, 0, NULL, info, id_offset); return replace_tail_inside(alt, inside, app->rand); } - } else if (IS_NAMED_PRIM(app->rator, "cdr")) { + } else if (IS_NAMED_PRIM(rator, "cdr")) { /* (cdr ({list|list*} X Y ...)) */ if ((appr->args > 0) && (SAME_OBJ(scheme_list_proc, r) @@ -3139,20 +3181,11 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } - alt = try_reduce_predicate(app->rator, rand, info, id_offset); + alt = try_reduce_predicate(rator, rand, info, id_offset); if (alt) return replace_tail_inside(alt, inside, app->rand); - check_known2(info, app, rand, id_offset, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); - check_known2(info, app, rand, id_offset, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); - check_known2(info, app, rand, id_offset, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); - check_known2(info, app, rand, id_offset, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); - /* It's not clear that these are useful, since a chaperone check is needed anyway: */ - check_known2(info, app, rand, id_offset, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); - check_known2(info, app, rand, id_offset, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); - - } else { - if (SAME_OBJ(scheme_struct_type_p_proc, app->rator)) { + if (SAME_OBJ(scheme_struct_type_p_proc, rator)) { Scheme_Object *c; c = get_struct_proc_shape(rand, info); if (c && ((SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK) @@ -3163,7 +3196,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } - if (SAME_OBJ(scheme_varref_const_p_proc, app->rator) + if (SAME_OBJ(scheme_varref_const_p_proc, rator) && SAME_TYPE(SCHEME_TYPE(rand), scheme_varref_form_type)) { Scheme_Object *var = SCHEME_PTR1_VAL(rand); if (SAME_OBJ(var, scheme_true)) { @@ -3183,15 +3216,44 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } } + + { + /* Try to check the argument's type, and use the unsafe versions if possible. */ + Scheme_Object *app_o = (Scheme_Object *)app; + + check_known(info, app_o, rator, rand, id_offset, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); + check_known(info, app_o, rator, rand, id_offset, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); + check_known(info, app_o, rator, rand, id_offset, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); + check_known(info, app_o, rator, rand, id_offset, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); + /* It's not clear that these are useful, since a chaperone check is needed anyway: */ + check_known(info, app_o, rator, rand, id_offset, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); + check_known(info, app_o, rator, rand, id_offset, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); + + /* These operation don't have an unsafe replacement. Check to record types and detect errors: */ + check_known(info, app_o, rator, rand, id_offset, "caar", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cadr", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cdar", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cddr", scheme_pair_p_proc, NULL); + + check_known(info, app_o, rator, rand, id_offset, "caddr", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cdddr", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cadddr", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "cddddr", scheme_pair_p_proc, NULL); + + check_known(info, app_o, rator, rand, id_offset, "vector->list", scheme_vector_p_proc, NULL); + check_known(info, app_o, rator, rand, id_offset, "vector->values", scheme_vector_p_proc, NULL); + + /* Some of these may have changed app->rator. */ + rator = app->rator; + } } register_local_argument_types(NULL, app, NULL, info); - flags = appn_flags(app->rator, info); + flags = appn_flags(rator, info); SCHEME_APPN_FLAGS(app) |= flags; - return finish_optimize_any_application((Scheme_Object *)app, app->rator, 1, - info, context); + return finish_optimize_any_application((Scheme_Object *)app, rator, 1, info, context); } int scheme_eq_testable_constant(Scheme_Object *v) @@ -3560,6 +3622,21 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz } } + if (SCHEME_PRIMP(app->rator)) { + Scheme_Object *app_o = (Scheme_Object *)app, *rator = app->rator, *rand1 = app->rand1, *rand2 = app->rand2; + + check_known(info, app_o, rator, rand1, 0, "vector-ref", scheme_vector_p_proc, NULL); + + check_known(info, app_o, rator, rand1, 0, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand2, 0, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); + + check_known(info, app_o, rator, rand1, 0, "map", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "for-each", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "andmap", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, 0, "ormap", scheme_procedure_p_proc, NULL); + } + register_local_argument_types(NULL, NULL, app, info); flags = appn_flags(app->rator, info);