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

optimizer: add string? to list of relevant predicates

Browse Source 
Also add the type information for a few related functions like
string-append and bytes-append.
This commit is contained in:
Gustavo Massaccesi 2016-07-06 00:32:41 -03:00
parent 9cf9897b16
commit dce42313ad
5 changed files with 80 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1396,6 +1396,50 @@
'(lambda (w z) #t)
#f)
;Test types inference for string?
(test-comp '(lambda (s) (fixnum? (string-length s)))
'(lambda (s) (string-length s) #t))
(test-comp '(lambda (s) (string-length s) (string? s))
'(lambda (s) (string-length s) #t))
(test-comp '(lambda (s p) (string-ref s p) (string? s))
'(lambda (s p) (string-ref s p) #t))
(test-comp '(lambda (s p v) (string-set! s p v) (string? s))
'(lambda (s p v) (string-set! s p v) #t))
(test-comp '(lambda (s1) (string-append s1) (string? s1))
'(lambda (s1) (string-append s1) #t))
(test-comp '(lambda (s1 s2) (string-append s1 s2) (list (string? s1) (string? s2)))
'(lambda (s1 s2) (string-append s1 s2) (list #t #t)))
(test-comp '(lambda (s1 s2 s3) (string-append s1 s2 s3) (list (string? s1) (string? s2) (string? s3)))
'(lambda (s1 s2 s3) (string-append s1 s2 s3) (list #t #t #t)))
(test-comp '(lambda (s1) (string? (string-append s1)))
'(lambda (s1) (string-append s1) #t))
(test-comp '(lambda (s1 s2) (string? (string-append s1 s2)))
'(lambda (s1 s2) (string-append s1 s2) #t))
(test-comp '(lambda (s1 s2 s3) (string? (string-append s1 s2 s3)))
'(lambda (s1 s2 s3) (string-append s1 s2 s3) #t))
;Test types inference for bytes?
(test-comp '(lambda (s) (fixnum? (bytes-length s)))
'(lambda (s) (bytes-length s) #t))
(test-comp '(lambda (s) (bytes-length s) (bytes? s))
'(lambda (s) (bytes-length s) #t))
(test-comp '(lambda (s p) (bytes-ref s p) (bytes? s))
'(lambda (s p) (bytes-ref s p) #t))
(test-comp '(lambda (s p v) (bytes-set! s p v) (bytes? s))
'(lambda (s p v) (bytes-set! s p v) #t))
(test-comp '(lambda (s1) (bytes-append s1) (bytes? s1))
'(lambda (s1) (bytes-append s1) #t))
(test-comp '(lambda (s1 s2) (bytes-append s1 s2) (list (bytes? s1) (bytes? s2)))
'(lambda (s1 s2) (bytes-append s1 s2) (list #t #t)))
(test-comp '(lambda (s1 s2 s3) (bytes-append s1 s2 s3) (list (bytes? s1) (bytes? s2) (bytes? s3)))
'(lambda (s1 s2 s3) (bytes-append s1 s2 s3) (list #t #t #t)))
(test-comp '(lambda (s1) (bytes? (bytes-append s1)))
'(lambda (s1) (bytes-append s1) #t))
(test-comp '(lambda (s1 s2) (bytes? (bytes-append s1 s2)))
'(lambda (s1 s2) (bytes-append s1 s2) #t))
(test-comp '(lambda (s1 s2 s3) (bytes? (bytes-append s1 s2 s3)))
'(lambda (s1 s2 s3) (bytes-append s1 s2 s3) #t))
(test-comp '(lambda (w z)
(let ([x (list* w z)]
[y (list* z w)])
@ -3179,6 +3223,7 @@
(test-use-unsafe 'mpair? 'mcdr 'unsafe-mcdr)
(test-use-unsafe 'box? 'unbox 'unsafe-unbox)
(test-use-unsafe 'vector? 'vector-length 'unsafe-vector-length)
(test-use-unsafe 'string? 'string-length 'unsafe-string-length)
(test-use-unsafe 'bytes? 'bytes-length 'unsafe-bytes-length)
(test-use-unsafe/savetype 'fixnum? 'bitwise-not 'unsafe-fxnot #f)
(test-use-unsafe/savetype 'fixnum? 'fxnot 'unsafe-fxnot #f))

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

@ -2617,9 +2617,6 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
return scheme_list_pair_p_proc;
else if (SAME_OBJ(rator, scheme_mcons_proc))
return scheme_mpair_p_proc;
// XXX This could be implemented
// else if (SAME_OBJ(rator, scheme_make_byte_string_p))
// return scheme_byte_string_p_proc;
else if (SAME_OBJ(rator, scheme_list_proc)) {
if (argc >= 1)
return scheme_list_pair_p_proc;
@ -2628,6 +2625,10 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
} else if (SAME_OBJ(rator, scheme_list_star_proc)) {
if (argc > 2)
return scheme_pair_p_proc;
} else if (IS_NAMED_PRIM(rator, "string-append")) {
return scheme_string_p_proc;
} else if (IS_NAMED_PRIM(rator, "bytes-append")) {
return scheme_byte_string_p_proc;
} else if (SAME_OBJ(rator, scheme_vector_proc)
|| SAME_OBJ(rator, scheme_vector_immutable_proc)
|| SAME_OBJ(rator, scheme_make_vector_proc)
@ -2864,6 +2865,8 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
return scheme_pair_p_proc;
if (SCHEME_MPAIRP(expr))
return scheme_mpair_p_proc;
if (SCHEME_CHAR_STRINGP(expr))
return scheme_string_p_proc;
if (SCHEME_BYTE_STRINGP(expr))
return scheme_byte_string_p_proc;
if (SCHEME_VOIDP(expr))
@ -3375,6 +3378,11 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL);
check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL);
check_known_all(info, app_o, "string-append", scheme_string_p_proc, scheme_true);
check_known_all(info, app_o, "bytes-append", scheme_byte_string_p_proc, scheme_true);
check_known(info, app_o, rator, rand1, "string-set!", scheme_string_p_proc, NULL);
check_known(info, app_o, rator, rand1, "bytes-set!", scheme_byte_string_p_proc, NULL);
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)
check_known_all(info, app_o, NULL, scheme_real_p_proc,
(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL);
@ -3790,13 +3798,17 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
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);
check_known(info, app_o, rator, rand, "string-length", scheme_string_p_proc, scheme_unsafe_string_length_proc);
check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_byte_string_length_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);
check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true);
check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true);
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)
check_known(info, app_o, rator, rand, NULL, scheme_real_p_proc,
(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL);
@ -4239,6 +4251,11 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
rator = app->rator; /* in case it was updated */
check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true);
check_known_both(info, app_o, rator, rand1, rand2, "bytes-append", scheme_byte_string_p_proc, scheme_true);
check_known(info, app_o, rator, rand1, "string-ref", scheme_string_p_proc, NULL);
check_known(info, app_o, rator, rand1, "bytes-ref", scheme_byte_string_p_proc, NULL);
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)
check_known_both(info, app_o, rator, rand1, rand2, NULL, scheme_real_p_proc,
(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL);
@ -4714,6 +4731,7 @@ static int relevant_predicate(Scheme_Object *pred)
|| SAME_OBJ(pred, scheme_box_p_proc)
|| SAME_OBJ(pred, scheme_list_p_proc)
|| SAME_OBJ(pred, scheme_list_pair_p_proc)
|| SAME_OBJ(pred, scheme_string_p_proc)
|| SAME_OBJ(pred, scheme_byte_string_p_proc)
|| SAME_OBJ(pred, scheme_vector_p_proc)
|| SAME_OBJ(pred, scheme_procedure_p_proc)

4
racket/src/racket/src/schpriv.h
View File

@ -547,8 +547,10 @@ extern Scheme_Object *scheme_unsafe_fxior_proc;
extern Scheme_Object *scheme_unsafe_fxxor_proc;
extern Scheme_Object *scheme_unsafe_fxrshift_proc;
extern Scheme_Object *scheme_string_p_proc;
extern Scheme_Object *scheme_unsafe_string_length_proc;
extern Scheme_Object *scheme_byte_string_p_proc;
extern Scheme_Object *scheme_unsafe_bytes_len_proc;
extern Scheme_Object *scheme_unsafe_byte_string_length_proc;
extern Scheme_Object *scheme_unsafe_real_add1_proc;
extern Scheme_Object *scheme_unsafe_real_sub1_proc;

5
racket/src/racket/src/string.c
View File

@ -392,6 +392,7 @@ SHARED_OK static Scheme_Object *fs_change_props;
READ_ONLY static Scheme_Object *complete_symbol, *continues_symbol, *aborts_symbol, *error_symbol;
READ_ONLY Scheme_Object *scheme_string_p_proc;
READ_ONLY Scheme_Object *scheme_byte_string_p_proc;
void
@ -484,10 +485,12 @@ scheme_init_string (Scheme_Env *env)
banner_str = scheme_make_utf8_string(scheme_banner());
SCHEME_SET_CHAR_STRING_IMMUTABLE(banner_str);
REGISTER_SO(scheme_string_p_proc);
p = scheme_make_folding_prim(string_p, "string?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("string?", p, env);
scheme_string_p_proc = p;
scheme_add_global_constant("make-string",
scheme_make_immed_prim(make_string,
@ -761,7 +764,7 @@ scheme_init_string (Scheme_Env *env)
REGISTER_SO(scheme_byte_string_p_proc);
p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("bytes?", p, env);
scheme_byte_string_p_proc = p;

9
racket/src/racket/src/vector.c
View File

@ -35,7 +35,8 @@ READ_ONLY Scheme_Object *scheme_vector_ref_proc;
READ_ONLY Scheme_Object *scheme_vector_set_proc;
READ_ONLY Scheme_Object *scheme_list_to_vector_proc;
READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_bytes_len_proc;
READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc;
/* locals */
static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
@ -231,11 +232,13 @@ scheme_init_unsafe_vector (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-struct*-set!", p, env);
REGISTER_SO(scheme_unsafe_string_length_proc);
p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-string-length", p, env);
scheme_unsafe_string_length_proc = p;
p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
@ -247,13 +250,13 @@ scheme_init_unsafe_vector (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-string-set!", p, env);
REGISTER_SO(scheme_unsafe_bytes_len_proc);
REGISTER_SO(scheme_unsafe_byte_string_length_proc);
p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-bytes-length", p, env);
scheme_unsafe_bytes_len_proc = p;
scheme_unsafe_byte_string_length_proc = p;
p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED