diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index bc32b71108..b0c524c0ed 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -4026,6 +4026,71 @@ (list (c? (c-q (c 1 2 3)))) 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) (let ([v (unbox b)]) (with-continuation-mark 'x 'y (unbox v)))) diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 64adfb3cfd..95ed8ca56c 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -2033,9 +2033,9 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, is_st = 0; else 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, 5); + NULL, NULL, NULL, 5); for (i = 0; i < g; i++) { var = SCHEME_VEC_ELS(vec)[i+delta]; diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 3265f93d38..5f015730a0 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -4558,8 +4558,10 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; 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; + Scheme_Object *parent_identity; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4593,19 +4595,25 @@ static void setup_accessible_table(Scheme_Module *m) } } else { if (!checked_st) { - is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - 1, 0, 1, NULL, &stinfo, - NULL, NULL, NULL, 0, - m->prefix->toplevels, ht, - 5); + if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + 1, 0, 1, NULL, &stinfo, &parent_identity, + NULL, NULL, NULL, 0, + m->prefix->toplevels, ht, + &is_st, + 5)) { + is_st = scheme_make_pair(is_st, parent_identity); + } else + is_st = NULL; checked_st = 1; } if (is_st) { intptr_t shape; shape = scheme_get_struct_proc_shape(k-1, &stinfo); + /* Vector of size 3 => struct procedure */ v = scheme_make_vector(3, v); SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + SCHEME_VEC_ELS(v)[2] = is_st; } } 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) get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant); } else { + /* vector of size 3 => struct proc */ if (_is_constant) { 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; } diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index 0d08dc8e3f..083ba4e512 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -4408,3 +4408,41 @@ static int mark_log_reader_FIXUP(void *p, struct NewGC *gc) { #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 + + diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 6d5ef536b0..7f5fa9af90 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -1265,6 +1265,14 @@ mark_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; /**********************************************************************/ diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 8c7878e1de..213196a402 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -624,9 +624,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, Scheme_Object *auto_e; int 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), - NULL, NULL, 0, NULL, NULL, + NULL, NULL, 0, NULL, NULL, NULL, 5); if (auto_e) { 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)) break; 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++; - } else + } else { + if (SCHEME_INT_VAL(app3->args[2]) != (i - 4)) { + /* selectors are not in the usual order */ + normal_ops = 0; + } num_gets++; + } } else break; } 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 (num_gets) normal_ops = 0; num_sets++; - } else + } else { + if (SCHEME_INT_VAL(app3->rand2) != (i - 4)) normal_ops = 0; num_gets++; + } } else break; } @@ -1114,7 +1125,8 @@ static int is_constant_super(Scheme_Object *arg, Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_table, 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)? */ { 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)) { int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); 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; + } } } } 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)) { v = scheme_hash_get(symbol_table, name); 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]; if (v && SCHEME_INTP(v)) { 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, GC_CAN_IGNORE int *_auto_e_depth, Simple_Stuct_Type_Info *_stinfo, + Scheme_Object **_parent_identity, Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Object **_name, int fuel) /* 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 @@ -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])) { int super_count_plus_one; + if (_parent_identity) + *_parent_identity = scheme_null; if (!SCHEME_FALSEP(app->args[2])) super_count_plus_one = is_constant_super(app->args[2], top_level_consts, top_level_table, runstack, rs_delta + app->num_args, - symbols, symbol_table); + symbols, symbol_table, _parent_identity); else 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]))) { if (_auto_e_depth) *_auto_e_depth = (resolved ? app->num_args : 0); + if (_name) + *_name = app->args[1]; if (_stinfo) { int super_count = (super_count_plus_one ? (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]) + super_count); _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->indexed_ops = 0; _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; auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, must_always_succeed, check_auto, - _auto_e_depth, _stinfo, + _auto_e_depth, _stinfo, _parent_identity, top_level_consts, top_level_table, runstack, rs_delta, symbols, symbol_table, + _name, fuel-1); if (auto_e) { /* 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; auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, must_always_succeed, check_auto, - _auto_e_depth, _stinfo, + _auto_e_depth, _stinfo, _parent_identity, top_level_consts, top_level_table, runstack, rs_delta + lvd->count, symbols, symbol_table, + _name, fuel-1); if (auto_e) { /* 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; default: if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) { - if (k - 3 < stinfo->num_gets) - return STRUCT_PROC_SHAPE_GETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); - else - return STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); + if (k - 3 < stinfo->num_gets) { + /* record index of field */ + return (STRUCT_PROC_SHAPE_GETTER + | ((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; } -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; - 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; SCHEME_PROC_SHAPE_MODE(ps) = k; + SCHEME_PROC_SHAPE_IDENTITY(ps) = identity; 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) /* Not necessarily omittable or copyable, but single-valued expressions. 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); 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) { + if (!pred1 || !pred2) + return 0; + /* P => P */ if (SAME_OBJ(pred1, pred2)) return 1; @@ -4765,6 +4852,13 @@ static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2) || SAME_OBJ(pred1, scheme_flonum_p_proc))) 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; } @@ -4774,6 +4868,13 @@ static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2) return 0; if (SAME_OBJ(pred1, scheme_list_p_proc) && SAME_OBJ(pred2, scheme_pair_p_proc)) 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 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); } + 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)) { Scheme_App3_Rec *app = (Scheme_App3_Rec *)t; 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 simultaneous definitions: */ 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; vars = SCHEME_VEC_ELS(e)[0]; @@ -7896,13 +8007,15 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) sproc = 1; } } else if (scheme_is_simple_make_struct_type(e, n, 0, 0, 1, NULL, - &stinfo, + &stinfo, &parent_identity, info->top_level_consts, NULL, NULL, 0, NULL, NULL, + &sstruct, 5)) { - sstruct = 1; + sstruct = scheme_make_pair(sstruct, parent_identity); cnst = 1; - } + } else + sstruct = NULL; if (cnst) { Scheme_Toplevel *tl; @@ -7915,7 +8028,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) Scheme_Object *e2; 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) { e2 = scheme_make_noninline_proc(e); } else if (SCHEME_LAMBDAP(e)) { diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 74c5253c0a..084ac01c42 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -527,6 +527,7 @@ extern Scheme_Object *scheme_vector_ref_proc; extern Scheme_Object *scheme_vector_set_proc; extern Scheme_Object *scheme_list_to_vector_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_box_p_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 { int uses_super; - int field_count, init_field_count; - int normal_ops, indexed_ops, num_gets, num_sets; + int super_field_count; /* total fields (must == constructor-supplied fields) in superstruct */ + 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; Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int must_always_succeed, int check_auto, int *_auto_e_depth, Simple_Stuct_Type_Info *_stinfo, + Scheme_Object **_parent_identity, Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Object **_name, int fuel); Scheme_Object *scheme_intern_struct_proc_shape(int shape); 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_CONSTR 1 #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_MASK 0xF #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); int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 0bc85ea01c..c87691a8d7 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.6.0.1" +#define MZSCHEME_VERSION "6.6.0.2" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 6 #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) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 278389dc46..00dae6de55 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -3596,11 +3596,12 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) return (v == STRUCT_PROC_SHAPE_PRED); } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { 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)); } 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]; - return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + return (v == ((pos << STRUCT_PROC_SHAPE_SHIFT) | STRUCT_PROC_SHAPE_GETTER)); } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index 8b5df86b30..b7364792eb 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -738,7 +738,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_noninline_proc_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_environment_variables_type, small_object); diff --git a/racket/src/racket/src/validate.c b/racket/src/racket/src/validate.c index e25aac6e1d..558cfedb4f 100644 --- a/racket/src/racket/src/validate.c +++ b/racket/src/racket/src/validate.c @@ -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, - &stinfo, + &stinfo, 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 if `uses_super', we need to increment tl_timestamp for subtype-defining `struct' sequences. */ diff --git a/racket/src/racket/src/vector.c b/racket/src/racket/src/vector.c index dbfcb6ca2a..8c64867250 100644 --- a/racket/src/racket/src/vector.c +++ b/racket/src/racket/src/vector.c @@ -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_string_length_proc; READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc; /* locals */ 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_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); + scheme_unsafe_struct_ref_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE);