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

Check the type of the arguments of more procedures

Browse Source 
The optimizer checks the type of the argument of some unary procedures and
uses the gathered information to replace them by the unsafe version, reduce
predicates and detect type errors. This extends the checks to more procedures
that have no unsafe version and procedures that have more than one argument.
This commit is contained in:
Gustavo Massaccesi 2015-04-01 00:45:40 -03:00
parent c44cffe5a8
commit 4c10a9efac
2 changed files with 168 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

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

201
racket/src/racket/src/optimize.c
View File

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