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

optimizer: add boolean? to the list of relevant predicates

Browse Source 
Previously the relevant predicates where disjoint, and until this commit
the only predicate that recognizes #f was `not`. So it's necessary to fix
two reductions to allow other predicates that recognize #f, like `boolean?`.

Add a hidden `true-object?` primitive that recognizes only #t, that is also
useful to calculate unions and complements with `boolean?` and `not`.

Also, extend a special case for expressions like
    (or (symbol? x) (something))
where the optimizer is confused by the temporal variable that saves the
result of `(symbol? x)`, and the final expression is equivalent to
    (let ([temp (symbol? x)])
      (if temp #t (something)))
This extension detects that the temporal variable is a `boolean?` and
reduces the expression to
    (if (symbol? x) #t (something))
This commit is contained in:
Gustavo Massaccesi 2016-10-25 11:33:38 -03:00
parent 2030c0b0ae
commit f159295e55
11 changed files with 1621 additions and 1396 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.7.0.1")
(define version "6.7.0.2")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -5,7 +5,8 @@
(require racket/flonum
racket/function
(only-in '#%kernel (list-pair? k:list-pair?)))
(only-in '#%kernel (list-pair? k:list-pair?)
(true-object? k:true-object?)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -57,6 +58,15 @@
(test #f not 'nil)
(arity-test not 1 1)
(test #t k:true-object? #t)
(test #f k:true-object? 3)
(test #f k:true-object? (list 3))
(test #f k:true-object? #f)
(test #f k:true-object? '())
(test #f k:true-object? (list))
(test #f k:true-object? 'nil)
(arity-test k:true-object? 1 1)
(test #t boolean? #f)
(test #t boolean? #t)
(test #f boolean? 0)

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

@ -38,7 +38,7 @@
#:first-arg [first-arg #f]
#:second-arg [second-arg #f])
(unless (memq name '(eq? eqv? equal?
not null? pair? list? k:list-pair?
not k:true-object? null? pair? list? k:list-pair?
real? number? boolean?
procedure? symbol? keyword?
string? bytes?
@ -329,6 +329,10 @@
(un #f 'not #t)
(un #f 'not 10)
(un #f 'k:true-object? #f)
(un #t 'k:true-object? #t)
(un #f 'k:true-object? 10)
(bin #t '< 100 200)
(bin #f '< 200 100)
(bin #f '< 100 100)
@ -1144,7 +1148,9 @@
(test-comp `(lambda (x) (if (,e? x (list 0)) (pair? x) 0))
`(lambda (x) (if (,e? x (list 0)) #t 0)))
(test-comp `(lambda (x y) (car y) (if (,e? x y) (pair? x) 0))
`(lambda (x y) (car y) (if (,e? x y) #t 0))))])
`(lambda (x y) (car y) (if (,e? x y) #t 0)))
(test-comp `(lambda (x y) (boolean? (,e? x y)))
`(lambda (x y) (,e? x y) #t)))])
(test-equal? 'eq?)
(test-equal? 'eqv?)
(test-equal? 'equal?))
@ -2042,6 +2048,18 @@
'(lambda (x) (let ([n (if (zero? (random 2)) 1 -1)])
(list n n #f))))
; Test reductions in expressions that are similar to the expansion of `or`
(test-comp '(lambda (z)
(when (boolean? z)
(if z z 0)))
'(lambda (z)
(when (boolean? z)
(if z #t 0))))
(test-comp '(lambda (z)
(let ([r (boolean? z)])
(if r r 0)))
'(lambda (z)
(if (boolean? z) #t 0)))
(test-comp '(lambda (x) (if (let ([r (something)])
(if r r (something-else)))
(a1)
@ -2074,6 +2092,9 @@
(a1)
(a2))))
(test-comp '(lambda (x) (if (pair? x) #t #f))
'(lambda (x) (pair? x)))
(test-comp '(lambda (x) (let ([r (something)])
(if r #t (something-else))))
'(lambda (x) (if (something) #t (something-else))))
@ -2098,6 +2119,7 @@
(test-pred-implies-val 'null? 'null)
(test-pred-implies-val 'void? '(void))
(test-pred-implies-val 'eof-object? 'eof)
(test-pred-implies-val 'k:true-object? '#t)
(test-pred-implies-val 'not '#f))
(test-comp '(lambda (x) (if (null? x) 1 0) null)
'(lambda (x) (if (null? x) 1 0) x)
@ -3028,7 +3050,10 @@
(let ([x ',pred-name])
(let ([y (,pred-name z)])
x)))
`(lambda (z) ',pred-name)))])
`(lambda (z) ',pred-name))
(test-comp `(lambda (z)
(boolean? (,pred-name z)))
`(lambda (z) (,pred-name z) #t)))])
(test-pred 'pair?)
(test-pred 'mpair?)
(test-pred 'list?)
@ -3061,7 +3086,8 @@
(test-pred 'procedure?)
(test-pred 'eof-object?)
(test-pred 'immutable?)
(test-pred 'not))
(test-pred 'not)
(test-pred 'k:true-object?))
(let ([test-implies
(lambda (pred1 pred2 [val '=>])
@ -3102,6 +3128,8 @@
(test-implies 'k:list-pair? 'pair?)
(test-implies 'k:list-pair? 'list?)
(test-implies 'list? 'pair? '?)
(test-implies 'not 'boolean?)
(test-implies 'k:true-object? 'boolean?)
)
(test-comp '(lambda (z)
@ -3136,7 +3164,23 @@
(when (and (list? z)
(not (k:list-pair? z)))
#t)))
(test-comp '(lambda (z)
(when (and (boolean? z)
(not (k:true-object? z)))
(not z)))
'(lambda (z)
(when (and (boolean? z)
(not (k:true-object? z)))
#t)))
(test-comp '(lambda (z)
(when (and (boolean? z)
(not (not z)))
(k:true-object? z)))
'(lambda (z)
(when (and (boolean? z)
(not (not z)))
#t)))
(let ([test-reduce
(lambda (pred-name expr [val #t])
@ -4663,6 +4707,22 @@
(set! f 0))
#f)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test that the `if` is not confused by the
;; predicates that recognize #f.
(test-comp '(lambda (x) (when (boolean? x)
(if x 1 2)))
'(lambda (x) (when (boolean? x)
1))
#f)
(test-comp '(lambda (x) (when (not x)
(if x 1 2)))
'(lambda (x) (when (not x)
1))
#f)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Special case of folding for string=? and bytes=?

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

@ -232,6 +232,7 @@
assq assv assoc
prop:incomplete-arity prop:method-arity-error
list-pair?
true-object?
random)
(all-from "reqprov.rkt")
(all-from-except "for.rkt"

20
racket/src/racket/src/bool.c
View File

@ -35,12 +35,15 @@ READ_ONLY Scheme_Object scheme_true[1];
READ_ONLY Scheme_Object scheme_false[1];
READ_ONLY Scheme_Object *scheme_not_proc;
READ_ONLY Scheme_Object *scheme_true_object_p_proc;
READ_ONLY Scheme_Object *scheme_boolean_p_proc;
READ_ONLY Scheme_Object *scheme_eq_proc;
READ_ONLY Scheme_Object *scheme_eqv_proc;
READ_ONLY Scheme_Object *scheme_equal_proc;
/* locals */
static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *true_object_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
@ -84,6 +87,8 @@ void scheme_init_bool (Scheme_Env *env)
Scheme_Object *p;
REGISTER_SO(scheme_not_proc);
REGISTER_SO(scheme_true_object_p_proc);
REGISTER_SO(scheme_boolean_p_proc);
REGISTER_SO(scheme_eq_proc);
REGISTER_SO(scheme_eqv_proc);
REGISTER_SO(scheme_equal_proc);
@ -94,9 +99,16 @@ void scheme_init_bool (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("not", p, env);
p = scheme_make_folding_prim(true_object_p_prim, "true-object?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_true_object_p_proc = p;
scheme_add_global_constant("true-object?", p, env);
p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_boolean_p_proc = p;
scheme_add_global_constant("boolean?", p, env);
p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
@ -111,7 +123,7 @@ void scheme_init_bool (Scheme_Env *env)
scheme_eqv_proc = p;
scheme_add_global_constant("eqv?", scheme_eqv_proc, env);
p = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
p = scheme_make_noncm_prim(equal_prim, "equal?", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_equal_proc = p;
scheme_add_global_constant("equal?", scheme_equal_proc, env);
@ -147,6 +159,12 @@ not_prim (int argc, Scheme_Object *argv[])
return (SAME_OBJ(argv[0], scheme_false) ? scheme_true : scheme_false);
}
static Scheme_Object *
true_object_p_prim (int argc, Scheme_Object *argv[])
{
return (SAME_OBJ(argv[0], scheme_true) ? scheme_true : scheme_false);
}
static Scheme_Object *
boolean_p_prim (int argc, Scheme_Object *argv[])
{

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

File diff suppressed because it is too large Load Diff

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

@ -1089,6 +1089,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
if (IS_NAMED_PRIM(rator, "not")) {
generate_inlined_constant_test(jitter, app, scheme_false, NULL, for_branch, branch_short, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "true-object?")) {
generate_inlined_constant_test(jitter, app, scheme_true, NULL, for_branch, branch_short, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "null?")) {
generate_inlined_constant_test(jitter, app, scheme_null, NULL, for_branch, branch_short, dest);
return 1;

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

@ -2902,7 +2902,7 @@ int scheme_expr_produces_local_type(Scheme_Object *expr, int *_involves_k_cross)
10, empty_eq_hash_tree));
}
static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, Optimize_Info *info, int argc)
{
if (SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_REAL)
@ -2946,6 +2946,53 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
return scheme_void_p_proc;
else if (SAME_OBJ(rator, scheme_procedure_specialize_proc))
return scheme_procedure_p_proc;
else if (IS_NAMED_PRIM(rator, "pair?")
|| IS_NAMED_PRIM(rator, "mpair?")
|| IS_NAMED_PRIM(rator, "list?")
|| IS_NAMED_PRIM(rator, "list-pair?")
|| IS_NAMED_PRIM(rator, "vector?")
|| IS_NAMED_PRIM(rator, "box?")
|| IS_NAMED_PRIM(rator, "number?")
|| IS_NAMED_PRIM(rator, "real?")
|| IS_NAMED_PRIM(rator, "complex?")
|| IS_NAMED_PRIM(rator, "rational?")
|| IS_NAMED_PRIM(rator, "integer?")
|| IS_NAMED_PRIM(rator, "exact-integer?")
|| IS_NAMED_PRIM(rator, "exact-nonnegative-integer?")
|| IS_NAMED_PRIM(rator, "exact-positive-integer?")
|| IS_NAMED_PRIM(rator, "inexact-real?")
|| IS_NAMED_PRIM(rator, "fixnum?")
|| IS_NAMED_PRIM(rator, "flonum?")
|| IS_NAMED_PRIM(rator, "single-flonum?")
|| IS_NAMED_PRIM(rator, "null?")
|| IS_NAMED_PRIM(rator, "void?")
|| IS_NAMED_PRIM(rator, "symbol?")
|| IS_NAMED_PRIM(rator, "keyword?")
|| IS_NAMED_PRIM(rator, "string?")
|| IS_NAMED_PRIM(rator, "bytes?")
|| IS_NAMED_PRIM(rator, "path?")
|| IS_NAMED_PRIM(rator, "char?")
|| IS_NAMED_PRIM(rator, "boolean?")
|| IS_NAMED_PRIM(rator, "chaperone?")
|| IS_NAMED_PRIM(rator, "impersonator?")
|| IS_NAMED_PRIM(rator, "procedure?")
|| IS_NAMED_PRIM(rator, "eof-object?")
|| IS_NAMED_PRIM(rator, "immutable?")
|| IS_NAMED_PRIM(rator, "not")
|| IS_NAMED_PRIM(rator, "true-object?")
|| IS_NAMED_PRIM(rator, "zero?")
|| IS_NAMED_PRIM(rator, "procedure-arity-includes?")
|| IS_NAMED_PRIM(rator, "variable-reference-constant?")
|| IS_NAMED_PRIM(rator, "eq?")
|| IS_NAMED_PRIM(rator, "eqv?")
|| IS_NAMED_PRIM(rator, "equal?")
|| IS_NAMED_PRIM(rator, "string=?")
|| IS_NAMED_PRIM(rator, "bytes=?")
|| IS_NAMED_PRIM(rator, "free-identifier=?")
|| IS_NAMED_PRIM(rator, "bound-identifier=?")
|| IS_NAMED_PRIM(rator, "procedure-closure-contents-eq?")) {
return scheme_boolean_p_proc;
}
{
Scheme_Object *p;
@ -2955,6 +3002,22 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
}
}
{
Scheme_Object *shape;
shape = get_struct_proc_shape(rator, info, 1);
if (shape) {
if (SAME_TYPE(SCHEME_TYPE(shape), scheme_struct_proc_shape_type)) {
if (((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED)) {
return scheme_boolean_p_proc;
}
} else if (SAME_TYPE(SCHEME_TYPE(shape), scheme_struct_prop_proc_shape_type)) {
if (SCHEME_PROP_PROC_SHAPE_MODE(shape) == STRUCT_PROP_PROC_SHAPE_PRED) {
return scheme_boolean_p_proc;
}
}
}
}
return NULL;
}
@ -3019,7 +3082,7 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
return scheme_list_p_proc;
}
return rator_implies_predicate(app->rator, 1);
return rator_implies_predicate(app->rator, info, 1);
}
break;
case scheme_application3_type:
@ -3074,7 +3137,7 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
return scheme_list_p_proc;
}
return rator_implies_predicate(app->rator, 2);
return rator_implies_predicate(app->rator, info, 2);
}
break;
case scheme_application_type:
@ -3105,7 +3168,7 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
return scheme_list_p_proc;
}
return rator_implies_predicate(app->args[0], app->num_args);
return rator_implies_predicate(app->args[0], info, app->num_args);
}
break;
case scheme_ir_lambda_type:
@ -3204,6 +3267,8 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
if (SCHEME_EOFP(expr))
return scheme_eof_object_p_proc;
if (SAME_OBJ(expr, scheme_true))
return scheme_true_object_p_proc;
if (SCHEME_FALSEP(expr))
return scheme_not_proc;
}
@ -3615,10 +3680,10 @@ static Scheme_Object *finish_optimize_any_application(Scheme_Object *app, Scheme
if ((context & OPT_CONTEXT_BOOLEAN) && !info->escapes) {
Scheme_Object *pred;
pred = rator_implies_predicate(rator, argc);
if (pred && predicate_implies_not(rator, scheme_not_proc))
pred = rator_implies_predicate(rator, info, argc);
if (pred && predicate_implies_not(pred, scheme_not_proc))
return make_discarding_sequence(app, scheme_true, info);
else if (pred && predicate_implies(rator, scheme_not_proc))
else if (pred && predicate_implies(pred, scheme_not_proc))
return make_discarding_sequence(app, scheme_false, info);
}
@ -4983,6 +5048,8 @@ static Scheme_Object *collapse_local(Scheme_Object *var, Optimize_Info *info, in
return scheme_true;
}
if (SAME_OBJ(pred, scheme_true_object_p_proc))
return scheme_true;
if (SAME_OBJ(pred, scheme_null_p_proc))
return scheme_null;
if (SAME_OBJ(pred, scheme_void_p_proc))
@ -5067,7 +5134,7 @@ static void add_type(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pre
}
static void add_type_no(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pred)
/* Currently only check a few special cases for lists. */
/* Currently only check a few special cases for lists and booleans. */
{
Scheme_Object *old_pred;
@ -5087,6 +5154,16 @@ static void add_type_no(Optimize_Info *info, Scheme_Object *var, Scheme_Object *
||SAME_OBJ(pred, scheme_list_pair_p_proc))
add_type(info, var, scheme_null_p_proc);
}
if (old_pred && SAME_OBJ(old_pred, scheme_boolean_p_proc)) {
/* boolean? but not `not` => true-object? */
if (SAME_OBJ(pred, scheme_not_proc))
add_type(info, var, scheme_true_object_p_proc);
/* boolean? but not true-object? => `not` */
if (SAME_OBJ(pred, scheme_true_object_p_proc))
add_type(info, var, scheme_not_proc);
}
}
static void merge_types(Optimize_Info *src_info, Optimize_Info *info, Scheme_Hash_Tree *skip_vars)
@ -5143,6 +5220,13 @@ static void merge_branchs_types(Optimize_Info *t_info, Optimize_Info *f_info,
&& (SAME_OBJ(f_pred, scheme_null_p_proc)))) {
add_type(base_info, var, scheme_list_p_proc);
}
/* special case: true-object? or `not` => boolean? */
if ((SAME_OBJ(t_pred, scheme_not_proc)
&& (SAME_OBJ(f_pred, scheme_true_object_p_proc)))
|| (SAME_OBJ(t_pred, scheme_true_object_p_proc)
&& (SAME_OBJ(f_pred, scheme_not_proc)))) {
add_type(base_info, var, scheme_boolean_p_proc);
}
}
}
i = scheme_hash_tree_next(f_types, i);
@ -5174,6 +5258,8 @@ static int relevant_predicate(Scheme_Object *pred)
|| SAME_OBJ(pred, scheme_real_p_proc)
|| SAME_OBJ(pred, scheme_void_p_proc)
|| SAME_OBJ(pred, scheme_eof_object_p_proc)
|| SAME_OBJ(pred, scheme_boolean_p_proc)
|| SAME_OBJ(pred, scheme_true_object_p_proc)
|| SAME_OBJ(pred, scheme_not_proc)
);
}
@ -5202,6 +5288,12 @@ static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2)
&& SAME_OBJ(pred1, scheme_list_pair_p_proc))
return 1;
/* not, true-object? => boolean? */
if (SAME_OBJ(pred2, scheme_boolean_p_proc)
&& (SAME_OBJ(pred1, scheme_not_proc)
|| SAME_OBJ(pred1, scheme_true_object_p_proc)))
return 1;
/* real?, fixnum?, or flonum? => number? */
if (SAME_OBJ(pred2, scheme_number_p_proc)
&& (SAME_OBJ(pred1, scheme_real_p_proc)
@ -5249,7 +5341,9 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
if (fuel < 0)
return;
if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
if (SAME_TYPE(SCHEME_TYPE(t), scheme_ir_local_type)) {
add_type_no(info, t, scheme_not_proc);
} 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)
@ -5418,18 +5512,25 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
pred = expr_implies_predicate(t2, info);
if (pred) {
Scheme_Object *test_val = SAME_OBJ(pred, scheme_not_proc) ? scheme_false : scheme_true;
Scheme_Object *test_val = NULL;
if (predicate_implies(pred, scheme_not_proc))
test_val = scheme_false;
else if (predicate_implies_not(pred, scheme_not_proc))
test_val = scheme_true;
t2 = optimize_ignored(t2, info, 1, 0, 5);
t = replace_tail_inside(t2, inside, t);
if (test_val) {
t2 = optimize_ignored(t2, info, 1, 0, 5);
t = replace_tail_inside(t2, inside, t);
t2 = test_val;
if (scheme_omittable_expr(t, 1, 5, 0, info, NULL)) {
t = test_val;
inside = NULL;
} else {
t = make_sequence_2(t, test_val);
inside = t;
t2 = test_val;
if (scheme_omittable_expr(t, 1, 5, 0, info, NULL)) {
t = test_val;
inside = NULL;
} else {
t = make_sequence_2(t, test_val);
inside = t;
}
}
}
}
@ -5531,11 +5632,21 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
return make_optimize_prim_application2(scheme_not_proc, t, info, context);
}
/* For test position, convert (if <expr> #t #f) to <expr> */
if ((context & OPT_CONTEXT_BOOLEAN)
&& SAME_OBJ(tb, scheme_true) && SAME_OBJ(fb, scheme_false)) {
/* Convert (if <boolean> #t #f) to <boolean>
and, for test position, convert (if <expr> #t #f) to <expr> */
if (SAME_OBJ(tb, scheme_true) && SAME_OBJ(fb, scheme_false)) {
Scheme_Object *pred;
if (context & OPT_CONTEXT_BOOLEAN)
/* In a boolean context, any expression can be extrated. */
pred = scheme_boolean_p_proc;
else
pred = expr_implies_predicate(t, info);
if (pred && predicate_implies(pred, scheme_boolean_p_proc)) {
info->size -= 2;
return t;
}
}
/* Try optimize: (if <expr> v v) => (begin <expr> v) */
@ -6897,16 +7008,27 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in
int pre_vclock, pre_aclock, pre_kclock, pre_sclock, increments_kclock = 0;
int once_vclock, once_aclock, once_kclock, once_sclock, once_increments_kclock = 0;
if (context & OPT_CONTEXT_BOOLEAN) {
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t N), since we're in a test position. */
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
irlv = (Scheme_IR_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(irlv->body), scheme_branch_type)
&& (irlv->vars[0]->use_count == 2)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)irlv->body;
if (SAME_OBJ(b->test, (Scheme_Object *)irlv->vars[0])
&& SAME_OBJ(b->tbranch, (Scheme_Object *)irlv->vars[0])) {
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t N), when the expression is in a test position
or the result of M is a boolean?. */
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE)
&& (head->count == 1)
&& (head->num_clauses == 1)) {
irlv = (Scheme_IR_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(irlv->body), scheme_branch_type)
&& (irlv->vars[0]->use_count == 2)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)irlv->body;
if (SAME_OBJ(b->test, (Scheme_Object *)irlv->vars[0])
&& SAME_OBJ(b->tbranch, (Scheme_Object *)irlv->vars[0])) {
Scheme_Object *pred;
if (context & OPT_CONTEXT_BOOLEAN)
/* In a boolean context, any expression can be moved. */
pred = scheme_boolean_p_proc;
else
pred = expr_implies_predicate(irlv->value, info);
if (pred && predicate_implies(pred, scheme_boolean_p_proc)) {
Scheme_Branch_Rec *b3;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);

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

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

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

@ -587,6 +587,8 @@ extern Scheme_Object *scheme_lambda_syntax;
extern Scheme_Object *scheme_begin_syntax;
extern Scheme_Object *scheme_not_proc;
extern Scheme_Object *scheme_true_object_p_proc;
extern Scheme_Object *scheme_boolean_p_proc;
extern Scheme_Object *scheme_eq_proc;
extern Scheme_Object *scheme_eqv_proc;
extern Scheme_Object *scheme_equal_proc;

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.7.0.1"
#define MZSCHEME_VERSION "6.7.0.2"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 7
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)