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

optimizer: connect struct predicates and accessors

Browse Source 
for example, make the optimizer convert something like

 (struct a (x))
 (lambda (v) (if (a? v) (a-x v) #f))

to

 (struct a (x))
 (lambda (v) (if (a? v) (unsafe-struct-ref v 0) #f))
This commit is contained in:
Matthew Flatt 2016-07-13 08:54:03 -06:00
parent 591fcb6228
commit 95f6a2342b
12 changed files with 295 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4026,6 +4026,71 @@
(list (c? (c-q (c 1 2 3)))) (list (c? (c-q (c 1 2 3))))
5))) 5)))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(if (a? v)
(list (a-x v) (a-y v))
(void))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(if (a? v)
(list (unsafe-struct-ref v 0)
(unsafe-struct-ref v 1))
(void)))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(list (a-x v) (a-y v))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(list (a-x v)
(unsafe-struct-ref v 1)))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(list (a-x v) (a? v))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(define (f v)
(list (a-x v) #t))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(struct b a (z))
(define (f v)
(and (b? v) (b-z v))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(struct b a (z))
(define (f v)
(and (b? v) (unsafe-struct-ref v 2)))))
(test-comp '(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(struct b a (z))
(define (f v)
(list (b-z v) (a? v))))
'(module m racket/base
(require racket/unsafe/ops)
(struct a (x y))
(struct b a (z))
(define (f v)
(list (b-z v) #t))))
(test-comp `(lambda (b) (test-comp `(lambda (b)
(let ([v (unbox b)]) (let ([v (unbox b)])
(with-continuation-mark 'x 'y (unbox v)))) (with-continuation-mark 'x 'y (unbox v))))

4
racket/src/racket/src/eval.c
View File

@ -2033,9 +2033,9 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
is_st = 0; is_st = 0;
else else
is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 0, 1, is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 0, 1,
NULL, NULL, NULL, NULL, NULL,
NULL, NULL, MZ_RUNSTACK, 0, NULL, NULL, MZ_RUNSTACK, 0,
NULL, NULL, 5); NULL, NULL, NULL, 5);
for (i = 0; i < g; i++) { for (i = 0; i < g; i++) {
var = SCHEME_VEC_ELS(vec)[i+delta]; var = SCHEME_VEC_ELS(vec)[i+delta];

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

@ -4558,8 +4558,10 @@ static void setup_accessible_table(Scheme_Module *m)
for (i = 0; i < cnt; i++) { for (i = 0; i < cnt; i++) {
form = SCHEME_VEC_ELS(m->bodies[0])[i]; form = SCHEME_VEC_ELS(m->bodies[0])[i];
if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) {
int checked_st = 0, is_st = 0; int checked_st = 0;
Scheme_Object *is_st = NULL;
Simple_Stuct_Type_Info stinfo; Simple_Stuct_Type_Info stinfo;
Scheme_Object *parent_identity;
for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) {
tl = SCHEME_VEC_ELS(form)[k]; tl = SCHEME_VEC_ELS(form)[k];
if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) {
@ -4593,19 +4595,25 @@ static void setup_accessible_table(Scheme_Module *m)
} }
} else { } else {
if (!checked_st) { if (!checked_st) {
is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
SCHEME_VEC_SIZE(form)-1, SCHEME_VEC_SIZE(form)-1,
1, 0, 1, NULL, &stinfo, 1, 0, 1, NULL, &stinfo, &parent_identity,
NULL, NULL, NULL, 0, NULL, NULL, NULL, 0,
m->prefix->toplevels, ht, m->prefix->toplevels, ht,
5); &is_st,
5)) {
is_st = scheme_make_pair(is_st, parent_identity);
} else
is_st = NULL;
checked_st = 1; checked_st = 1;
} }
if (is_st) { if (is_st) {
intptr_t shape; intptr_t shape;
shape = scheme_get_struct_proc_shape(k-1, &stinfo); shape = scheme_get_struct_proc_shape(k-1, &stinfo);
/* Vector of size 3 => struct procedure */
v = scheme_make_vector(3, v); v = scheme_make_vector(3, v);
SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
SCHEME_VEC_ELS(v)[2] = is_st;
} }
} }
scheme_hash_set(ht, tl, v); scheme_hash_set(ht, tl, v);
@ -4836,10 +4844,12 @@ static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t
if (_is_constant) if (_is_constant)
get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant); get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant);
} else { } else {
/* vector of size 3 => struct proc */
if (_is_constant) { if (_is_constant) {
Scheme_Object *ps; Scheme_Object *ps;
ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1])); ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]),
SCHEME_VEC_ELS(pos)[2]);
*_is_constant = ps; *_is_constant = ps;
} }

38
racket/src/racket/src/mzmark_type.inc
View File

@ -4408,3 +4408,41 @@ static int mark_log_reader_FIXUP(void *p, struct NewGC *gc) {
#define mark_log_reader_IS_CONST_SIZE 1 #define mark_log_reader_IS_CONST_SIZE 1
static int struct_proc_shape_SIZE(void *p, struct NewGC *gc) {
#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS
gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Proc_Shape));
#else
return 0;
#endif
}
static int struct_proc_shape_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Scheme_Struct_Proc_Shape *s = (Scheme_Struct_Proc_Shape *)p;
gcMARK2(s->identity, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else
return
gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Proc_Shape));
# endif
#endif
}
static int struct_proc_shape_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Scheme_Struct_Proc_Shape *s = (Scheme_Struct_Proc_Shape *)p;
gcFIXUP2(s->identity, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else
return
gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Proc_Shape));
# endif
#endif
}
#define struct_proc_shape_IS_ATOMIC 0
#define struct_proc_shape_IS_CONST_SIZE 1

8
racket/src/racket/src/mzmarksrc.c
View File

@ -1265,6 +1265,14 @@ mark_log_reader {
gcBYTES_TO_WORDS(sizeof(Scheme_Log_Reader)); gcBYTES_TO_WORDS(sizeof(Scheme_Log_Reader));
} }
struct_proc_shape {
mark:
Scheme_Struct_Proc_Shape *s = (Scheme_Struct_Proc_Shape *)p;
gcMARK2(s->identity, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Proc_Shape));
}
END type; END type;
/**********************************************************************/ /**********************************************************************/

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

