optimizer: connect struct predicates and accessors

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))

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))))

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];

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],
+                            if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
                                                                   SCHEME_VEC_SIZE(form)-1,
-                                                                        1, 0, 1, NULL, &stinfo,
+                                                                  1, 0, 1, NULL, &stinfo, &parent_identity,
                                                                   NULL, NULL, NULL, 0,
                                                                   m->prefix->toplevels, ht,
-                                                                        5);
+                                                                  &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;
             }

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
+
+

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;
 
 /**********************************************************************/

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,10 +1140,13 @@ 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)) {
     pos = SCHEME_TOPLEVEL_POS(arg);
     if (runstack) {
@@ -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)
+      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;
 }
 
-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;
 }
 
@@ -4775,6 +4869,13 @@ static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2)
   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: */
   return (!predicate_implies(pred1, pred2) && !predicate_implies(pred2, pred1));
@@ -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)) {

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 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;
 
 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);

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)

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)

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);

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. */

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);