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

optimizer: add hidden list-pair? primitive

Browse Source 
This is useful in the optimizer to track simultaneously the list? and pair?
types of an expression.
This commit is contained in:
Gustavo Massaccesi 2016-03-21 22:41:43 -03:00
parent cff10bc5a8
commit b9b71b20cc
11 changed files with 1294 additions and 1027 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.4.0.14")
(define version "6.4.0.15")
(define deps `("racket-lib"
["racket" #:version ,version]))

10
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -4,7 +4,8 @@
(Section 'basic)
(require racket/flonum
racket/function)
racket/function
(only-in '#%kernel (list-pair? k:list-pair?)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -148,6 +149,13 @@
(test #f pair? '#(a b))
(arity-test pair? 1 1)
(test #f k:list-pair? '(a . b))
(test #f k:list-pair? '(a . 1))
(test #t k:list-pair? '(a b c))
(test #f k:list-pair? '())
(test #f k:list-pair? '#(a b))
(arity-test k:list-pair? 1 1)
(test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c))

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

@ -12,7 +12,8 @@
compiler/zo-marshal
;; `random` from `racket/base is a Racket function, which makes
;; compilation less predictable than a primitive
(only-in '#%kernel random))
(only-in '#%kernel random
(list-pair? k:list-pair?)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -24,6 +25,7 @@
(namespace-require 'racket/fixnum)
(namespace-require 'racket/unsafe/ops)
(namespace-require 'racket/unsafe/undefined)
(namespace-require '(rename '#%kernel k:list-pair? list-pair?))
(eval '(define-values (prop:thing thing? thing-ref)
(make-struct-type-property 'thing)))
(eval '(struct rock (x) #:property prop:thing 'yes))
@ -35,7 +37,7 @@
#:first-arg [first-arg #f]
#:second-arg [second-arg #f])
(unless (memq name '(eq? eqv? equal?
not null? pair? list?
not null? pair? list? k:list-pair?
real? number? boolean?
procedure? symbol? keyword?
string? bytes?
@ -198,6 +200,11 @@
(un #f 'list? '(1 2 . 3))
(un-exact #t 'list? '(1 2 3))
(un-exact 3 'length '(1 2 3))
(un #f 'k:list-pair? 0)
(un #f 'k:list-pair? '())
(un #f 'k:list-pair? '(1 . 2))
(un-exact #t 'k:list-pair? '(1))
(un-exact #t 'k:list-pair? '(1 2))
(un #f 'boolean? 0)
(un #t 'boolean? #t)
(un #t 'boolean? #f)
@ -904,7 +911,7 @@
;; Give `s` a minimal location, so that other macro locations
;; don't bleed through:
(datum->syntax #f s (vector 'here #f #f #f #f)))
(test same? `(compile ,same? ,expr2) (comp=? (compile (->stx expr1)) (compile (->stx expr2)) same?))]))
(test same? `(compile ,same? (,expr1 => ,expr2)) (comp=? (compile (->stx expr1)) (compile (->stx expr2)) same?))]))
(let ([x (compile '(lambda (x) x))])
(test #t 'fixpt (eq? x (compile x))))
@ -2852,6 +2859,7 @@
(test-pred 'pair?)
(test-pred 'mpair?)
(test-pred 'list?)
(test-pred 'k:list-pair?)
(test-pred 'box?)
(test-pred 'number?)
(test-pred 'real?)
@ -2881,6 +2889,146 @@
(test-pred 'immutable?)
(test-pred 'not))
(let ([test-implies
(lambda (pred1 pred2 [val '=>])
(cond
[(eq? val '=>)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #t)))
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #t))
#f)
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #f))
#f)]
[(eq? val '!=)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #f)))
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #f)))]
[(eq? val '?)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #t))
#f)
(test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
`(lambda (z) (when (,pred1 z) #f))
#f)
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #t))
#f)
(test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
`(lambda (z) (when (,pred2 z) #f))
#f)]
[else
(test '= (list pred1 pred2 val) 'bad-option)]))])
(test-implies 'null? 'k:list-pair? '!=)
(test-implies 'null? 'pair? '!=)
(test-implies 'null? 'list?)
(test-implies 'k:list-pair? 'pair?)
(test-implies 'k:list-pair? 'list?)
(test-implies 'list? 'pair? '?)
)
(test-comp '(lambda (z)
(when (and (list? z)
(pair? z))
(k:list-pair? z)))
'(lambda (z)
(when (and (list? z)
(pair? z))
#t)))
(test-comp '(lambda (z)
(when (and (list? z)
(not (null? z)))
(k:list-pair? z)))
'(lambda (z)
(when (and (list? z)
(not (null? z)))
#t)))
(test-comp '(lambda (z)
(when (and (list? z)
(not (pair? z)))
(null? z)))
'(lambda (z)
(when (and (list? z)
(not (pair? z)))
#t)))
(test-comp '(lambda (z)
(when (and (list? z)
(not (k:list-pair? z)))
(null? z)))
'(lambda (z)
(when (and (list? z)
(not (k:list-pair? z)))
#t)))
(let ([test-reduce
(lambda (pred-name expr [val #t])
(test-comp `(list ',pred-name (,pred-name ,expr))
`(list ',pred-name ,val))
(test-comp `(let ([e ,expr])
(list ',pred-name e e (,pred-name e)))
`(let ([e ,expr])
(list ',pred-name e e ,val))))])
(test-reduce 'list? 0 #f)
(test-reduce 'list? ''())
(test-reduce 'list? ''(1))
(test-reduce 'list? ''(1 2))
#;(test-reduce 'list? ''(1 . 2) #f)
(test-reduce 'list? '(list))
(test-reduce 'list? '(list 1))
(test-reduce 'list? '(list 1 2))
#;(test-reduce 'list? '(cons 1 2) #f)
(test-reduce 'list? '(cons 1 null))
(test-reduce 'list? '(cons 1 (list 2 3)))
(test-reduce 'list? '(cdr (list 1 2)))
(test-reduce 'list? '(cdr (list 1)))
(test-reduce 'null? 0 #f)
(test-reduce 'null? ''())
(test-reduce 'null? ''(1) #f)
(test-reduce 'null? ''(1 2) #f)
(test-reduce 'null? ''(1 . 2) #f)
(test-reduce 'null? '(list))
(test-reduce 'null? '(list 1) #f)
(test-reduce 'null? '(list 1 2) #f)
(test-reduce 'null? '(cons 1 2) #f)
(test-reduce 'null? '(cons 1 null) #f)
(test-reduce 'null? '(cons 1 (list 2 3)) #f)
(test-reduce 'null? '(cdr (list 1 2)) #f)
(test-reduce 'null? '(cdr (list 1)))
(test-reduce 'pair? 0 #f)
(test-reduce 'pair? ''() #f)
(test-reduce 'pair? ''(1))
(test-reduce 'pair? ''(1 2))
(test-reduce 'pair? ''(1 . 2))
(test-reduce 'pair? '(list) #f)
(test-reduce 'pair? '(list 1))
(test-reduce 'pair? '(list 1 2))
(test-reduce 'pair? '(cons 1 2))
(test-reduce 'pair? '(cons 1 null))
(test-reduce 'pair? '(cons 1 (list 2 3)))
(test-reduce 'pair? '(cdr (list 1 2)))
(test-reduce 'pair? '(cdr (list 1)) #f)
(test-reduce 'k:list-pair? 0 #f)
(test-reduce 'k:list-pair? ''() #f)
(test-reduce 'k:list-pair? ''(1))
(test-reduce 'k:list-pair? ''(1 2))
#;(test-reduce 'k:list-pair? ''(1 . 2) #f)
(test-reduce 'k:list-pair? '(list) #f)
(test-reduce 'k:list-pair? '(list 1))
(test-reduce 'k:list-pair? '(list 1 2))
#;(test-reduce 'k:list-pair? '(cons 1 2) #f)
(test-reduce 'k:list-pair? '(cons 1 null))
(test-reduce 'k:list-pair? '(cons 1 (list 2 3)))
(test-reduce 'k:list-pair? '(cdr (list 1 2)))
(test-reduce 'k:list-pair? '(cdr (list 1)) #f)
)
(let ([test-bin
(lambda (bin-name)
(test-comp `(lambda (z)
@ -5609,5 +5757,4 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

1
racket/collects/racket/private/pre-base.rkt
View File

@ -231,6 +231,7 @@
chaperone-procedure* impersonate-procedure*
assq assv assoc
prop:incomplete-arity prop:method-arity-error
list-pair?
random)
(all-from "reqprov.rkt")
(all-from-except "for.rkt"

1974
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

18
racket/src/racket/src/jitinline.c
View File

@ -1083,9 +1083,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "odd?")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, 0, CMP_ODDP, 0, for_branch, branch_short, 0, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "list?")) {
} else if (IS_NAMED_PRIM(rator, "list?")
|| IS_NAMED_PRIM(rator, "list-pair?")) {
int for_list_pair = 0;
GC_CAN_IGNORE jit_insn *ref0, *ref1, *ref3, *ref4, *ref6;
if (IS_NAMED_PRIM(rator, "list-pair?"))
for_list_pair = 1;
mz_runstack_skipped(jitter, 1);
scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
@ -1104,6 +1109,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
ref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
/* The difference between list? and list-pair? is only for null. */
ref3 = jit_beqi_i(jit_forward(), JIT_R1, scheme_null_type);
ref4 = jit_bnei_i(jit_forward(), JIT_R1, scheme_pair_type);
CHECK_LIMIT();
@ -1116,11 +1122,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
ref0 = jit_patchable_movi_p(JIT_V1, jit_forward());
(void)jit_calli(sjc.list_p_branch_code);
mz_patch_branch(ref3);
if (!for_list_pair)
mz_patch_branch(ref3);
mz_patch_branch(ref6);
scheme_add_branch_false_movi(for_branch, ref0);
scheme_add_branch_false(for_branch, ref1);
if (for_list_pair)
scheme_add_branch_false(for_branch, ref3);
scheme_add_branch_false(for_branch, ref4);
scheme_branch_for_true(jitter, for_branch);
} else {
@ -1132,10 +1141,13 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_patch_branch(ref1);
mz_patch_branch(ref4);
if (for_list_pair)
mz_patch_branch(ref3);
(void)jit_movi_p(dest, scheme_false);
ref1 = jit_jmpi(jit_forward());
mz_patch_branch(ref3);
if (!for_list_pair)
mz_patch_branch(ref3);
mz_patch_branch(ref6);
(void)jit_movi_p(dest, scheme_true);

24
racket/src/racket/src/list.c
View File

@ -31,11 +31,14 @@ READ_ONLY Scheme_Object scheme_null[1];
READ_ONLY Scheme_Object *scheme_null_p_proc;
READ_ONLY Scheme_Object *scheme_pair_p_proc;
READ_ONLY Scheme_Object *scheme_mpair_p_proc;
READ_ONLY Scheme_Object *scheme_car_proc;
READ_ONLY Scheme_Object *scheme_cdr_proc;
READ_ONLY Scheme_Object *scheme_cons_proc;
READ_ONLY Scheme_Object *scheme_mcons_proc;
READ_ONLY Scheme_Object *scheme_list_p_proc;
READ_ONLY Scheme_Object *scheme_list_proc;
READ_ONLY Scheme_Object *scheme_list_star_proc;
READ_ONLY Scheme_Object *scheme_list_pair_p_proc;
READ_ONLY Scheme_Object *scheme_box_proc;
READ_ONLY Scheme_Object *scheme_box_immutable_proc;
READ_ONLY Scheme_Object *scheme_box_p_proc;
@ -59,6 +62,7 @@ static Scheme_Object *null_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *list_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *list_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *list_star_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *list_pair_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *immutablep (int argc, Scheme_Object *argv[]);
static Scheme_Object *length_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *append_prim (int argc, Scheme_Object *argv[]);
@ -239,11 +243,15 @@ scheme_init_list (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
scheme_add_global_constant ("cons", p, env);
REGISTER_SO(scheme_car_proc);
p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1);
scheme_car_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant ("car", p, env);
REGISTER_SO(scheme_cdr_proc);
p = scheme_make_folding_prim(scheme_checked_cdr, "cdr", 1, 1, 1);
scheme_cdr_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant ("cdr", p, env);
@ -302,6 +310,13 @@ scheme_init_list (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
scheme_add_global_constant ("list*", p, env);
REGISTER_SO(scheme_list_pair_p_proc);
p = scheme_make_folding_prim(list_pair_p_prim, "list-pair?", 1, 1, 1);
scheme_list_pair_p_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant ("list-pair?", p, env);
p = scheme_make_folding_prim(immutablep, "immutable?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("immutable?", p, env);
@ -1420,6 +1435,15 @@ list_star_prim (int argc, Scheme_Object *argv[])
LIST_BODY(STAR_LIST_INIT(), cons);
}
static Scheme_Object *
list_pair_p_prim (int argc, Scheme_Object *argv[])
{
return ((SCHEME_PAIRP(argv[0])
&& scheme_is_list(argv[0]))
? scheme_true
: scheme_false);
}
static Scheme_Object *
immutablep (int argc, Scheme_Object *argv[])
{

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

@ -2567,14 +2567,15 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
return scheme_real_p_proc;
else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_NUMBER)
return scheme_number_p_proc;
else if ((SAME_OBJ(rator, scheme_cons_proc)
|| SAME_OBJ(rator, scheme_unsafe_cons_list_proc)))
else if (SAME_OBJ(rator, scheme_cons_proc))
return scheme_pair_p_proc;
else if (SAME_OBJ(rator, scheme_unsafe_cons_list_proc))
return scheme_list_pair_p_proc;
else if (SAME_OBJ(rator, scheme_mcons_proc))
return scheme_mpair_p_proc;
else if (SAME_OBJ(rator, scheme_list_proc)) {
if (argc >= 1)
return scheme_pair_p_proc;
return scheme_list_pair_p_proc;
else
return scheme_null_p_proc;
} else if (SAME_OBJ(rator, scheme_list_star_proc)) {
@ -2657,7 +2658,15 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
if (p && predicate_implies(p, scheme_real_p_proc))
return scheme_real_p_proc;
}
if (SAME_OBJ(app->rator, scheme_cdr_proc)
|| SAME_OBJ(app->rator, scheme_unsafe_cdr_proc)) {
Scheme_Object *p;
p = do_expr_implies_predicate(app->rand, info, NULL, fuel-1, ignore_vars);
if (SAME_OBJ(p, scheme_list_pair_p_proc))
return scheme_list_p_proc;
}
return rator_implies_predicate(app->rator, 1);
}
break;
@ -2689,6 +2698,15 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
}
}
if (SAME_OBJ(app->rator, scheme_cons_proc)) {
Scheme_Object *p;
p = do_expr_implies_predicate(app->rand2, info, NULL, fuel-1, ignore_vars);
if (SAME_OBJ(p, scheme_list_pair_p_proc)
|| SAME_OBJ(p, scheme_list_p_proc)
|| SAME_OBJ(p, scheme_null_p_proc))
return scheme_list_pair_p_proc;
}
return rator_implies_predicate(app->rator, 2);
}
break;
@ -2772,12 +2790,6 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
return do_expr_implies_predicate(seq->array[0], info, _involves_k_cross, fuel-1, ignore_vars);
}
case scheme_pair_type:
return scheme_pair_p_proc;
break;
case scheme_mutable_pair_type:
return scheme_mpair_p_proc;
break;
case scheme_vector_type:
return scheme_vector_p_proc;
break;
@ -2799,6 +2811,8 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
if (SCHEME_NULLP(expr))
return scheme_null_p_proc;
if (scheme_is_list(expr))
return scheme_list_pair_p_proc;
if (SCHEME_PAIRP(expr))
return scheme_pair_p_proc;
if (SCHEME_MPAIRP(expr))
@ -3121,10 +3135,8 @@ static int check_known_variant(Optimize_Info *info, Scheme_Object *app,
info->escapes = 1;
}
} else {
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type)) {
if (!SCHEME_VAR(rand)->mutated)
add_type(info, rand, implies_pred);
}
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type))
add_type(info, rand, implies_pred);
}
}
@ -3149,10 +3161,8 @@ static void check_known_rator(Optimize_Info *info, Scheme_Object *rator)
if (predicate_implies_not(pred, scheme_procedure_p_proc))
info->escapes = 1;
} else {
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type)) {
if (!SCHEME_VAR(rator)->mutated)
add_type(info, rator, scheme_procedure_p_proc);
}
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type))
add_type(info, rator, scheme_procedure_p_proc);
}
}
@ -4501,6 +4511,8 @@ static Scheme_Object *equivalent_exprs(Scheme_Object *a, Scheme_Object *b,
}
static void add_type(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pred)
/* This is conceptually an intersection, but `Any` is represented by a
missing entry, so the implementation looks like an union. */
{
Scheme_Hash_Tree *new_types = info->types;
Scheme_Object *old_pred;
@ -4516,12 +4528,46 @@ static void add_type(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pre
if (old_pred && predicate_implies(old_pred, pred))
return;
/* special case: list? and pair? => list-pair? */
if (old_pred) {
if ((SAME_OBJ(old_pred, scheme_list_p_proc)
&& (SAME_OBJ(pred, scheme_pair_p_proc)))
|| (SAME_OBJ(old_pred, scheme_pair_p_proc)
&& (SAME_OBJ(pred, scheme_list_p_proc)))) {
pred = scheme_list_pair_p_proc;
}
}
if (!new_types)
new_types = scheme_make_hash_tree(0);
new_types = scheme_hash_tree_set(new_types, var, pred);
info->types = new_types;
}
static void add_type_no(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pred)
/* Currently only check a few special cases for lists. */
{
Scheme_Hash_Tree *new_types = info->types;
Scheme_Object *old_pred;
if (SCHEME_VAR(var)->mutated)
return;
old_pred = optimize_get_predicate(info, var, 1);
if (old_pred && SAME_OBJ(old_pred, scheme_list_p_proc)) {
/* list? but not null? => list-pair? */
if (SAME_OBJ(pred, scheme_null_p_proc))
add_type(info, var, scheme_list_pair_p_proc);
/* list? but not pair? => null? */
/* list? but not list-pair? => null? */
if (SAME_OBJ(pred, scheme_pair_p_proc)
||SAME_OBJ(pred, scheme_list_pair_p_proc))
add_type(info, var, scheme_null_p_proc);
}
}
static void merge_types(Optimize_Info *src_info, Optimize_Info *info, Scheme_Hash_Tree *skip_vars)
{
Scheme_Hash_Tree *types = src_info->types;
@ -4540,9 +4586,11 @@ static void merge_types(Optimize_Info *src_info, Optimize_Info *info, Scheme_Has
}
}
static void intersect_and_merge_types(Optimize_Info *t_info, Optimize_Info *f_info,
static void merge_branchs_types(Optimize_Info *t_info, Optimize_Info *f_info,
Optimize_Info *base_info)
/* Add to base_info the intersection of the types of t_info and f_info */
/* This is conceptually an union, but `Any` is represented by a
missing entry, so the implementation looks like an intersection.
This adds to base_info the "intersection" of the types of t_info and f_info */
{
Scheme_Hash_Tree *t_types = t_info->types, *f_types = f_info->types;
Scheme_Object *var, *t_pred, *f_pred;
@ -4566,6 +4614,15 @@ static void intersect_and_merge_types(Optimize_Info *t_info, Optimize_Info *f_in
add_type(base_info, var, t_pred);
else if (predicate_implies(t_pred, f_pred))
add_type(base_info, var, f_pred);
else {
/* special case: null? or list-pair? => list? */
if ((SAME_OBJ(t_pred, scheme_null_p_proc)
&& (SAME_OBJ(f_pred, scheme_list_pair_p_proc)))
|| (SAME_OBJ(t_pred, scheme_list_pair_p_proc)
&& (SAME_OBJ(f_pred, scheme_null_p_proc)))) {
add_type(base_info, var, scheme_list_p_proc);
}
}
}
i = scheme_hash_tree_next(f_types, i);
}
@ -4583,6 +4640,7 @@ static int relevant_predicate(Scheme_Object *pred)
|| SAME_OBJ(pred, scheme_mpair_p_proc)
|| 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_vector_p_proc)
|| SAME_OBJ(pred, scheme_procedure_p_proc)
|| SAME_OBJ(pred, scheme_syntax_p_proc)
@ -4608,6 +4666,16 @@ static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2)
&& SAME_OBJ(pred1, scheme_null_p_proc))
return 1;
/* list-pair? => list? */
if (SAME_OBJ(pred2, scheme_list_p_proc)
&& SAME_OBJ(pred1, scheme_list_pair_p_proc))
return 1;
/* list-pair? => pair? */
if (SAME_OBJ(pred2, scheme_pair_p_proc)
&& SAME_OBJ(pred1, scheme_list_pair_p_proc))
return 1;
/* real?, fixnum?, or flonum? => number? */
if (SAME_OBJ(pred2, scheme_number_p_proc)
&& (SAME_OBJ(pred1, scheme_real_p_proc)
@ -4645,7 +4713,6 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
if (SCHEME_PRIMP(app->rator)
&& SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)
&& !SCHEME_VAR(app->rand)->mutated
&& relevant_predicate(app->rator)) {
/* Looks like a predicate on a local variable. Record that the
predicate succeeded, which may allow conversion of safe
@ -4660,8 +4727,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
Scheme_App3_Rec *app = (Scheme_App3_Rec *)t;
Scheme_Object *pred1, *pred2;
if (SAME_OBJ(app->rator, scheme_eq_proc)) {
if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type)
&& !SCHEME_VAR(app->rand1)->mutated) {
if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type)) {
pred1 = expr_implies_predicate(app->rand1, info);
if (!pred1) {
pred2 = expr_implies_predicate(app->rand2, info);
@ -4669,8 +4735,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
add_type(info, app->rand1, pred2);
}
}
if (SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_ir_local_type)
&& !SCHEME_VAR(app->rand2)->mutated) {
if (SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_ir_local_type)) {
pred2 = expr_implies_predicate(app->rand2, info);
if (!pred2) {
pred1 = expr_implies_predicate(app->rand1, info);
@ -4700,8 +4765,15 @@ static void add_types_for_f_branch(Scheme_Object *t, Optimize_Info *info, int fu
if (SAME_TYPE(SCHEME_TYPE(t), scheme_ir_local_type)) {
add_type(info, t, scheme_not_proc);
if (SAME_OBJ(app->rator, scheme_not_proc)) {
add_types_for_t_branch(app->rand, info, fuel-1);
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
if (SCHEME_PRIMP(app->rator)
&& SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)
&& relevant_predicate(app->rator)) {
/* Looks like a predicate on a local variable. Record that the
predicate failed, this is currently useful only for lists. */
add_type_no(info, app->rand, app->rator);
}
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) {
@ -4885,7 +4957,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
info->single_result = new_single_result;
if (then_info->kclock > info->kclock)
info->kclock = then_info->kclock;
intersect_and_merge_types(then_info, else_info, info);
merge_branchs_types(then_info, else_info, info);
}
if (then_info->sclock > info->sclock)

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1145
#define EXPECTED_PRIM_COUNT 1146
#define EXPECTED_UNSAFE_COUNT 126
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

@ -509,11 +509,14 @@ extern Scheme_Object *scheme_unsafe_cdr_proc;
extern Scheme_Object *scheme_unsafe_mcar_proc;
extern Scheme_Object *scheme_unsafe_mcdr_proc;
extern Scheme_Object *scheme_unsafe_unbox_proc;
extern Scheme_Object *scheme_car_proc;
extern Scheme_Object *scheme_cdr_proc;
extern Scheme_Object *scheme_cons_proc;
extern Scheme_Object *scheme_mcons_proc;
extern Scheme_Object *scheme_list_p_proc;
extern Scheme_Object *scheme_list_proc;
extern Scheme_Object *scheme_list_star_proc;
extern Scheme_Object *scheme_list_pair_p_proc;
extern Scheme_Object *scheme_vector_proc;
extern Scheme_Object *scheme_vector_p_proc;
extern Scheme_Object *scheme_make_vector_proc;

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.4.0.14"
#define MZSCHEME_VERSION "6.4.0.15"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 14
#define MZSCHEME_VERSION_W 15
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)