@ -624,9 +624,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
Scheme_Object *auto_e; Scheme_Object *auto_e;
int auto_e_depth; int auto_e_depth;
auto_e = scheme_is_simple_make_struct_type(o, vals, flags, 1, 0, &auto_e_depth, auto_e = scheme_is_simple_make_struct_type(o, vals, flags, 1, 0, &auto_e_depth,
NULL, NULL, NULL,
(opt_info ? opt_info->top_level_consts : NULL), (opt_info ? opt_info->top_level_consts : NULL),
NULL, NULL, 0, NULL, NULL, NULL, NULL, 0, NULL, NULL, NULL,
5); 5);
if (auto_e) { if (auto_e) {
if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info)) if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info))
@ -1059,10 +1059,19 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int
delta2, _stinfo->field_count, vars)) delta2, _stinfo->field_count, vars))
break; break;
if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) { if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) {
if (num_gets) normal_ops = 0; if (num_gets) {
/* Since we're alking backwards, it's not normal to hit a mutator
after (i.e., before in argument order) a selector */
normal_ops = 0;
}
num_sets++; num_sets++;
} else } else {
if (SCHEME_INT_VAL(app3->args[2]) != (i - 4)) {
/* selectors are not in the usual order */
normal_ops = 0;
}
num_gets++; num_gets++;
}
} else } else
break; break;
} else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type) } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)
@ -1075,8 +1084,10 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int
if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) {
if (num_gets) normal_ops = 0; if (num_gets) normal_ops = 0;
num_sets++; num_sets++;
} else } else {
if (SCHEME_INT_VAL(app3->rand2) != (i - 4)) normal_ops = 0;
num_gets++; num_gets++;
}
} else } else
break; break;
} }
@ -1114,7 +1125,8 @@ static int is_constant_super(Scheme_Object *arg,
Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *top_level_table, Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta, Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_parent_identity)
/* Does `arg` produce another structure type (which can serve as a supertype)? */ /* Does `arg` produce another structure type (which can serve as a supertype)? */
{ {
int pos; int pos;
@ -1128,8 +1140,11 @@ static int is_constant_super(Scheme_Object *arg,
if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) {
int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK);
int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT);
if (mode == STRUCT_PROC_SHAPE_STRUCT) if (mode == STRUCT_PROC_SHAPE_STRUCT) {
if (_parent_identity)
*_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v);
return field_count + 1; return field_count + 1;
}
} }
} }
} else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) { } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) {
@ -1158,6 +1173,8 @@ static int is_constant_super(Scheme_Object *arg,
if (SCHEME_SYMBOLP(name)) { if (SCHEME_SYMBOLP(name)) {
v = scheme_hash_get(symbol_table, name); v = scheme_hash_get(symbol_table, name);
if (v && SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { if (v && SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) {
if (_parent_identity)
*_parent_identity = SCHEME_VEC_ELS(v)[2];
v = SCHEME_VEC_ELS(v)[1]; v = SCHEME_VEC_ELS(v)[1];
if (v && SCHEME_INTP(v)) { if (v && SCHEME_INTP(v)) {
int mode = (SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_MASK); int mode = (SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_MASK);
@ -1193,10 +1210,12 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
int must_always_succeed, int check_auto, int must_always_succeed, int check_auto,
GC_CAN_IGNORE int *_auto_e_depth, GC_CAN_IGNORE int *_auto_e_depth,
Simple_Stuct_Type_Info *_stinfo, Simple_Stuct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *top_level_table, Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta, Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_name,
int fuel) int fuel)
/* Checks whether it's a `make-struct-type' call --- that, if `must_always_succeed` is /* Checks whether it's a `make-struct-type' call --- that, if `must_always_succeed` is
true, certainly succeeds (i.e., no exception) --- pending a check of the auto-value true, certainly succeeds (i.e., no exception) --- pending a check of the auto-value
@ -1215,11 +1234,13 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
&& SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) {
int super_count_plus_one; int super_count_plus_one;
if (_parent_identity)
*_parent_identity = scheme_null;
if (!SCHEME_FALSEP(app->args[2])) if (!SCHEME_FALSEP(app->args[2]))
super_count_plus_one = is_constant_super(app->args[2], super_count_plus_one = is_constant_super(app->args[2],
top_level_consts, top_level_table, runstack, top_level_consts, top_level_table, runstack,
rs_delta + app->num_args, rs_delta + app->num_args,
symbols, symbol_table); symbols, symbol_table, _parent_identity);
else else
super_count_plus_one = 0; super_count_plus_one = 0;
@ -1268,6 +1289,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
|| SCHEME_SYMBOLP(app->args[11]))) { || SCHEME_SYMBOLP(app->args[11]))) {
if (_auto_e_depth) if (_auto_e_depth)
*_auto_e_depth = (resolved ? app->num_args : 0); *_auto_e_depth = (resolved ? app->num_args : 0);
if (_name)
*_name = app->args[1];
if (_stinfo) { if (_stinfo) {
int super_count = (super_count_plus_one int super_count = (super_count_plus_one
? (super_count_plus_one - 1) ? (super_count_plus_one - 1)
@ -1277,6 +1300,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
+ SCHEME_INT_VAL(app->args[4]) + SCHEME_INT_VAL(app->args[4])
+ super_count); + super_count);
_stinfo->uses_super = (super_count_plus_one ? 1 : 0); _stinfo->uses_super = (super_count_plus_one ? 1 : 0);
_stinfo->super_field_count = (super_count_plus_one ? (super_count_plus_one - 1) : 0);
_stinfo->normal_ops = 1; _stinfo->normal_ops = 1;
_stinfo->indexed_ops = 0; _stinfo->indexed_ops = 0;
_stinfo->num_gets = 1; _stinfo->num_gets = 1;
@ -1301,10 +1325,11 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
if (!_stinfo) _stinfo = &stinfo; if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved,
must_always_succeed, check_auto, must_always_succeed, check_auto,
_auto_e_depth, _stinfo, _auto_e_depth, _stinfo, _parent_identity,
top_level_consts, top_level_table, top_level_consts, top_level_table,
runstack, rs_delta, runstack, rs_delta,
symbols, symbol_table, symbols, symbol_table,
_name,
fuel-1); fuel-1);
if (auto_e) { if (auto_e) {
/* We have (let-values ([... (make-struct-type)]) ....), so make sure body /* We have (let-values ([... (make-struct-type)]) ....), so make sure body
@ -1333,10 +1358,11 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
if (!_stinfo) _stinfo = &stinfo; if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved,
must_always_succeed, check_auto, must_always_succeed, check_auto,
_auto_e_depth, _stinfo, _auto_e_depth, _stinfo, _parent_identity,
top_level_consts, top_level_table, top_level_consts, top_level_table,
runstack, rs_delta + lvd->count, runstack, rs_delta + lvd->count,
symbols, symbol_table, symbols, symbol_table,
_name,
fuel-1); fuel-1);
if (auto_e) { if (auto_e) {
/* We have (let-values ([... (make-struct-type)]) ....), so make sure body /* We have (let-values ([... (make-struct-type)]) ....), so make sure body
@ -1376,27 +1402,44 @@ intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo)
break; break;
default: default:
if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) { if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) {
if (k - 3 < stinfo->num_gets) if (k - 3 < stinfo->num_gets) {
return STRUCT_PROC_SHAPE_GETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); /* record index of field */
else return (STRUCT_PROC_SHAPE_GETTER
return STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); | ((stinfo->super_field_count + (k - 3)) << STRUCT_PROC_SHAPE_SHIFT));
} else
return (STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT));
} }
} }
return STRUCT_PROC_SHAPE_OTHER; return STRUCT_PROC_SHAPE_OTHER;
} }
Scheme_Object *scheme_make_struct_proc_shape(intptr_t k) Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity)
{ {
Scheme_Object *ps; Scheme_Object *ps;
ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object)); ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Simple_Object));
ps->type = scheme_struct_proc_shape_type; ps->type = scheme_struct_proc_shape_type;
SCHEME_PROC_SHAPE_MODE(ps) = k; SCHEME_PROC_SHAPE_MODE(ps) = k;
SCHEME_PROC_SHAPE_IDENTITY(ps) = identity;
return ps; return ps;
} }
XFORM_NONGCING static int is_struct_identity_subtype(Scheme_Object *sub, Scheme_Object *sup)
{
/* A structure identity is a list of symbols, but the symbols are
just for debugging. Instead, the address of each pair forming the
list represents an identiity. */
while (SCHEME_PAIRP(sub)) {
if (SAME_OBJ(sub, sup))
return 1;
sub = SCHEME_CDR(sub);
}
return 0;
}
static int single_valued_expression(Scheme_Object *expr, int fuel, int non_cm) static int single_valued_expression(Scheme_Object *expr, int fuel, int non_cm)
/* Not necessarily omittable or copyable, but single-valued expressions. /* Not necessarily omittable or copyable, but single-valued expressions.
If `non_cm`, the expression must not be sensitive If `non_cm`, the expression must not be sensitive
@ -3819,6 +3862,47 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
} }
} }
/* Using a struct getter or predicate? */
alt = get_struct_proc_shape(rator, info);
if (alt) {
int mode = (SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_MASK);
if ((mode == STRUCT_PROC_SHAPE_PRED)
|| (mode == STRUCT_PROC_SHAPE_GETTER)) {
Scheme_Object *pred;
pred = expr_implies_predicate(rand, info);
if (pred
&& SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type)
&& is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred),
SCHEME_PROC_SHAPE_IDENTITY(alt))) {
if (mode == STRUCT_PROC_SHAPE_PRED) {
/* We know that the predicate will succeed */
return replace_tail_inside(make_discarding_sequence(rand, scheme_true, info),
inside,
app->rand);
} else {
/* Struct type matches, so use `unsafe-struct-ref` */
Scheme_App3_Rec *new;
new = (Scheme_App3_Rec *)make_application_3(scheme_unsafe_struct_ref_proc,
app->rand,
scheme_make_integer(SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT),
info);
SCHEME_APPN_FLAGS(new) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL);
scheme_check_leaf_rator(scheme_unsafe_struct_ref_proc, &rator_flags);
return finish_optimize_application3(new, info, context, rator_flags);
}
}
/* Register type based on getter succeeding: */
if ((mode == STRUCT_PROC_SHAPE_GETTER)
&& SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(alt))
&& SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type))
add_type(info, rand, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED,
SCHEME_PROC_SHAPE_IDENTITY(alt)));
}
}
register_local_argument_types(NULL, app, NULL, info); register_local_argument_types(NULL, app, NULL, info);
flags = appn_flags(rator, info); flags = appn_flags(rator, info);
@ -4733,6 +4817,9 @@ static int relevant_predicate(Scheme_Object *pred)
static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2) static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2)
{ {
if (!pred1 || !pred2)
return 0;
/* P => P */ /* P => P */
if (SAME_OBJ(pred1, pred2)) if (SAME_OBJ(pred1, pred2))
return 1; return 1;
@ -4765,6 +4852,13 @@ static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2)
|| SAME_OBJ(pred1, scheme_flonum_p_proc))) || SAME_OBJ(pred1, scheme_flonum_p_proc)))
return 1; return 1;
/* structure subtype? */
if (SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type)
&& SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type)
&& is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred1),
SCHEME_PROC_SHAPE_IDENTITY(pred2)))
return 1;
return 0; return 0;
} }
@ -4774,6 +4868,13 @@ static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2)
return 0; return 0;
if (SAME_OBJ(pred1, scheme_list_p_proc) && SAME_OBJ(pred2, scheme_pair_p_proc)) if (SAME_OBJ(pred1, scheme_list_p_proc) && SAME_OBJ(pred2, scheme_pair_p_proc))
return 0; return 0;
/* we don't track structure-type identity precisely enough to know
that structures don't rule out other structures --- or even other
prdicates (such as `procedure?`) */
if (SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type)
|| SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type))
return 0;
/* Otherwise, with our current set of predicates, overlapping matches happen /* Otherwise, with our current set of predicates, overlapping matches happen
only when one implies the other: */ only when one implies the other: */
@ -4799,6 +4900,15 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
add_types_for_f_branch(app->rand, info, fuel-1); add_types_for_f_branch(app->rand, info, fuel-1);
} }
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)) {
Scheme_Object *shape;
shape = get_struct_proc_shape(app->rator, info);
if (shape
&& ((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED)
&& SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(shape))) {
add_type(info, app->rand, shape);
}
}
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_application3_type)) { } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)t; Scheme_App3_Rec *app = (Scheme_App3_Rec *)t;
Scheme_Object *pred1, *pred2; Scheme_Object *pred1, *pred2;
@ -7869,7 +7979,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
(including raising an exception), then continue the group of (including raising an exception), then continue the group of
simultaneous definitions: */ simultaneous definitions: */
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
int n, cnst = 0, sproc = 0, sstruct = 0; int n, cnst = 0, sproc = 0;
Scheme_Object *sstruct = NULL, *parent_identity = NULL;
Simple_Stuct_Type_Info stinfo; Simple_Stuct_Type_Info stinfo;
vars = SCHEME_VEC_ELS(e)[0]; vars = SCHEME_VEC_ELS(e)[0];
@ -7896,13 +8007,15 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
sproc = 1; sproc = 1;
} }
} else if (scheme_is_simple_make_struct_type(e, n, 0, 0, 1, NULL, } else if (scheme_is_simple_make_struct_type(e, n, 0, 0, 1, NULL,
&stinfo, &stinfo, &parent_identity,
info->top_level_consts, info->top_level_consts,
NULL, NULL, 0, NULL, NULL, NULL, NULL, 0, NULL, NULL,
&sstruct,
5)) { 5)) {
sstruct = 1; sstruct = scheme_make_pair(sstruct, parent_identity);
cnst = 1; cnst = 1;
} } else
sstruct = NULL;
if (cnst) { if (cnst) {
Scheme_Toplevel *tl; Scheme_Toplevel *tl;
@ -7915,7 +8028,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
Scheme_Object *e2; Scheme_Object *e2;
if (sstruct) { if (sstruct) {
e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo)); e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo),
sstruct);
} else if (sproc) { } else if (sproc) {
e2 = scheme_make_noninline_proc(e); e2 = scheme_make_noninline_proc(e);
} else if (SCHEME_LAMBDAP(e)) { } else if (SCHEME_LAMBDAP(e)) {

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

@ -527,6 +527,7 @@ extern Scheme_Object *scheme_vector_ref_proc;
extern Scheme_Object *scheme_vector_set_proc; extern Scheme_Object *scheme_vector_set_proc;
extern Scheme_Object *scheme_list_to_vector_proc; extern Scheme_Object *scheme_list_to_vector_proc;
extern Scheme_Object *scheme_unsafe_vector_length_proc; extern Scheme_Object *scheme_unsafe_vector_length_proc;
extern Scheme_Object *scheme_unsafe_struct_ref_proc;
extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_hash_ref_proc;
extern Scheme_Object *scheme_box_p_proc; extern Scheme_Object *scheme_box_p_proc;
extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_box_proc;
@ -3485,23 +3486,29 @@ int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args
typedef struct { typedef struct {
int uses_super; int uses_super;
int field_count, init_field_count; int super_field_count; /* total fields (must == constructor-supplied fields) in superstruct */
int normal_ops, indexed_ops, num_gets, num_sets; int field_count; /* total fields in this struct */
int init_field_count; /* number of fields supplied to the constructor; usually == field_count */
int normal_ops; /* are selectors and predicates in the usual order? */
int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */
int num_gets, num_sets;
} Simple_Stuct_Type_Info; } Simple_Stuct_Type_Info;
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved,
int must_always_succeed, int must_always_succeed,
int check_auto, int *_auto_e_depth, int check_auto, int *_auto_e_depth,
Simple_Stuct_Type_Info *_stinfo, Simple_Stuct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *top_level_table, Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta, Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_name,
int fuel); int fuel);
Scheme_Object *scheme_intern_struct_proc_shape(int shape); Scheme_Object *scheme_intern_struct_proc_shape(int shape);
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo); intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo);
Scheme_Object *scheme_make_struct_proc_shape(intptr_t k); Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity);
#define STRUCT_PROC_SHAPE_STRUCT 0 #define STRUCT_PROC_SHAPE_STRUCT 0
#define STRUCT_PROC_SHAPE_CONSTR 1 #define STRUCT_PROC_SHAPE_CONSTR 1
#define STRUCT_PROC_SHAPE_PRED 2 #define STRUCT_PROC_SHAPE_PRED 2
@ -3510,7 +3517,14 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k);
#define STRUCT_PROC_SHAPE_OTHER 5 #define STRUCT_PROC_SHAPE_OTHER 5
#define STRUCT_PROC_SHAPE_MASK 0xF #define STRUCT_PROC_SHAPE_MASK 0xF
#define STRUCT_PROC_SHAPE_SHIFT 4 #define STRUCT_PROC_SHAPE_SHIFT 4
#define SCHEME_PROC_SHAPE_MODE(obj) (((Scheme_Small_Object *)(obj))->u.int_val)
typedef struct Scheme_Struct_Proc_Shape {
Scheme_Object so;
intptr_t mode;
Scheme_Object *identity; /* sequence of pairs that identity the struct type */
} Scheme_Struct_Proc_Shape;
#define SCHEME_PROC_SHAPE_MODE(obj) ((Scheme_Struct_Proc_Shape *)obj)->mode
#define SCHEME_PROC_SHAPE_IDENTITY(obj) ((Scheme_Struct_Proc_Shape *)obj)->identity
Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected); Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected);

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.6.0.1" #define MZSCHEME_VERSION "6.6.0.2"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 6 #define MZSCHEME_VERSION_Y 6
#define MZSCHEME_VERSION_Z 0 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -3596,11 +3596,12 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected)
return (v == STRUCT_PROC_SHAPE_PRED); return (v == STRUCT_PROC_SHAPE_PRED);
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_SETTER)); | STRUCT_PROC_SHAPE_SETTER));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]);
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) return (v == ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_GETTER)); | STRUCT_PROC_SHAPE_GETTER));
} else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER)

