improve structure-type property handling

Make the optimizer recognize and track `make-struct-property-type`
values, and use that information to recognize `make-struct-type`
calls that will defnitely succeed because a property that hs no
guard is given a value in the list of properties.

Combined with the change to require-keyword expansion, this
change allows the optimizer to inline `f` in

 (define (g y)
   (f #:x y))

 (define (f #:x x)
   (list x))

because the `make-struct-type` that appears between `g` and `f`
is determined to have no side-effect that would prevent `f` from
having its expected value.

pkgs/racket-doc/scribblings/raco/zo-struct.scrbl

@@ -142,6 +142,9 @@ returns.}
 @defstruct+[(predicate-shape struct-shape) ()]
 @defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])]
 @defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])]
+@defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])]
+@defstruct+[(property-predicate-shape struct-shape) ()]
+@defstruct+[(property-accessor-shape struct-shape) ()]
 @defstruct+[(struct-other-shape struct-shape) ()]
 )]{
 

pkgs/racket-test-core/tests/racket/optimize.rktl

@@ -4128,6 +4128,97 @@
                (a? (a-x (a 1 2)))
                5)))
 
+(test-comp '(lambda ()
+             (make-struct-type 'a #f 0 0 #f)
+             10)
+           '(lambda ()
+             10))
+
+(test-comp '(lambda ()
+             (make-struct-type-property 'a)
+             10)
+           '(lambda ()
+             10))
+
+(test-comp '(module m racket/base
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
+             (lambda (x)
+               (a? x)
+               (if a? (if a-ref x 11) 10)))
+           '(module m racket/base
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
+             (lambda (x)
+               x)))
+
+(test-comp '(module m racket/base
+             (define (f x) (list (g x) g))
+             ;; Defining and using a property doesn't interrupt a sequence
+             ;; of simultaneous definitions, so `g` above can be inlined
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           '(module m racket/base
+             (define (f x) (list (list x) g))
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y))))
+
+(test-comp '(module m racket/base
+             (define (f x) (list (g x) g))
+             ;; A property type with a guard inhibits inlining, because the
+             ;; guard might raise an error
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           '(module m racket/base
+             (define (f x) (list (list x) g))
+             (define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           #f)
+
+(module struct-type-property-a racket/base
+  (provide prop:a)
+  (define-values (prop:a a? a-ref) (make-struct-type-property 'a)))
+
+(test-comp '(module m racket/base
+             (require 'struct-type-property-a)
+             (define (f x) (list (g x) g))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           '(module m racket/base
+             (require 'struct-type-property-a)
+             (define (f x) (list (list x) g))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y))))
+
+(module struct-type-property-a-with-guard racket/base
+  (provide prop:a)
+  (define-values (prop:a a? a-ref) (make-struct-type-property 'a error)))
+
+(test-comp '(module m racket/base
+             (require 'struct-type-property-a-with-guard)
+             (define (f x) (list (g x) g))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           '(module m racket/base
+             (require 'struct-type-property-a-with-guard)
+             (define (f x) (list (list x) g))
+             (struct b () #:property prop:a 'a)
+             (define (g y) (list y)))
+           #f)
+
+;; A function with a required optional argument creates a pattern like
+;; the ones above, but intermediate points include extra references
+;; that make it difficult to check with `test-comp`
+#;
+(test-comp '(module m racket/base
+             (define (f x) (list (g #:x x)))
+             (define (g #:x y) (list y)))
+           '(module m racket/base
+             (define (f x) (list (list x)))
+             (define (g #:x y) (list y))))
+
 (test-comp `(lambda (b)
               (let ([v (unbox b)])
                 (with-continuation-mark 'x 'y (unbox v))))

pkgs/zo-lib/compiler/zo-marshal.rkt

@@ -627,7 +627,8 @@
        [(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root))))
         (out-byte CPT_ROOT_SCOPE out)]
        [(struct module-variable (modidx sym pos phase constantness))
-        (define (to-sym n) (string->symbol (format "struct~a" n)))
+        (define (to-sym #:prefix [prefix "struct"] n)
+          (string->symbol (format "~a~a" prefix n)))
         (out-byte CPT_MODULE_VAR out)
         (out-anything modidx out)
         (out-anything sym out)
@@ -664,6 +665,15 @@
                        [(mutator-shape? constantness)
                         (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
                                                                  4)))]
+                       [(struct-type-property-shape? constantness)
+                        (to-sym #:prefix "prop" 
+                                (if (struct-type-property-shape-has-guard? constantness)
+                                    1
+                                    0))]
+                       [(property-predicate-shape? constantness)
+                        (to-sym #:prefix "prop" 2)]
+                       [(property-accessor-shape? constantness)
+                        (to-sym #:prefix "prop" 3)]
                        [(struct-other-shape? constantness)
                         (to-sym 5)]
                        [else #f])

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -780,7 +780,7 @@
                                    (cond
                                     [shape
                                      (cond
-                                      [(number? shape) 
+                                      [(number? shape)
                                        (define n (arithmetic-shift shape -1))
                                        (make-function-shape (if (negative? n)
                                                                 (make-arity-at-least (sub1 (- n)))
@@ -796,6 +796,13 @@
                                          [(3) (make-accessor-shape (arithmetic-shift n -3))]
                                          [(4) (make-mutator-shape (arithmetic-shift n -3))]
                                          [else (make-struct-other-shape)])]
+                                      [(and (symbol? shape)
+                                            (regexp-match? #rx"^prop" (symbol->string shape)))
+                                       (define n (string->number (substring (symbol->string shape) 4)))
+                                       (case n
+                                         [(0 1) (make-struct-type-property-shape (= n 1))]
+                                         [(3) (make-property-predicate-shape)]
+                                         [else (make-property-accessor-shape)])]
                                       [else
                                        ;; parse symbol as ":"-separated sequence of arities
                                        (make-function-shape

pkgs/zo-lib/compiler/zo-structs.rkt

@@ -46,6 +46,9 @@
 (define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
 (define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
 (define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
+(define-form-struct (struct-type-property-shape struct-shape) ([has-guard? boolean?]))
+(define-form-struct (property-predicate-shape struct-shape) ())
+(define-form-struct (property-accessor-shape struct-shape) ())
 (define-form-struct (struct-other-shape struct-shape) ())
 
 ;; In toplevels of resove prefix:

racket/src/racket/src/compenv.c

@@ -1144,6 +1144,13 @@ Scheme_Object *scheme_intern_struct_proc_shape(int shape)
   return scheme_intern_symbol(buf);
 }
 
+Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape)
+{
+  char buf[20];
+  sprintf(buf, "prop%d", shape);
+  return scheme_intern_symbol(buf);
+}
+
 void scheme_dump_env(Scheme_Comp_Env *env)
 {
   Scheme_Comp_Env *frame;
@@ -1588,6 +1595,11 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
         *_inline_variant = mod_constant;
       is_constant = 2;
       shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant));
+    } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_prop_proc_shape_type)) {
+      if (_inline_variant)
+        *_inline_variant = mod_constant;
+      is_constant = 2;
+      shape = scheme_intern_struct_prop_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant));
     } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) {
       if (_inline_variant) {
         /* In case the inline variant includes references to module

racket/src/racket/src/eval.c

@@ -2031,11 +2031,17 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
 
       if (dm_env)
         is_st = 0;
+      else if (scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, 
+                                                 NULL, NULL, NULL, NULL,
+                                                 NULL, NULL, MZ_RUNSTACK, 0, 
+                                                 NULL, NULL, NULL, 5))
+        is_st = 1;
+      else if (scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, 
+                                                          NULL, NULL, NULL, NULL, MZ_RUNSTACK, 0, 
+                                                          NULL, NULL, 5))
+        is_st = 1;
       else
-        is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 0, 1, 
-                                                    NULL, NULL, NULL, NULL,
-                                                    NULL, NULL, MZ_RUNSTACK, 0, 
-                                                    NULL, NULL, NULL, 5);
+        is_st = 0;
 
       for (i = 0; i < g; i++) {
         var = SCHEME_VEC_ELS(vec)[i+delta];

racket/src/racket/src/fun.c

@@ -2568,11 +2568,16 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje
   Scheme_Object *p;
 
   if (expected 
-      && SCHEME_SYMBOLP(expected) 
-      && SCHEME_SYM_VAL(expected)[0] == 's') {
-    return (scheme_check_structure_shape(e, expected)
-            ? expected
-            : NULL);
+      && SCHEME_SYMBOLP(expected)) {
+    if (SCHEME_SYM_VAL(expected)[0] == 's') {
+      return (scheme_check_structure_shape(e, expected)
+              ? expected
+              : NULL);
+    } else if (SCHEME_SYM_VAL(expected)[0] == 'p') {
+      return (scheme_check_structure_property_shape(e, expected)
+              ? expected
+              : NULL);
+    }
   }
 
   if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))

racket/src/racket/src/module.c

@@ -4558,7 +4558,7 @@ 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;
+              int checked_st = 0, is_st_prop = 0, has_guard = 0;
               Scheme_Object *is_st = NULL;
               Simple_Stuct_Type_Info stinfo;
               Scheme_Object *parent_identity;
@@ -4597,14 +4597,24 @@ static void setup_accessible_table(Scheme_Module *m)
                           if (!checked_st) {
                             if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
                                                                   SCHEME_VEC_SIZE(form)-1,
-                                                                  1, 0, 1, NULL, &stinfo, &parent_identity,
+                                                                  CHECK_STRUCT_TYPE_RESOLVED,
+                                                                  NULL, &stinfo, &parent_identity,
                                                                   NULL, NULL, NULL, NULL, 0,
                                                                   m->prefix->toplevels, ht,
                                                                   &is_st,
                                                                   5)) {
                               is_st = scheme_make_pair(is_st, parent_identity);
-                            } else
+                            } else {
                               is_st = NULL;
+                              if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0],
+                                                                             SCHEME_VEC_SIZE(form)-1,
+                                                                             CHECK_STRUCT_TYPE_RESOLVED,
+                                                                             &has_guard,
+                                                                             NULL, NULL, NULL, NULL, 0,
+                                                                             m->prefix->toplevels, ht,
+                                                                             5))
+                                is_st_prop = 1;
+                            }
                             checked_st = 1;
                           }
                           if (is_st) {
@@ -4614,6 +4624,14 @@ static void setup_accessible_table(Scheme_Module *m)
                             v = scheme_make_vector(3, v);
                             SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
                             SCHEME_VEC_ELS(v)[2] = is_st;
+                          } else if (is_st_prop) {
+                            intptr_t shape;
+                            shape = scheme_get_struct_property_proc_shape(k-1, has_guard);
+                            /* Vector of size 4 => struct property shape */
+                            v = scheme_make_vector(4, v);
+                            SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
+                            SCHEME_VEC_ELS(v)[2] = scheme_false;
+                            SCHEME_VEC_ELS(v)[3] = scheme_false;
                           }
                         }
                         scheme_hash_set(ht, tl, v);
@@ -4843,14 +4861,24 @@ static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t
           if (SCHEME_VEC_SIZE(pos) == 2) {
             if (_is_constant)
               get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant);
-          } else {
+          } else if (SCHEME_VEC_SIZE(pos) == 3) {
             /* 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]),
                                                  SCHEME_VEC_ELS(pos)[2]);
 
+              *_is_constant = ps;
+            }
+          } else {
+            MZ_ASSERT(SCHEME_VEC_SIZE(pos) == 4);
+            /* vector of size 4 => struct property proc */
+            if (_is_constant) {
+              Scheme_Object *ps;
+
+              ps = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]));
+
               *_is_constant = ps;
             }
           }