2
racket/src/racket/src/type.c
View File

@ -738,7 +738,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_noninline_proc_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object);
GC_REG_TRAV(scheme_prune_context_type, small_object); GC_REG_TRAV(scheme_prune_context_type, small_object);
GC_REG_TRAV(scheme_proc_shape_type, small_object); GC_REG_TRAV(scheme_proc_shape_type, struct_proc_shape);
GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj);
GC_REG_TRAV(scheme_environment_variables_type, small_object); GC_REG_TRAV(scheme_environment_variables_type, small_object);

4
racket/src/racket/src/validate.c
View File

@ -399,9 +399,9 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
} }
if (scheme_is_simple_make_struct_type(val, size-1, 1, 0, 1, NULL, if (scheme_is_simple_make_struct_type(val, size-1, 1, 0, 1, NULL,
&stinfo, &stinfo, NULL,
NULL, (_st_ht ? *_st_ht : NULL), NULL, (_st_ht ? *_st_ht : NULL),
NULL, 0, NULL, NULL, 5)) { NULL, 0, NULL, NULL, NULL, 5)) {
/* This set of bindings is constant across invocations, but /* This set of bindings is constant across invocations, but
if `uses_super', we need to increment tl_timestamp for if `uses_super', we need to increment tl_timestamp for
subtype-defining `struct' sequences. */ subtype-defining `struct' sequences. */

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

@ -37,6 +37,7 @@ READ_ONLY Scheme_Object *scheme_list_to_vector_proc;
READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc; READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc; READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc; READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc;
READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc;
/* locals */ /* locals */
static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
@ -212,7 +213,9 @@ scheme_init_unsafe_vector (Scheme_Env *env)
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_NARY_INLINED);
scheme_add_global_constant("unsafe-vector*-set!", p, env); scheme_add_global_constant("unsafe-vector*-set!", p, env);
REGISTER_SO(scheme_unsafe_struct_ref_proc);
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2); p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
scheme_unsafe_struct_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE); | SCHEME_PRIM_IS_OMITABLE);